source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 cmc
 135 cmc Sep-06: egb takes care of dynamic ss bonds too
 136 cmc
 137       if (dyn_ss) call dyn_set_nss
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141 #ifdef MPI
 142       time01=MPI_Wtime()
 143 #else
 144       time00=tcpu()
 145 #endif
 146 #endif
 147       call vec_and_deriv
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #else
 152       time_vec=time_vec+tcpu()-time01
 153 #endif
 154 #endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177 c        write (iout,*) "Soft-spheer ELEC potential"
 178         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179      &   eello_turn4)
 180       endif
 181 c      print *,"Processor",myrank," computed UELEC"
 182 C
 183 C Calculate excluded-volume interaction energy between peptide groups
 184 C and side chains.
 185 C
 186       if (ipot.lt.6) then
 187        if(wscp.gt.0d0) then
 188         call escp(evdw2,evdw2_14)
 189        else
 190         evdw2=0
 191         evdw2_14=0
 192        endif
 193       else
 194 c        write (iout,*) "Soft-sphere SCP potential"
 195         call escp_soft_sphere(evdw2,evdw2_14)
 196       endif
 197 c
 198 c Calculate the bond-stretching energy
 199 c
 200       call ebond(estr)
 201 C
 202 C Calculate the disulfide-bridge and other energy and the contributions
 203 C from other distance constraints.
 204 cd    print *,'Calling EHPB'
 205       call edis(ehpb)
 206 cd    print *,'EHPB exitted succesfully.'
 207 C
 208 C Calculate the virtual-bond-angle energy.
 209 C
 210       if (wang.gt.0d0) then
 211         call ebend(ebe)
 212       else
 213         ebe=0
 214       endif
 215 c      print *,"Processor",myrank," computed UB"
 216 C
 217 C Calculate the SC local energy.
 218 C
 219       call esc(escloc)
 220 c      print *,"Processor",myrank," computed USC"
 221 C
 222 C Calculate the virtual-bond torsional energy.
 223 C
 224 cd    print *,'nterm=',nterm
 225       if (wtor.gt.0) then
 226        call etor(etors,edihcnstr)
 227       else
 228        etors=0
 229        edihcnstr=0
 230       endif
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 c      print *,"Processor",myrank," computed Usccorr"
 250 C
 251 C 12/1/95 Multi-body terms
 252 C
 253       n_corr=0
 254       n_corr1=0
 255       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 256      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 257          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 258 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 259 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 260       else
 261          ecorr=0.0d0
 262          ecorr5=0.0d0
 263          ecorr6=0.0d0
 264          eturn6=0.0d0
 265       endif
 266       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 268 cd         write (iout,*) "multibody_hb ecorr",ecorr
 269       endif
 270 c      print *,"Processor",myrank," computed Ucorr"
 271 C
 272 C If performing constraint dynamics, call the constraint energy
 273 C  after the equilibration time
 274       if(usampl.and.totT.gt.eq_time) then
 275          call EconstrQ
 276          call Econstr_back
 277       else
 278          Uconst=0.0d0
 279          Uconst_back=0.0d0
 280       endif
 281 #ifdef TIMING
 282 #ifdef MPI
 283       time_enecalc=time_enecalc+MPI_Wtime()-time00
 284 #else
 285       time_enecalc=time_enecalc+tcpu()-time00
 286 #endif
 287 #endif
 288 c      print *,"Processor",myrank," computed Uconstr"
 289 #ifdef TIMING
 290 #ifdef MPI
 291       time00=MPI_Wtime()
 292 #else
 293       time00=tcpu()
 294 #endif
 295 #endif
 296 c
 297 C Sum the energies
 298 C
 299       energia(1)=evdw
 300 #ifdef SCP14
 301       energia(2)=evdw2-evdw2_14
 302       energia(18)=evdw2_14
 303 #else
 304       energia(2)=evdw2
 305       energia(18)=0.0d0
 306 #endif
 307 #ifdef SPLITELE
 308       energia(3)=ees
 309       energia(16)=evdw1
 310 #else
 311       energia(3)=ees+evdw1
 312       energia(16)=0.0d0
 313 #endif
 314       energia(4)=ecorr
 315       energia(5)=ecorr5
 316       energia(6)=ecorr6
 317       energia(7)=eel_loc
 318       energia(8)=eello_turn3
 319       energia(9)=eello_turn4
 320       energia(10)=eturn6
 321       energia(11)=ebe
 322       energia(12)=escloc
 323       energia(13)=etors
 324       energia(14)=etors_d
 325       energia(15)=ehpb
 326       energia(19)=edihcnstr
 327       energia(17)=estr
 328       energia(20)=Uconst+Uconst_back
 329       energia(21)=esccor
 330       energia(22)=evdw_p
 331       energia(23)=evdw_m
 332 c      print *," Processor",myrank," calls SUM_ENERGY"
 333       call sum_energy(energia,.true.)
 334 c      print *," Processor",myrank," left SUM_ENERGY"
 335 #ifdef TIMING
 336 #ifdef MPI
 337       time_sumene=time_sumene+MPI_Wtime()-time00
 338 #else
 339       time_sumene=time_sumene+tcpu()-time00
 340 #endif
 341 #endif
 342       return
 343       end
 344 c-------------------------------------------------------------------------------
 345       subroutine sum_energy(energia,reduce)
 346       implicit real*8 (a-h,o-z)
 347       include 'DIMENSIONS'
 348 #ifndef ISNAN
 349       external proc_proc
 350 #ifdef WINPGI
 351 cMS$ATTRIBUTES C ::  proc_proc
 352 #endif
 353 #endif
 354 #ifdef MPI
 355       include "mpif.h"
 356 #endif
 357       include 'COMMON.SETUP'
 358       include 'COMMON.IOUNITS'
 359       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 360       include 'COMMON.FFIELD'
 361       include 'COMMON.DERIV'
 362       include 'COMMON.INTERACT'
 363       include 'COMMON.SBRIDGE'
 364       include 'COMMON.CHAIN'
 365       include 'COMMON.VAR'
 366       include 'COMMON.CONTROL'
 367       include 'COMMON.TIME1'
 368       logical reduce
 369 #ifdef MPI
 370       if (nfgtasks.gt.1 .and. reduce) then
 371 #ifdef DEBUG
 372         write (iout,*) "energies before REDUCE"
 373         call enerprint(energia)
 374         call flush(iout)
 375 #endif
 376         do i=0,n_ene
 377           enebuff(i)=energia(i)
 378         enddo
 379         time00=MPI_Wtime()
 380         call MPI_Barrier(FG_COMM,IERR)
 381         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 382         time00=MPI_Wtime()
 383         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 384      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 385 #ifdef DEBUG
 386         write (iout,*) "energies after REDUCE"
 387         call enerprint(energia)
 388         call flush(iout)
 389 #endif
 390         time_Reduce=time_Reduce+MPI_Wtime()-time00
 391       endif
 392       if (fg_rank.eq.0) then
 393 #endif
 394 #ifdef TSCSC
 395       evdw=energia(22)+wsct*energia(23)
 396 #else
 397       evdw=energia(1)
 398 #endif
 399 #ifdef SCP14
 400       evdw2=energia(2)+energia(18)
 401       evdw2_14=energia(18)
 402 #else
 403       evdw2=energia(2)
 404 #endif
 405 #ifdef SPLITELE
 406       ees=energia(3)
 407       evdw1=energia(16)
 408 #else
 409       ees=energia(3)
 410       evdw1=0.0d0
 411 #endif
 412       ecorr=energia(4)
 413       ecorr5=energia(5)
 414       ecorr6=energia(6)
 415       eel_loc=energia(7)
 416       eello_turn3=energia(8)
 417       eello_turn4=energia(9)
 418       eturn6=energia(10)
 419       ebe=energia(11)
 420       escloc=energia(12)
 421       etors=energia(13)
 422       etors_d=energia(14)
 423       ehpb=energia(15)
 424       edihcnstr=energia(19)
 425       estr=energia(17)
 426       Uconst=energia(20)
 427       esccor=energia(21)
 428 #ifdef SPLITELE
 429       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor
 435 #else
 436       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 437      & +wang*ebe+wtor*etors+wscloc*escloc
 438      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 439      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 440      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 441      & +wbond*estr+Uconst+wsccor*esccor
 442 #endif
 443       energia(0)=etot
 444 c detecting NaNQ
 445 #ifdef ISNAN
 446 #ifdef AIX
 447       if (isnan(etot).ne.0) energia(0)=1.0d+99
 448 #else
 449       if (isnan(etot)) energia(0)=1.0d+99
 450 #endif
 451 #else
 452       i=0
 453 #ifdef WINPGI
 454       idumm=proc_proc(etot,i)
 455 #else
 456       call proc_proc(etot,i)
 457 #endif
 458       if(i.eq.1)energia(0)=1.0d+99
 459 #endif
 460 #ifdef MPI
 461       endif
 462 #endif
 463       return
 464       end
 465 c-------------------------------------------------------------------------------
 466       subroutine sum_gradient
 467       implicit real*8 (a-h,o-z)
 468       include 'DIMENSIONS'
 469 #ifndef ISNAN
 470       external proc_proc
 471 #ifdef WINPGI
 472 cMS$ATTRIBUTES C ::  proc_proc
 473 #endif
 474 #endif
 475 #ifdef MPI
 476       include 'mpif.h'
 477 #endif
 478       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 479      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 480       include 'COMMON.SETUP'
 481       include 'COMMON.IOUNITS'
 482       include 'COMMON.FFIELD'
 483       include 'COMMON.DERIV'
 484       include 'COMMON.INTERACT'
 485       include 'COMMON.SBRIDGE'
 486       include 'COMMON.CHAIN'
 487       include 'COMMON.VAR'
 488       include 'COMMON.CONTROL'
 489       include 'COMMON.TIME1'
 490       include 'COMMON.MAXGRAD'
 491       include 'COMMON.SCCOR'
 492 #ifdef TIMING
 493 #ifdef MPI
 494       time01=MPI_Wtime()
 495 #else
 496       time01=tcpu()
 497 #endif
 498 #endif
 499 #ifdef DEBUG
 500       write (iout,*) "sum_gradient gvdwc, gvdwx"
 501       do i=1,nres
 502         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 503      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 504      &   (gvdwcT(j,i),j=1,3)
 505       enddo
 506       call flush(iout)
 507 #endif
 508 #ifdef MPI
 509 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 510         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 511      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 512 #endif
 513 C
 514 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 515 C            in virtual-bond-vector coordinates
 516 C
 517 #ifdef DEBUG
 518 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 521 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 522 c      enddo
 523 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 524 c      do i=1,nres-1
 525 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 526 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 527 c      enddo
 528       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 529       do i=1,nres
 530         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 531      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 532      &   g_corr5_loc(i)
 533       enddo
 534       call flush(iout)
 535 #endif
 536 #ifdef SPLITELE
 537 #ifdef TSCSC
 538       do i=1,nct
 539         do j=1,3
 540           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 541      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 542      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 543      &                wel_loc*gel_loc_long(j,i)+
 544      &                wcorr*gradcorr_long(j,i)+
 545      &                wcorr5*gradcorr5_long(j,i)+
 546      &                wcorr6*gradcorr6_long(j,i)+
 547      &                wturn6*gcorr6_turn_long(j,i)+
 548      &                wstrain*ghpbc(j,i)
 549         enddo
 550       enddo
 551 #else
 552       do i=1,nct
 553         do j=1,3
 554           gradbufc(j,i)=wsc*gvdwc(j,i)+
 555      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 556      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 557      &                wel_loc*gel_loc_long(j,i)+
 558      &                wcorr*gradcorr_long(j,i)+
 559      &                wcorr5*gradcorr5_long(j,i)+
 560      &                wcorr6*gradcorr6_long(j,i)+
 561      &                wturn6*gcorr6_turn_long(j,i)+
 562      &                wstrain*ghpbc(j,i)
 563         enddo
 564       enddo
 565 #endif
 566 #else
 567       do i=1,nct
 568         do j=1,3
 569           gradbufc(j,i)=wsc*gvdwc(j,i)+
 570      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 571      &                welec*gelc_long(j,i)+
 572      &                wbond*gradb(j,i)+
 573      &                wel_loc*gel_loc_long(j,i)+
 574      &                wcorr*gradcorr_long(j,i)+
 575      &                wcorr5*gradcorr5_long(j,i)+
 576      &                wcorr6*gradcorr6_long(j,i)+
 577      &                wturn6*gcorr6_turn_long(j,i)+
 578      &                wstrain*ghpbc(j,i)
 579         enddo
 580       enddo
 581 #endif
 582 #ifdef MPI
 583       if (nfgtasks.gt.1) then
 584       time00=MPI_Wtime()
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc before allreduce"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       do i=1,nres
 593         do j=1,3
 594           gradbufc_sum(j,i)=gradbufc(j,i)
 595         enddo
 596       enddo
 597 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 598 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 599 c      time_reduce=time_reduce+MPI_Wtime()-time00
 600 #ifdef DEBUG
 601 c      write (iout,*) "gradbufc_sum after allreduce"
 602 c      do i=1,nres
 603 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 604 c      enddo
 605 c      call flush(iout)
 606 #endif
 607 #ifdef TIMING
 608 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 609 #endif
 610       do i=nnt,nres
 611         do k=1,3
 612           gradbufc(k,i)=0.0d0
 613         enddo
 614       enddo
 615 #ifdef DEBUG
 616       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 617       write (iout,*) (i," jgrad_start",jgrad_start(i),
 618      &                  " jgrad_end  ",jgrad_end(i),
 619      &                  i=igrad_start,igrad_end)
 620 #endif
 621 c
 622 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 623 c do not parallelize this part.
 624 c
 625 c      do i=igrad_start,igrad_end
 626 c        do j=jgrad_start(i),jgrad_end(i)
 627 c          do k=1,3
 628 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 629 c          enddo
 630 c        enddo
 631 c      enddo
 632       do j=1,3
 633         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 634       enddo
 635       do i=nres-2,nnt,-1
 636         do j=1,3
 637           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 638         enddo
 639       enddo
 640 #ifdef DEBUG
 641       write (iout,*) "gradbufc after summing"
 642       do i=1,nres
 643         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 644       enddo
 645       call flush(iout)
 646 #endif
 647       else
 648 #endif
 649 #ifdef DEBUG
 650       write (iout,*) "gradbufc"
 651       do i=1,nres
 652         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 653       enddo
 654       call flush(iout)
 655 #endif
 656       do i=1,nres
 657         do j=1,3
 658           gradbufc_sum(j,i)=gradbufc(j,i)
 659           gradbufc(j,i)=0.0d0
 660         enddo
 661       enddo
 662       do j=1,3
 663         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 664       enddo
 665       do i=nres-2,nnt,-1
 666         do j=1,3
 667           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 668         enddo
 669       enddo
 670 c      do i=nnt,nres-1
 671 c        do k=1,3
 672 c          gradbufc(k,i)=0.0d0
 673 c        enddo
 674 c        do j=i+1,nres
 675 c          do k=1,3
 676 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 677 c          enddo
 678 c        enddo
 679 c      enddo
 680 #ifdef DEBUG
 681       write (iout,*) "gradbufc after summing"
 682       do i=1,nres
 683         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 684       enddo
 685       call flush(iout)
 686 #endif
 687 #ifdef MPI
 688       endif
 689 #endif
 690       do k=1,3
 691         gradbufc(k,nres)=0.0d0
 692       enddo
 693       do i=1,nct
 694         do j=1,3
 695 #ifdef SPLITELE
 696           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 697      &                wel_loc*gel_loc(j,i)+
 698      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 699      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 700      &                wel_loc*gel_loc_long(j,i)+
 701      &                wcorr*gradcorr_long(j,i)+
 702      &                wcorr5*gradcorr5_long(j,i)+
 703      &                wcorr6*gradcorr6_long(j,i)+
 704      &                wturn6*gcorr6_turn_long(j,i))+
 705      &                wbond*gradb(j,i)+
 706      &                wcorr*gradcorr(j,i)+
 707      &                wturn3*gcorr3_turn(j,i)+
 708      &                wturn4*gcorr4_turn(j,i)+
 709      &                wcorr5*gradcorr5(j,i)+
 710      &                wcorr6*gradcorr6(j,i)+
 711      &                wturn6*gcorr6_turn(j,i)+
 712      &                wsccor*gsccorc(j,i)
 713      &               +wscloc*gscloc(j,i)
 714 #else
 715           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 716      &                wel_loc*gel_loc(j,i)+
 717      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 718      &                welec*gelc_long(j,i)+
 719      &                wel_loc*gel_loc_long(j,i)+
 720      &                wcorr*gcorr_long(j,i)+
 721      &                wcorr5*gradcorr5_long(j,i)+
 722      &                wcorr6*gradcorr6_long(j,i)+
 723      &                wturn6*gcorr6_turn_long(j,i))+
 724      &                wbond*gradb(j,i)+
 725      &                wcorr*gradcorr(j,i)+
 726      &                wturn3*gcorr3_turn(j,i)+
 727      &                wturn4*gcorr4_turn(j,i)+
 728      &                wcorr5*gradcorr5(j,i)+
 729      &                wcorr6*gradcorr6(j,i)+
 730      &                wturn6*gcorr6_turn(j,i)+
 731      &                wsccor*gsccorc(j,i)
 732      &               +wscloc*gscloc(j,i)
 733 #endif
 734 #ifdef TSCSC
 735           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 736      &                  wscp*gradx_scp(j,i)+
 737      &                  wbond*gradbx(j,i)+
 738      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 739      &                  wsccor*gsccorx(j,i)
 740      &                 +wscloc*gsclocx(j,i)
 741 #else
 742           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 743      &                  wbond*gradbx(j,i)+
 744      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 745      &                  wsccor*gsccorx(j,i)
 746      &                 +wscloc*gsclocx(j,i)
 747 #endif
 748         enddo
 749       enddo
 750 #ifdef DEBUG
 751       write (iout,*) "gloc before adding corr"
 752       do i=1,4*nres
 753         write (iout,*) i,gloc(i,icg)
 754       enddo
 755 #endif
 756       do i=1,nres-3
 757         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 758      &   +wcorr5*g_corr5_loc(i)
 759      &   +wcorr6*g_corr6_loc(i)
 760      &   +wturn4*gel_loc_turn4(i)
 761      &   +wturn3*gel_loc_turn3(i)
 762      &   +wturn6*gel_loc_turn6(i)
 763      &   +wel_loc*gel_loc_loc(i)
 764       enddo
 765 #ifdef DEBUG
 766       write (iout,*) "gloc after adding corr"
 767       do i=1,4*nres
 768         write (iout,*) i,gloc(i,icg)
 769       enddo
 770 #endif
 771 #ifdef MPI
 772       if (nfgtasks.gt.1) then
 773         do j=1,3
 774           do i=1,nres
 775             gradbufc(j,i)=gradc(j,i,icg)
 776             gradbufx(j,i)=gradx(j,i,icg)
 777           enddo
 778         enddo
 779         do i=1,4*nres
 780           glocbuf(i)=gloc(i,icg)
 781         enddo
 782 #ifdef DEBUG
 783       write (iout,*) "gloc_sc before reduce"
 784       do i=1,nres
 785        do j=1,3
 786         write (iout,*) i,j,gloc_sc(j,i,icg)
 787        enddo
 788       enddo
 789 #endif
 790         do i=1,nres
 791          do j=1,3
 792           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 793          enddo
 794         enddo
 795         time00=MPI_Wtime()
 796         call MPI_Barrier(FG_COMM,IERR)
 797         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 798         time00=MPI_Wtime()
 799         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 800      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 801         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 802      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 803         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 806      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 807         time_reduce=time_reduce+MPI_Wtime()-time00
 808 #ifdef DEBUG
 809       write (iout,*) "gloc_sc after reduce"
 810       do i=1,nres
 811        do j=1,3
 812         write (iout,*) i,j,gloc_sc(j,i,icg)
 813        enddo
 814       enddo
 815 #endif
 816 #ifdef DEBUG
 817       write (iout,*) "gloc after reduce"
 818       do i=1,4*nres
 819         write (iout,*) i,gloc(i,icg)
 820       enddo
 821 #endif
 822       endif
 823 #endif
 824       if (gnorm_check) then
 825 c
 826 c Compute the maximum elements of the gradient
 827 c
 828       gvdwc_max=0.0d0
 829       gvdwc_scp_max=0.0d0
 830       gelc_max=0.0d0
 831       gvdwpp_max=0.0d0
 832       gradb_max=0.0d0
 833       ghpbc_max=0.0d0
 834       gradcorr_max=0.0d0
 835       gel_loc_max=0.0d0
 836       gcorr3_turn_max=0.0d0
 837       gcorr4_turn_max=0.0d0
 838       gradcorr5_max=0.0d0
 839       gradcorr6_max=0.0d0
 840       gcorr6_turn_max=0.0d0
 841       gsccorc_max=0.0d0
 842       gscloc_max=0.0d0
 843       gvdwx_max=0.0d0
 844       gradx_scp_max=0.0d0
 845       ghpbx_max=0.0d0
 846       gradxorr_max=0.0d0
 847       gsccorx_max=0.0d0
 848       gsclocx_max=0.0d0
 849       do i=1,nct
 850         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 851         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 852 #ifdef TSCSC
 853         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 854         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 855 #endif
 856         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 857         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 858      &   gvdwc_scp_max=gvdwc_scp_norm
 859         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 860         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 861         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 862         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 863         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 864         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 865         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 866         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 867         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 868         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 869         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 870         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 871         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 872      &    gcorr3_turn(1,i)))
 873         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 874      &    gcorr3_turn_max=gcorr3_turn_norm
 875         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 876      &    gcorr4_turn(1,i)))
 877         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 878      &    gcorr4_turn_max=gcorr4_turn_norm
 879         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 880         if (gradcorr5_norm.gt.gradcorr5_max)
 881      &    gradcorr5_max=gradcorr5_norm
 882         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 883         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 884         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 885      &    gcorr6_turn(1,i)))
 886         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 887      &    gcorr6_turn_max=gcorr6_turn_norm
 888         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 889         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 890         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 891         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 892         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 893         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 894 #ifdef TSCSC
 895         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 896         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 897 #endif
 898         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 899         if (gradx_scp_norm.gt.gradx_scp_max)
 900      &    gradx_scp_max=gradx_scp_norm
 901         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 902         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 903         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 904         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 905         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 906         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 907         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 908         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 909       enddo
 910       if (gradout) then
 911 #ifdef AIX
 912         open(istat,file=statname,position="append")
 913 #else
 914         open(istat,file=statname,access="append")
 915 #endif
 916         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 917      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 918      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 919      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 920      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 921      &     gsccorx_max,gsclocx_max
 922         close(istat)
 923         if (gvdwc_max.gt.1.0d4) then
 924           write (iout,*) "gvdwc gvdwx gradb gradbx"
 925           do i=nnt,nct
 926             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 927      &        gradb(j,i),gradbx(j,i),j=1,3)
 928           enddo
 929           call pdbout(0.0d0,'cipiszcze',iout)
 930           call flush(iout)
 931         endif
 932       endif
 933       endif
 934 #ifdef DEBUG
 935       write (iout,*) "gradc gradx gloc"
 936       do i=1,nres
 937         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 938      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 939       enddo
 940 #endif
 941 #ifdef TIMING
 942 #ifdef MPI
 943       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 944 #else
 945       time_sumgradient=time_sumgradient+tcpu()-time01
 946 #endif
 947 #endif
 948       return
 949       end
 950 c-------------------------------------------------------------------------------
 951       subroutine rescale_weights(t_bath)
 952       implicit real*8 (a-h,o-z)
 953       include 'DIMENSIONS'
 954       include 'COMMON.IOUNITS'
 955       include 'COMMON.FFIELD'
 956       include 'COMMON.SBRIDGE'
 957       double precision kfac /2.4d0/
 958       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 959 c      facT=temp0/t_bath
 960 c      facT=2*temp0/(t_bath+temp0)
 961       if (rescale_mode.eq.0) then
 962         facT=1.0d0
 963         facT2=1.0d0
 964         facT3=1.0d0
 965         facT4=1.0d0
 966         facT5=1.0d0
 967       else if (rescale_mode.eq.1) then
 968         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 969         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 970         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 971         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 972         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 973       else if (rescale_mode.eq.2) then
 974         x=t_bath/temp0
 975         x2=x*x
 976         x3=x2*x
 977         x4=x3*x
 978         x5=x4*x
 979         facT=licznik/dlog(dexp(x)+dexp(-x))
 980         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 981         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 982         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 983         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 984       else
 985         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 986         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 987 #ifdef MPI
 988        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 989 #endif
 990        stop 555
 991       endif
 992       welec=weights(3)*fact
 993       wcorr=weights(4)*fact3
 994       wcorr5=weights(5)*fact4
 995       wcorr6=weights(6)*fact5
 996       wel_loc=weights(7)*fact2
 997       wturn3=weights(8)*fact2
 998       wturn4=weights(9)*fact3
 999       wturn6=weights(10)*fact5
1000       wtor=weights(13)*fact
1001       wtor_d=weights(14)*fact2
1002       wsccor=weights(21)*fact
1003 #ifdef TSCSC
1004 c      wsct=t_bath/temp0
1005       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1006 #endif
1007       return
1008       end
1009 C------------------------------------------------------------------------
1010       subroutine enerprint(energia)
1011       implicit real*8 (a-h,o-z)
1012       include 'DIMENSIONS'
1013       include 'COMMON.IOUNITS'
1014       include 'COMMON.FFIELD'
1015       include 'COMMON.SBRIDGE'
1016       include 'COMMON.MD'
1017       double precision energia(0:n_ene)
1018       etot=energia(0)
1019 #ifdef TSCSC
1020       evdw=energia(22)+wsct*energia(23)
1021 #else
1022       evdw=energia(1)
1023 #endif
1024       evdw2=energia(2)
1025 #ifdef SCP14
1026       evdw2=energia(2)+energia(18)
1027 #else
1028       evdw2=energia(2)
1029 #endif
1030       ees=energia(3)
1031 #ifdef SPLITELE
1032       evdw1=energia(16)
1033 #endif
1034       ecorr=energia(4)
1035       ecorr5=energia(5)
1036       ecorr6=energia(6)
1037       eel_loc=energia(7)
1038       eello_turn3=energia(8)
1039       eello_turn4=energia(9)
1040       eello_turn6=energia(10)
1041       ebe=energia(11)
1042       escloc=energia(12)
1043       etors=energia(13)
1044       etors_d=energia(14)
1045       ehpb=energia(15)
1046       edihcnstr=energia(19)
1047       estr=energia(17)
1048       Uconst=energia(20)
1049       esccor=energia(21)
1050 #ifdef SPLITELE
1051       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1052      &  estr,wbond,ebe,wang,
1053      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1054      &  ecorr,wcorr,
1055      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1056      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1057      &  edihcnstr,ebr*nss,
1058      &  Uconst,etot
1059    10 format (/'Virtual-chain energies:'//
1060      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1061      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1062      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1063      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1064      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1065      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1066      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1067      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1068      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1069      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1070      & ' (SS bridges & dist. cnstr.)'/
1071      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1072      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1073      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1074      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1075      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1076      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1077      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1078      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1079      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1080      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1081      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1082      & 'ETOT=  ',1pE16.6,' (total)')
1083 #else
1084       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1085      &  estr,wbond,ebe,wang,
1086      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1087      &  ecorr,wcorr,
1088      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1089      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1090      &  ebr*nss,Uconst,etot
1091    10 format (/'Virtual-chain energies:'//
1092      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1093      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1094      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1095      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1096      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1097      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1098      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1099      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1100      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1101      & ' (SS bridges & dist. cnstr.)'/
1102      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1105      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1106      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1107      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1108      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1109      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1110      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1111      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1112      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1113      & 'ETOT=  ',1pE16.6,' (total)')
1114 #endif
1115       return
1116       end
1117 C-----------------------------------------------------------------------
1118       subroutine elj(evdw,evdw_p,evdw_m)
1119 C
1120 C This subroutine calculates the interaction energy of nonbonded side chains
1121 C assuming the LJ potential of interaction.
1122 C
1123       implicit real*8 (a-h,o-z)
1124       include 'DIMENSIONS'
1125       parameter (accur=1.0d-10)
1126       include 'COMMON.GEO'
1127       include 'COMMON.VAR'
1128       include 'COMMON.LOCAL'
1129       include 'COMMON.CHAIN'
1130       include 'COMMON.DERIV'
1131       include 'COMMON.INTERACT'
1132       include 'COMMON.TORSION'
1133       include 'COMMON.SBRIDGE'
1134       include 'COMMON.NAMES'
1135       include 'COMMON.IOUNITS'
1136       include 'COMMON.CONTACTS'
1137       dimension gg(3)
1138 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1139       evdw=0.0D0
1140       do i=iatsc_s,iatsc_e
1141         itypi=itype(i)
1142         itypi1=itype(i+1)
1143         xi=c(1,nres+i)
1144         yi=c(2,nres+i)
1145         zi=c(3,nres+i)
1146 C Change 12/1/95
1147         num_conti=0
1148 C
1149 C Calculate SC interaction energy.
1150 C
1151         do iint=1,nint_gr(i)
1152 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1153 cd   &                  'iend=',iend(i,iint)
1154           do j=istart(i,iint),iend(i,iint)
1155             itypj=itype(j)
1156             xj=c(1,nres+j)-xi
1157             yj=c(2,nres+j)-yi
1158             zj=c(3,nres+j)-zi
1159 C Change 12/1/95 to calculate four-body interactions
1160             rij=xj*xj+yj*yj+zj*zj
1161             rrij=1.0D0/rij
1162 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1163             eps0ij=eps(itypi,itypj)
1164             fac=rrij**expon2
1165             e1=fac*fac*aa(itypi,itypj)
1166             e2=fac*bb(itypi,itypj)
1167             evdwij=e1+e2
1168 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1169 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1170 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1171 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1172 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1173 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1174 #ifdef TSCSC
1175             if (bb(itypi,itypj).gt.0) then
1176                evdw_p=evdw_p+evdwij
1177             else
1178                evdw_m=evdw_m+evdwij
1179             endif
1180 #else
1181             evdw=evdw+evdwij
1182 #endif
1183 C
1184 C Calculate the components of the gradient in DC and X
1185 C
1186             fac=-rrij*(e1+evdwij)
1187             gg(1)=xj*fac
1188             gg(2)=yj*fac
1189             gg(3)=zj*fac
1190 #ifdef TSCSC
1191             if (bb(itypi,itypj).gt.0.0d0) then
1192               do k=1,3
1193                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1194                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1195                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1196                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1197               enddo
1198             else
1199               do k=1,3
1200                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1201                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1202                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1203                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1204               enddo
1205             endif
1206 #else
1207             do k=1,3
1208               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1209               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1210               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1211               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1212             enddo
1213 #endif
1214 cgrad            do k=i,j-1
1215 cgrad              do l=1,3
1216 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1217 cgrad              enddo
1218 cgrad            enddo
1219 C
1220 C 12/1/95, revised on 5/20/97
1221 C
1222 C Calculate the contact function. The ith column of the array JCONT will
1223 C contain the numbers of atoms that make contacts with the atom I (of numbers
1224 C greater than I). The arrays FACONT and GACONT will contain the values of
1225 C the contact function and its derivative.
1226 C
1227 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1228 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1229 C Uncomment next line, if the correlation interactions are contact function only
1230             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1231               rij=dsqrt(rij)
1232               sigij=sigma(itypi,itypj)
1233               r0ij=rs0(itypi,itypj)
1234 C
1235 C Check whether the SC's are not too far to make a contact.
1236 C
1237               rcut=1.5d0*r0ij
1238               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1239 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1240 C
1241               if (fcont.gt.0.0D0) then
1242 C If the SC-SC distance if close to sigma, apply spline.
1243 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1244 cAdam &             fcont1,fprimcont1)
1245 cAdam           fcont1=1.0d0-fcont1
1246 cAdam           if (fcont1.gt.0.0d0) then
1247 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1248 cAdam             fcont=fcont*fcont1
1249 cAdam           endif
1250 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1251 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1252 cga             do k=1,3
1253 cga               gg(k)=gg(k)*eps0ij
1254 cga             enddo
1255 cga             eps0ij=-evdwij*eps0ij
1256 C Uncomment for AL's type of SC correlation interactions.
1257 cadam           eps0ij=-evdwij
1258                 num_conti=num_conti+1
1259                 jcont(num_conti,i)=j
1260                 facont(num_conti,i)=fcont*eps0ij
1261                 fprimcont=eps0ij*fprimcont/rij
1262                 fcont=expon*fcont
1263 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1264 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1265 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1266 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1267                 gacont(1,num_conti,i)=-fprimcont*xj
1268                 gacont(2,num_conti,i)=-fprimcont*yj
1269                 gacont(3,num_conti,i)=-fprimcont*zj
1270 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1271 cd              write (iout,'(2i3,3f10.5)')
1272 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1273               endif
1274             endif
1275           enddo      ! j
1276         enddo        ! iint
1277 C Change 12/1/95
1278         num_cont(i)=num_conti
1279       enddo          ! i
1280       do i=1,nct
1281         do j=1,3
1282           gvdwc(j,i)=expon*gvdwc(j,i)
1283           gvdwx(j,i)=expon*gvdwx(j,i)
1284         enddo
1285       enddo
1286 C******************************************************************************
1287 C
1288 C                              N O T E !!!
1289 C
1290 C To save time, the factor of EXPON has been extracted from ALL components
1291 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1292 C use!
1293 C
1294 C******************************************************************************
1295       return
1296       end
1297 C-----------------------------------------------------------------------------
1298       subroutine eljk(evdw,evdw_p,evdw_m)
1299 C
1300 C This subroutine calculates the interaction energy of nonbonded side chains
1301 C assuming the LJK potential of interaction.
1302 C
1303       implicit real*8 (a-h,o-z)
1304       include 'DIMENSIONS'
1305       include 'COMMON.GEO'
1306       include 'COMMON.VAR'
1307       include 'COMMON.LOCAL'
1308       include 'COMMON.CHAIN'
1309       include 'COMMON.DERIV'
1310       include 'COMMON.INTERACT'
1311       include 'COMMON.IOUNITS'
1312       include 'COMMON.NAMES'
1313       dimension gg(3)
1314       logical scheck
1315 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1316       evdw=0.0D0
1317       do i=iatsc_s,iatsc_e
1318         itypi=itype(i)
1319         itypi1=itype(i+1)
1320         xi=c(1,nres+i)
1321         yi=c(2,nres+i)
1322         zi=c(3,nres+i)
1323 C
1324 C Calculate SC interaction energy.
1325 C
1326         do iint=1,nint_gr(i)
1327           do j=istart(i,iint),iend(i,iint)
1328             itypj=itype(j)
1329             xj=c(1,nres+j)-xi
1330             yj=c(2,nres+j)-yi
1331             zj=c(3,nres+j)-zi
1332             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1333             fac_augm=rrij**expon
1334             e_augm=augm(itypi,itypj)*fac_augm
1335             r_inv_ij=dsqrt(rrij)
1336             rij=1.0D0/r_inv_ij
1337             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1338             fac=r_shift_inv**expon
1339             e1=fac*fac*aa(itypi,itypj)
1340             e2=fac*bb(itypi,itypj)
1341             evdwij=e_augm+e1+e2
1342 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1343 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1344 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1345 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1346 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1347 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1348 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1349 #ifdef TSCSC
1350             if (bb(itypi,itypj).gt.0) then
1351                evdw_p=evdw_p+evdwij
1352             else
1353                evdw_m=evdw_m+evdwij
1354             endif
1355 #else
1356             evdw=evdw+evdwij
1357 #endif
1358 C
1359 C Calculate the components of the gradient in DC and X
1360 C
1361             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1362             gg(1)=xj*fac
1363             gg(2)=yj*fac
1364             gg(3)=zj*fac
1365 #ifdef TSCSC
1366             if (bb(itypi,itypj).gt.0.0d0) then
1367               do k=1,3
1368                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1369                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1370                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1371                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1372               enddo
1373             else
1374               do k=1,3
1375                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1376                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1377                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1378                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1379               enddo
1380             endif
1381 #else
1382             do k=1,3
1383               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1384               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1385               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1386               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1387             enddo
1388 #endif
1389 cgrad            do k=i,j-1
1390 cgrad              do l=1,3
1391 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1392 cgrad              enddo
1393 cgrad            enddo
1394           enddo      ! j
1395         enddo        ! iint
1396       enddo          ! i
1397       do i=1,nct
1398         do j=1,3
1399           gvdwc(j,i)=expon*gvdwc(j,i)
1400           gvdwx(j,i)=expon*gvdwx(j,i)
1401         enddo
1402       enddo
1403       return
1404       end
1405 C-----------------------------------------------------------------------------
1406       subroutine ebp(evdw,evdw_p,evdw_m)
1407 C
1408 C This subroutine calculates the interaction energy of nonbonded side chains
1409 C assuming the Berne-Pechukas potential of interaction.
1410 C
1411       implicit real*8 (a-h,o-z)
1412       include 'DIMENSIONS'
1413       include 'COMMON.GEO'
1414       include 'COMMON.VAR'
1415       include 'COMMON.LOCAL'
1416       include 'COMMON.CHAIN'
1417       include 'COMMON.DERIV'
1418       include 'COMMON.NAMES'
1419       include 'COMMON.INTERACT'
1420       include 'COMMON.IOUNITS'
1421       include 'COMMON.CALC'
1422       common /srutu/ icall
1423 c     double precision rrsave(maxdim)
1424       logical lprn
1425       evdw=0.0D0
1426 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1427       evdw=0.0D0
1428 c     if (icall.eq.0) then
1429 c       lprn=.true.
1430 c     else
1431         lprn=.false.
1432 c     endif
1433       ind=0
1434       do i=iatsc_s,iatsc_e
1435         itypi=itype(i)
1436         itypi1=itype(i+1)
1437         xi=c(1,nres+i)
1438         yi=c(2,nres+i)
1439         zi=c(3,nres+i)
1440         dxi=dc_norm(1,nres+i)
1441         dyi=dc_norm(2,nres+i)
1442         dzi=dc_norm(3,nres+i)
1443 c        dsci_inv=dsc_inv(itypi)
1444         dsci_inv=vbld_inv(i+nres)
1445 C
1446 C Calculate SC interaction energy.
1447 C
1448         do iint=1,nint_gr(i)
1449           do j=istart(i,iint),iend(i,iint)
1450             ind=ind+1
1451             itypj=itype(j)
1452 c            dscj_inv=dsc_inv(itypj)
1453             dscj_inv=vbld_inv(j+nres)
1454             chi1=chi(itypi,itypj)
1455             chi2=chi(itypj,itypi)
1456             chi12=chi1*chi2
1457             chip1=chip(itypi)
1458             chip2=chip(itypj)
1459             chip12=chip1*chip2
1460             alf1=alp(itypi)
1461             alf2=alp(itypj)
1462             alf12=0.5D0*(alf1+alf2)
1463 C For diagnostics only!!!
1464 c           chi1=0.0D0
1465 c           chi2=0.0D0
1466 c           chi12=0.0D0
1467 c           chip1=0.0D0
1468 c           chip2=0.0D0
1469 c           chip12=0.0D0
1470 c           alf1=0.0D0
1471 c           alf2=0.0D0
1472 c           alf12=0.0D0
1473             xj=c(1,nres+j)-xi
1474             yj=c(2,nres+j)-yi
1475             zj=c(3,nres+j)-zi
1476             dxj=dc_norm(1,nres+j)
1477             dyj=dc_norm(2,nres+j)
1478             dzj=dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480 cd          if (icall.eq.0) then
1481 cd            rrsave(ind)=rrij
1482 cd          else
1483 cd            rrij=rrsave(ind)
1484 cd          endif
1485             rij=dsqrt(rrij)
1486 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1487             call sc_angular
1488 C Calculate whole angle-dependent part of epsilon and contributions
1489 C to its derivatives
1490             fac=(rrij*sigsq)**expon2
1491             e1=fac*fac*aa(itypi,itypj)
1492             e2=fac*bb(itypi,itypj)
1493             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1494             eps2der=evdwij*eps3rt
1495             eps3der=evdwij*eps2rt
1496             evdwij=evdwij*eps2rt*eps3rt
1497 #ifdef TSCSC
1498             if (bb(itypi,itypj).gt.0) then
1499                evdw_p=evdw_p+evdwij
1500             else
1501                evdw_m=evdw_m+evdwij
1502             endif
1503 #else
1504             evdw=evdw+evdwij
1505 #endif
1506             if (lprn) then
1507             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1508             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1509 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1510 cd     &        restyp(itypi),i,restyp(itypj),j,
1511 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1512 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1513 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1514 cd     &        evdwij
1515             endif
1516 C Calculate gradient components.
1517             e1=e1*eps1*eps2rt**2*eps3rt**2
1518             fac=-expon*(e1+evdwij)
1519             sigder=fac/sigsq
1520             fac=rrij*fac
1521 C Calculate radial part of the gradient
1522             gg(1)=xj*fac
1523             gg(2)=yj*fac
1524             gg(3)=zj*fac
1525 C Calculate the angular part of the gradient and sum add the contributions
1526 C to the appropriate components of the Cartesian gradient.
1527 #ifdef TSCSC
1528             if (bb(itypi,itypj).gt.0) then
1529                call sc_grad
1530             else
1531                call sc_grad_T
1532             endif
1533 #else
1534             call sc_grad
1535 #endif
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c     stop
1540       return
1541       end
1542 C-----------------------------------------------------------------------------
1543       subroutine egb(evdw,evdw_p,evdw_m)
1544 C
1545 C This subroutine calculates the interaction energy of nonbonded side chains
1546 C assuming the Gay-Berne potential of interaction.
1547 C
1548       implicit real*8 (a-h,o-z)
1549       include 'DIMENSIONS'
1550       include 'COMMON.GEO'
1551       include 'COMMON.VAR'
1552       include 'COMMON.LOCAL'
1553       include 'COMMON.CHAIN'
1554       include 'COMMON.DERIV'
1555       include 'COMMON.NAMES'
1556       include 'COMMON.INTERACT'
1557       include 'COMMON.IOUNITS'
1558       include 'COMMON.CALC'
1559       include 'COMMON.CONTROL'
1560       include 'COMMON.SBRIDGE'
1561       logical lprn
1562       evdw=0.0D0
1563 ccccc      energy_dec=.false.
1564 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1565       evdw=0.0D0
1566       evdw_p=0.0D0
1567       evdw_m=0.0D0
1568       lprn=.false.
1569 c     if (icall.eq.0) lprn=.false.
1570       ind=0
1571       do i=iatsc_s,iatsc_e
1572         itypi=itype(i)
1573         itypi1=itype(i+1)
1574         xi=c(1,nres+i)
1575         yi=c(2,nres+i)
1576         zi=c(3,nres+i)
1577         dxi=dc_norm(1,nres+i)
1578         dyi=dc_norm(2,nres+i)
1579         dzi=dc_norm(3,nres+i)
1580 c        dsci_inv=dsc_inv(itypi)
1581         dsci_inv=vbld_inv(i+nres)
1582 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1583 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1584 C
1585 C Calculate SC interaction energy.
1586 C
1587         do iint=1,nint_gr(i)
1588           do j=istart(i,iint),iend(i,iint)
1589             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1590               call dyn_ssbond_ene(i,j,evdwij)
1591               evdw=evdw+evdwij
1592               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1593      &                        'evdw',i,j,evdwij,' ss'
1594             ELSE
1595             ind=ind+1
1596             itypj=itype(j)
1597 c            dscj_inv=dsc_inv(itypj)
1598             dscj_inv=vbld_inv(j+nres)
1599 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1600 c     &       1.0d0/vbld(j+nres)
1601 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1602             sig0ij=sigma(itypi,itypj)
1603             chi1=chi(itypi,itypj)
1604             chi2=chi(itypj,itypi)
1605             chi12=chi1*chi2
1606             chip1=chip(itypi)
1607             chip2=chip(itypj)
1608             chip12=chip1*chip2
1609             alf1=alp(itypi)
1610             alf2=alp(itypj)
1611             alf12=0.5D0*(alf1+alf2)
1612 C For diagnostics only!!!
1613 c           chi1=0.0D0
1614 c           chi2=0.0D0
1615 c           chi12=0.0D0
1616 c           chip1=0.0D0
1617 c           chip2=0.0D0
1618 c           chip12=0.0D0
1619 c           alf1=0.0D0
1620 c           alf2=0.0D0
1621 c           alf12=0.0D0
1622             xj=c(1,nres+j)-xi
1623             yj=c(2,nres+j)-yi
1624             zj=c(3,nres+j)-zi
1625             dxj=dc_norm(1,nres+j)
1626             dyj=dc_norm(2,nres+j)
1627             dzj=dc_norm(3,nres+j)
1628 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1629 c            write (iout,*) "j",j," dc_norm",
1630 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1631             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1632             rij=dsqrt(rrij)
1633 C Calculate angle-dependent terms of energy and contributions to their
1634 C derivatives.
1635             call sc_angular
1636             sigsq=1.0D0/sigsq
1637             sig=sig0ij*dsqrt(sigsq)
1638             rij_shift=1.0D0/rij-sig+sig0ij
1639 c for diagnostics; uncomment
1640 c            rij_shift=1.2*sig0ij
1641 C I hate to put IF's in the loops, but here don't have another choice!!!!
1642             if (rij_shift.le.0.0D0) then
1643               evdw=1.0D20
1644 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1645 cd     &        restyp(itypi),i,restyp(itypj),j,
1646 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1647               return
1648             endif
1649             sigder=-sig*sigsq
1650 c---------------------------------------------------------------
1651             rij_shift=1.0D0/rij_shift
1652             fac=rij_shift**expon
1653             e1=fac*fac*aa(itypi,itypj)
1654             e2=fac*bb(itypi,itypj)
1655             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1656             eps2der=evdwij*eps3rt
1657             eps3der=evdwij*eps2rt
1658 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1659 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1660             evdwij=evdwij*eps2rt*eps3rt
1661 #ifdef TSCSC
1662             if (bb(itypi,itypj).gt.0) then
1663                evdw_p=evdw_p+evdwij
1664             else
1665                evdw_m=evdw_m+evdwij
1666             endif
1667 #else
1668             evdw=evdw+evdwij
1669 #endif
1670             if (lprn) then
1671             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1672             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1673             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1674      &        restyp(itypi),i,restyp(itypj),j,
1675      &        epsi,sigm,chi1,chi2,chip1,chip2,
1676      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1677      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1678      &        evdwij
1679             endif
1680
1681             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1682      &                        'evdw',i,j,evdwij
1683
1684 C Calculate gradient components.
1685             e1=e1*eps1*eps2rt**2*eps3rt**2
1686             fac=-expon*(e1+evdwij)*rij_shift
1687             sigder=fac*sigder
1688             fac=rij*fac
1689 c            fac=0.0d0
1690 C Calculate the radial part of the gradient
1691             gg(1)=xj*fac
1692             gg(2)=yj*fac
1693             gg(3)=zj*fac
1694 C Calculate angular part of the gradient.
1695 #ifdef TSCSC
1696             if (bb(itypi,itypj).gt.0) then
1697                call sc_grad
1698             else
1699                call sc_grad_T
1700             endif
1701 #else
1702             call sc_grad
1703 #endif
1704             ENDIF    ! dyn_ss
1705           enddo      ! j
1706         enddo        ! iint
1707       enddo          ! i
1708 c      write (iout,*) "Number of loop steps in EGB:",ind
1709 cccc      energy_dec=.false.
1710       return
1711       end
1712 C-----------------------------------------------------------------------------
1713       subroutine egbv(evdw,evdw_p,evdw_m)
1714 C
1715 C This subroutine calculates the interaction energy of nonbonded side chains
1716 C assuming the Gay-Berne-Vorobjev potential of interaction.
1717 C
1718       implicit real*8 (a-h,o-z)
1719       include 'DIMENSIONS'
1720       include 'COMMON.GEO'
1721       include 'COMMON.VAR'
1722       include 'COMMON.LOCAL'
1723       include 'COMMON.CHAIN'
1724       include 'COMMON.DERIV'
1725       include 'COMMON.NAMES'
1726       include 'COMMON.INTERACT'
1727       include 'COMMON.IOUNITS'
1728       include 'COMMON.CALC'
1729       common /srutu/ icall
1730       logical lprn
1731       evdw=0.0D0
1732 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1733       evdw=0.0D0
1734       lprn=.false.
1735 c     if (icall.eq.0) lprn=.true.
1736       ind=0
1737       do i=iatsc_s,iatsc_e
1738         itypi=itype(i)
1739         itypi1=itype(i+1)
1740         xi=c(1,nres+i)
1741         yi=c(2,nres+i)
1742         zi=c(3,nres+i)
1743         dxi=dc_norm(1,nres+i)
1744         dyi=dc_norm(2,nres+i)
1745         dzi=dc_norm(3,nres+i)
1746 c        dsci_inv=dsc_inv(itypi)
1747         dsci_inv=vbld_inv(i+nres)
1748 C
1749 C Calculate SC interaction energy.
1750 C
1751         do iint=1,nint_gr(i)
1752           do j=istart(i,iint),iend(i,iint)
1753             ind=ind+1
1754             itypj=itype(j)
1755 c            dscj_inv=dsc_inv(itypj)
1756             dscj_inv=vbld_inv(j+nres)
1757             sig0ij=sigma(itypi,itypj)
1758             r0ij=r0(itypi,itypj)
1759             chi1=chi(itypi,itypj)
1760             chi2=chi(itypj,itypi)
1761             chi12=chi1*chi2
1762             chip1=chip(itypi)
1763             chip2=chip(itypj)
1764             chip12=chip1*chip2
1765             alf1=alp(itypi)
1766             alf2=alp(itypj)
1767             alf12=0.5D0*(alf1+alf2)
1768 C For diagnostics only!!!
1769 c           chi1=0.0D0
1770 c           chi2=0.0D0
1771 c           chi12=0.0D0
1772 c           chip1=0.0D0
1773 c           chip2=0.0D0
1774 c           chip12=0.0D0
1775 c           alf1=0.0D0
1776 c           alf2=0.0D0
1777 c           alf12=0.0D0
1778             xj=c(1,nres+j)-xi
1779             yj=c(2,nres+j)-yi
1780             zj=c(3,nres+j)-zi
1781             dxj=dc_norm(1,nres+j)
1782             dyj=dc_norm(2,nres+j)
1783             dzj=dc_norm(3,nres+j)
1784             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1785             rij=dsqrt(rrij)
1786 C Calculate angle-dependent terms of energy and contributions to their
1787 C derivatives.
1788             call sc_angular
1789             sigsq=1.0D0/sigsq
1790             sig=sig0ij*dsqrt(sigsq)
1791             rij_shift=1.0D0/rij-sig+r0ij
1792 C I hate to put IF's in the loops, but here don't have another choice!!!!
1793             if (rij_shift.le.0.0D0) then
1794               evdw=1.0D20
1795               return
1796             endif
1797             sigder=-sig*sigsq
1798 c---------------------------------------------------------------
1799             rij_shift=1.0D0/rij_shift
1800             fac=rij_shift**expon
1801             e1=fac*fac*aa(itypi,itypj)
1802             e2=fac*bb(itypi,itypj)
1803             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1804             eps2der=evdwij*eps3rt
1805             eps3der=evdwij*eps2rt
1806             fac_augm=rrij**expon
1807             e_augm=augm(itypi,itypj)*fac_augm
1808             evdwij=evdwij*eps2rt*eps3rt
1809 #ifdef TSCSC
1810             if (bb(itypi,itypj).gt.0) then
1811                evdw_p=evdw_p+evdwij+e_augm
1812             else
1813                evdw_m=evdw_m+evdwij+e_augm
1814             endif
1815 #else
1816             evdw=evdw+evdwij+e_augm
1817 #endif
1818             if (lprn) then
1819             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1820             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1821             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1822      &        restyp(itypi),i,restyp(itypj),j,
1823      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1824      &        chi1,chi2,chip1,chip2,
1825      &        eps1,eps2rt**2,eps3rt**2,
1826      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1827      &        evdwij+e_augm
1828             endif
1829 C Calculate gradient components.
1830             e1=e1*eps1*eps2rt**2*eps3rt**2
1831             fac=-expon*(e1+evdwij)*rij_shift
1832             sigder=fac*sigder
1833             fac=rij*fac-2*expon*rrij*e_augm
1834 C Calculate the radial part of the gradient
1835             gg(1)=xj*fac
1836             gg(2)=yj*fac
1837             gg(3)=zj*fac
1838 C Calculate angular part of the gradient.
1839 #ifdef TSCSC
1840             if (bb(itypi,itypj).gt.0) then
1841                call sc_grad
1842             else
1843                call sc_grad_T
1844             endif
1845 #else
1846             call sc_grad
1847 #endif
1848           enddo      ! j
1849         enddo        ! iint
1850       enddo          ! i
1851       end
1852 C-----------------------------------------------------------------------------
1853       subroutine sc_angular
1854 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1855 C om12. Called by ebp, egb, and egbv.
1856       implicit none
1857       include 'COMMON.CALC'
1858       include 'COMMON.IOUNITS'
1859       erij(1)=xj*rij
1860       erij(2)=yj*rij
1861       erij(3)=zj*rij
1862       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1863       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1864       om12=dxi*dxj+dyi*dyj+dzi*dzj
1865       chiom12=chi12*om12
1866 C Calculate eps1(om12) and its derivative in om12
1867       faceps1=1.0D0-om12*chiom12
1868       faceps1_inv=1.0D0/faceps1
1869       eps1=dsqrt(faceps1_inv)
1870 C Following variable is eps1*deps1/dom12
1871       eps1_om12=faceps1_inv*chiom12
1872 c diagnostics only
1873 c      faceps1_inv=om12
1874 c      eps1=om12
1875 c      eps1_om12=1.0d0
1876 c      write (iout,*) "om12",om12," eps1",eps1
1877 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1878 C and om12.
1879       om1om2=om1*om2
1880       chiom1=chi1*om1
1881       chiom2=chi2*om2
1882       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1883       sigsq=1.0D0-facsig*faceps1_inv
1884       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1885       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1886       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1887 c diagnostics only
1888 c      sigsq=1.0d0
1889 c      sigsq_om1=0.0d0
1890 c      sigsq_om2=0.0d0
1891 c      sigsq_om12=0.0d0
1892 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1893 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1894 c     &    " eps1",eps1
1895 C Calculate eps2 and its derivatives in om1, om2, and om12.
1896       chipom1=chip1*om1
1897       chipom2=chip2*om2
1898       chipom12=chip12*om12
1899       facp=1.0D0-om12*chipom12
1900       facp_inv=1.0D0/facp
1901       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1902 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1903 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1904 C Following variable is the square root of eps2
1905       eps2rt=1.0D0-facp1*facp_inv
1906 C Following three variables are the derivatives of the square root of eps
1907 C in om1, om2, and om12.
1908       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1909       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1910       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1911 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1912       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1913 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1914 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1915 c     &  " eps2rt_om12",eps2rt_om12
1916 C Calculate whole angle-dependent part of epsilon and contributions
1917 C to its derivatives
1918       return
1919       end
1920
1921 C----------------------------------------------------------------------------
1922       subroutine sc_grad_T
1923       implicit real*8 (a-h,o-z)
1924       include 'DIMENSIONS'
1925       include 'COMMON.CHAIN'
1926       include 'COMMON.DERIV'
1927       include 'COMMON.CALC'
1928       include 'COMMON.IOUNITS'
1929       double precision dcosom1(3),dcosom2(3)
1930       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1931       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1932       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1933      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1934 c diagnostics only
1935 c      eom1=0.0d0
1936 c      eom2=0.0d0
1937 c      eom12=evdwij*eps1_om12
1938 c end diagnostics
1939 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1940 c     &  " sigder",sigder
1941 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1942 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1943       do k=1,3
1944         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1945         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1946       enddo
1947       do k=1,3
1948         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1949       enddo
1950 c      write (iout,*) "gg",(gg(k),k=1,3)
1951       do k=1,3
1952         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1953      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1954      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1955         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1956      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1957      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1958 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1959 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1960 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1961 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1962       enddo
1963 C
1964 C Calculate the components of the gradient in DC and X
1965 C
1966 cgrad      do k=i,j-1
1967 cgrad        do l=1,3
1968 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1969 cgrad        enddo
1970 cgrad      enddo
1971       do l=1,3
1972         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1973         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1974       enddo
1975       return
1976       end
1977
1978 C----------------------------------------------------------------------------
1979       subroutine sc_grad
1980       implicit real*8 (a-h,o-z)
1981       include 'DIMENSIONS'
1982       include 'COMMON.CHAIN'
1983       include 'COMMON.DERIV'
1984       include 'COMMON.CALC'
1985       include 'COMMON.IOUNITS'
1986       double precision dcosom1(3),dcosom2(3)
1987       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1988       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1989       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1990      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1991 c diagnostics only
1992 c      eom1=0.0d0
1993 c      eom2=0.0d0
1994 c      eom12=evdwij*eps1_om12
1995 c end diagnostics
1996 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1997 c     &  " sigder",sigder
1998 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1999 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2000       do k=1,3
2001         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2002         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2003       enddo
2004       do k=1,3
2005         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2006       enddo
2007 c      write (iout,*) "gg",(gg(k),k=1,3)
2008       do k=1,3
2009         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2010      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2011      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2012         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2013      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2014      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2015 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2016 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2017 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2018 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2019       enddo
2020 C
2021 C Calculate the components of the gradient in DC and X
2022 C
2023 cgrad      do k=i,j-1
2024 cgrad        do l=1,3
2025 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2026 cgrad        enddo
2027 cgrad      enddo
2028       do l=1,3
2029         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2030         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2031       enddo
2032       return
2033       end
2034 C-----------------------------------------------------------------------
2035       subroutine e_softsphere(evdw)
2036 C
2037 C This subroutine calculates the interaction energy of nonbonded side chains
2038 C assuming the LJ potential of interaction.
2039 C
2040       implicit real*8 (a-h,o-z)
2041       include 'DIMENSIONS'
2042       parameter (accur=1.0d-10)
2043       include 'COMMON.GEO'
2044       include 'COMMON.VAR'
2045       include 'COMMON.LOCAL'
2046       include 'COMMON.CHAIN'
2047       include 'COMMON.DERIV'
2048       include 'COMMON.INTERACT'
2049       include 'COMMON.TORSION'
2050       include 'COMMON.SBRIDGE'
2051       include 'COMMON.NAMES'
2052       include 'COMMON.IOUNITS'
2053       include 'COMMON.CONTACTS'
2054       dimension gg(3)
2055 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2056       evdw=0.0D0
2057       do i=iatsc_s,iatsc_e
2058         itypi=itype(i)
2059         itypi1=itype(i+1)
2060         xi=c(1,nres+i)
2061         yi=c(2,nres+i)
2062         zi=c(3,nres+i)
2063 C
2064 C Calculate SC interaction energy.
2065 C
2066         do iint=1,nint_gr(i)
2067 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2068 cd   &                  'iend=',iend(i,iint)
2069           do j=istart(i,iint),iend(i,iint)
2070             itypj=itype(j)
2071             xj=c(1,nres+j)-xi
2072             yj=c(2,nres+j)-yi
2073             zj=c(3,nres+j)-zi
2074             rij=xj*xj+yj*yj+zj*zj
2075 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2076             r0ij=r0(itypi,itypj)
2077             r0ijsq=r0ij*r0ij
2078 c            print *,i,j,r0ij,dsqrt(rij)
2079             if (rij.lt.r0ijsq) then
2080               evdwij=0.25d0*(rij-r0ijsq)**2
2081               fac=rij-r0ijsq
2082             else
2083               evdwij=0.0d0
2084               fac=0.0d0
2085             endif
2086             evdw=evdw+evdwij
2087 C
2088 C Calculate the components of the gradient in DC and X
2089 C
2090             gg(1)=xj*fac
2091             gg(2)=yj*fac
2092             gg(3)=zj*fac
2093             do k=1,3
2094               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2095               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2096               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2097               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2098             enddo
2099 cgrad            do k=i,j-1
2100 cgrad              do l=1,3
2101 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2102 cgrad              enddo
2103 cgrad            enddo
2104           enddo ! j
2105         enddo ! iint
2106       enddo ! i
2107       return
2108       end
2109 C--------------------------------------------------------------------------
2110       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2111      &              eello_turn4)
2112 C
2113 C Soft-sphere potential of p-p interaction
2114 C
2115       implicit real*8 (a-h,o-z)
2116       include 'DIMENSIONS'
2117       include 'COMMON.CONTROL'
2118       include 'COMMON.IOUNITS'
2119       include 'COMMON.GEO'
2120       include 'COMMON.VAR'
2121       include 'COMMON.LOCAL'
2122       include 'COMMON.CHAIN'
2123       include 'COMMON.DERIV'
2124       include 'COMMON.INTERACT'
2125       include 'COMMON.CONTACTS'
2126       include 'COMMON.TORSION'
2127       include 'COMMON.VECTORS'
2128       include 'COMMON.FFIELD'
2129       dimension ggg(3)
2130 cd      write(iout,*) 'In EELEC_soft_sphere'
2131       ees=0.0D0
2132       evdw1=0.0D0
2133       eel_loc=0.0d0
2134       eello_turn3=0.0d0
2135       eello_turn4=0.0d0
2136       ind=0
2137       do i=iatel_s,iatel_e
2138         dxi=dc(1,i)
2139         dyi=dc(2,i)
2140         dzi=dc(3,i)
2141         xmedi=c(1,i)+0.5d0*dxi
2142         ymedi=c(2,i)+0.5d0*dyi
2143         zmedi=c(3,i)+0.5d0*dzi
2144         num_conti=0
2145 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2146         do j=ielstart(i),ielend(i)
2147           ind=ind+1
2148           iteli=itel(i)
2149           itelj=itel(j)
2150           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2151           r0ij=rpp(iteli,itelj)
2152           r0ijsq=r0ij*r0ij
2153           dxj=dc(1,j)
2154           dyj=dc(2,j)
2155           dzj=dc(3,j)
2156           xj=c(1,j)+0.5D0*dxj-xmedi
2157           yj=c(2,j)+0.5D0*dyj-ymedi
2158           zj=c(3,j)+0.5D0*dzj-zmedi
2159           rij=xj*xj+yj*yj+zj*zj
2160           if (rij.lt.r0ijsq) then
2161             evdw1ij=0.25d0*(rij-r0ijsq)**2
2162             fac=rij-r0ijsq
2163           else
2164             evdw1ij=0.0d0
2165             fac=0.0d0
2166           endif
2167           evdw1=evdw1+evdw1ij
2168 C
2169 C Calculate contributions to the Cartesian gradient.
2170 C
2171           ggg(1)=fac*xj
2172           ggg(2)=fac*yj
2173           ggg(3)=fac*zj
2174           do k=1,3
2175             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2176             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2177           enddo
2178 *
2179 * Loop over residues i+1 thru j-1.
2180 *
2181 cgrad          do k=i+1,j-1
2182 cgrad            do l=1,3
2183 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2184 cgrad            enddo
2185 cgrad          enddo
2186         enddo ! j
2187       enddo   ! i
2188 cgrad      do i=nnt,nct-1
2189 cgrad        do k=1,3
2190 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2191 cgrad        enddo
2192 cgrad        do j=i+1,nct-1
2193 cgrad          do k=1,3
2194 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2195 cgrad          enddo
2196 cgrad        enddo
2197 cgrad      enddo
2198       return
2199       end
2200 c------------------------------------------------------------------------------
2201       subroutine vec_and_deriv
2202       implicit real*8 (a-h,o-z)
2203       include 'DIMENSIONS'
2204 #ifdef MPI
2205       include 'mpif.h'
2206 #endif
2207       include 'COMMON.IOUNITS'
2208       include 'COMMON.GEO'
2209       include 'COMMON.VAR'
2210       include 'COMMON.LOCAL'
2211       include 'COMMON.CHAIN'
2212       include 'COMMON.VECTORS'
2213       include 'COMMON.SETUP'
2214       include 'COMMON.TIME1'
2215       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2216 C Compute the local reference systems. For reference system (i), the
2217 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2218 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2219 #ifdef PARVEC
2220       do i=ivec_start,ivec_end
2221 #else
2222       do i=1,nres-1
2223 #endif
2224           if (i.eq.nres-1) then
2225 C Case of the last full residue
2226 C Compute the Z-axis
2227             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2228             costh=dcos(pi-theta(nres))
2229             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2230             do k=1,3
2231               uz(k,i)=fac*uz(k,i)
2232             enddo
2233 C Compute the derivatives of uz
2234             uzder(1,1,1)= 0.0d0
2235             uzder(2,1,1)=-dc_norm(3,i-1)
2236             uzder(3,1,1)= dc_norm(2,i-1)
2237             uzder(1,2,1)= dc_norm(3,i-1)
2238             uzder(2,2,1)= 0.0d0
2239             uzder(3,2,1)=-dc_norm(1,i-1)
2240             uzder(1,3,1)=-dc_norm(2,i-1)
2241             uzder(2,3,1)= dc_norm(1,i-1)
2242             uzder(3,3,1)= 0.0d0
2243             uzder(1,1,2)= 0.0d0
2244             uzder(2,1,2)= dc_norm(3,i)
2245             uzder(3,1,2)=-dc_norm(2,i)
2246             uzder(1,2,2)=-dc_norm(3,i)
2247             uzder(2,2,2)= 0.0d0
2248             uzder(3,2,2)= dc_norm(1,i)
2249             uzder(1,3,2)= dc_norm(2,i)
2250             uzder(2,3,2)=-dc_norm(1,i)
2251             uzder(3,3,2)= 0.0d0
2252 C Compute the Y-axis
2253             facy=fac
2254             do k=1,3
2255               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2256             enddo
2257 C Compute the derivatives of uy
2258             do j=1,3
2259               do k=1,3
2260                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2261      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2262                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2263               enddo
2264               uyder(j,j,1)=uyder(j,j,1)-costh
2265               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2266             enddo
2267             do j=1,2
2268               do k=1,3
2269                 do l=1,3
2270                   uygrad(l,k,j,i)=uyder(l,k,j)
2271                   uzgrad(l,k,j,i)=uzder(l,k,j)
2272                 enddo
2273               enddo
2274             enddo
2275             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2276             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2277             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2278             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2279           else
2280 C Other residues
2281 C Compute the Z-axis
2282             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2283             costh=dcos(pi-theta(i+2))
2284             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2285             do k=1,3
2286               uz(k,i)=fac*uz(k,i)
2287             enddo
2288 C Compute the derivatives of uz
2289             uzder(1,1,1)= 0.0d0
2290             uzder(2,1,1)=-dc_norm(3,i+1)
2291             uzder(3,1,1)= dc_norm(2,i+1)
2292             uzder(1,2,1)= dc_norm(3,i+1)
2293             uzder(2,2,1)= 0.0d0
2294             uzder(3,2,1)=-dc_norm(1,i+1)
2295             uzder(1,3,1)=-dc_norm(2,i+1)
2296             uzder(2,3,1)= dc_norm(1,i+1)
2297             uzder(3,3,1)= 0.0d0
2298             uzder(1,1,2)= 0.0d0
2299             uzder(2,1,2)= dc_norm(3,i)
2300             uzder(3,1,2)=-dc_norm(2,i)
2301             uzder(1,2,2)=-dc_norm(3,i)
2302             uzder(2,2,2)= 0.0d0
2303             uzder(3,2,2)= dc_norm(1,i)
2304             uzder(1,3,2)= dc_norm(2,i)
2305             uzder(2,3,2)=-dc_norm(1,i)
2306             uzder(3,3,2)= 0.0d0
2307 C Compute the Y-axis
2308             facy=fac
2309             do k=1,3
2310               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2311             enddo
2312 C Compute the derivatives of uy
2313             do j=1,3
2314               do k=1,3
2315                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2316      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2317                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2318               enddo
2319               uyder(j,j,1)=uyder(j,j,1)-costh
2320               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2321             enddo
2322             do j=1,2
2323               do k=1,3
2324                 do l=1,3
2325                   uygrad(l,k,j,i)=uyder(l,k,j)
2326                   uzgrad(l,k,j,i)=uzder(l,k,j)
2327                 enddo
2328               enddo
2329             enddo
2330             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2331             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2332             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2333             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2334           endif
2335       enddo
2336       do i=1,nres-1
2337         vbld_inv_temp(1)=vbld_inv(i+1)
2338         if (i.lt.nres-1) then
2339           vbld_inv_temp(2)=vbld_inv(i+2)
2340           else
2341           vbld_inv_temp(2)=vbld_inv(i)
2342           endif
2343         do j=1,2
2344           do k=1,3
2345             do l=1,3
2346               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2347               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2348             enddo
2349           enddo
2350         enddo
2351       enddo
2352 #if defined(PARVEC) && defined(MPI)
2353       if (nfgtasks1.gt.1) then
2354         time00=MPI_Wtime()
2355 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2356 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2357 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2358         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2359      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2360      &   FG_COMM1,IERR)
2361         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2362      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2363      &   FG_COMM1,IERR)
2364         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2365      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2366      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2367         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2368      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2369      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2370         time_gather=time_gather+MPI_Wtime()-time00
2371       endif
2372 c      if (fg_rank.eq.0) then
2373 c        write (iout,*) "Arrays UY and UZ"
2374 c        do i=1,nres-1
2375 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2376 c     &     (uz(k,i),k=1,3)
2377 c        enddo
2378 c      endif
2379 #endif
2380       return
2381       end
2382 C-----------------------------------------------------------------------------
2383       subroutine check_vecgrad
2384       implicit real*8 (a-h,o-z)
2385       include 'DIMENSIONS'
2386       include 'COMMON.IOUNITS'
2387       include 'COMMON.GEO'
2388       include 'COMMON.VAR'
2389       include 'COMMON.LOCAL'
2390       include 'COMMON.CHAIN'
2391       include 'COMMON.VECTORS'
2392       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2393       dimension uyt(3,maxres),uzt(3,maxres)
2394       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2395       double precision delta /1.0d-7/
2396       call vec_and_deriv
2397 cd      do i=1,nres
2398 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2399 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2400 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2401 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2402 cd     &     (dc_norm(if90,i),if90=1,3)
2403 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2404 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2405 cd          write(iout,'(a)')
2406 cd      enddo
2407       do i=1,nres
2408         do j=1,2
2409           do k=1,3
2410             do l=1,3
2411               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2412               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2413             enddo
2414           enddo
2415         enddo
2416       enddo
2417       call vec_and_deriv
2418       do i=1,nres
2419         do j=1,3
2420           uyt(j,i)=uy(j,i)
2421           uzt(j,i)=uz(j,i)
2422         enddo
2423       enddo
2424       do i=1,nres
2425 cd        write (iout,*) 'i=',i
2426         do k=1,3
2427           erij(k)=dc_norm(k,i)
2428         enddo
2429         do j=1,3
2430           do k=1,3
2431             dc_norm(k,i)=erij(k)
2432           enddo
2433           dc_norm(j,i)=dc_norm(j,i)+delta
2434 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2435 c          do k=1,3
2436 c            dc_norm(k,i)=dc_norm(k,i)/fac
2437 c          enddo
2438 c          write (iout,*) (dc_norm(k,i),k=1,3)
2439 c          write (iout,*) (erij(k),k=1,3)
2440           call vec_and_deriv
2441           do k=1,3
2442             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2443             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2444             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2445             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2446           enddo
2447 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2448 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2449 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2450         enddo
2451         do k=1,3
2452           dc_norm(k,i)=erij(k)
2453         enddo
2454 cd        do k=1,3
2455 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2456 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2457 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2458 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2459 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2460 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2461 cd          write (iout,'(a)')
2462 cd        enddo
2463       enddo
2464       return
2465       end
2466 C--------------------------------------------------------------------------
2467       subroutine set_matrices
2468       implicit real*8 (a-h,o-z)
2469       include 'DIMENSIONS'
2470 #ifdef MPI
2471       include "mpif.h"
2472       include "COMMON.SETUP"
2473       integer IERR
2474       integer status(MPI_STATUS_SIZE)
2475 #endif
2476       include 'COMMON.IOUNITS'
2477       include 'COMMON.GEO'
2478       include 'COMMON.VAR'
2479       include 'COMMON.LOCAL'
2480       include 'COMMON.CHAIN'
2481       include 'COMMON.DERIV'
2482       include 'COMMON.INTERACT'
2483       include 'COMMON.CONTACTS'
2484       include 'COMMON.TORSION'
2485       include 'COMMON.VECTORS'
2486       include 'COMMON.FFIELD'
2487       double precision auxvec(2),auxmat(2,2)
2488 C
2489 C Compute the virtual-bond-torsional-angle dependent quantities needed
2490 C to calculate the el-loc multibody terms of various order.
2491 C
2492 #ifdef PARMAT
2493       do i=ivec_start+2,ivec_end+2
2494 #else
2495       do i=3,nres+1
2496 #endif
2497         if (i .lt. nres+1) then
2498           sin1=dsin(phi(i))
2499           cos1=dcos(phi(i))
2500           sintab(i-2)=sin1
2501           costab(i-2)=cos1
2502           obrot(1,i-2)=cos1
2503           obrot(2,i-2)=sin1
2504           sin2=dsin(2*phi(i))
2505           cos2=dcos(2*phi(i))
2506           sintab2(i-2)=sin2
2507           costab2(i-2)=cos2
2508           obrot2(1,i-2)=cos2
2509           obrot2(2,i-2)=sin2
2510           Ug(1,1,i-2)=-cos1
2511           Ug(1,2,i-2)=-sin1
2512           Ug(2,1,i-2)=-sin1
2513           Ug(2,2,i-2)= cos1
2514           Ug2(1,1,i-2)=-cos2
2515           Ug2(1,2,i-2)=-sin2
2516           Ug2(2,1,i-2)=-sin2
2517           Ug2(2,2,i-2)= cos2
2518         else
2519           costab(i-2)=1.0d0
2520           sintab(i-2)=0.0d0
2521           obrot(1,i-2)=1.0d0
2522           obrot(2,i-2)=0.0d0
2523           obrot2(1,i-2)=0.0d0
2524           obrot2(2,i-2)=0.0d0
2525           Ug(1,1,i-2)=1.0d0
2526           Ug(1,2,i-2)=0.0d0
2527           Ug(2,1,i-2)=0.0d0
2528           Ug(2,2,i-2)=1.0d0
2529           Ug2(1,1,i-2)=0.0d0
2530           Ug2(1,2,i-2)=0.0d0
2531           Ug2(2,1,i-2)=0.0d0
2532           Ug2(2,2,i-2)=0.0d0
2533         endif
2534         if (i .gt. 3 .and. i .lt. nres+1) then
2535           obrot_der(1,i-2)=-sin1
2536           obrot_der(2,i-2)= cos1
2537           Ugder(1,1,i-2)= sin1
2538           Ugder(1,2,i-2)=-cos1
2539           Ugder(2,1,i-2)=-cos1
2540           Ugder(2,2,i-2)=-sin1
2541           dwacos2=cos2+cos2
2542           dwasin2=sin2+sin2
2543           obrot2_der(1,i-2)=-dwasin2
2544           obrot2_der(2,i-2)= dwacos2
2545           Ug2der(1,1,i-2)= dwasin2
2546           Ug2der(1,2,i-2)=-dwacos2
2547           Ug2der(2,1,i-2)=-dwacos2
2548           Ug2der(2,2,i-2)=-dwasin2
2549         else
2550           obrot_der(1,i-2)=0.0d0
2551           obrot_der(2,i-2)=0.0d0
2552           Ugder(1,1,i-2)=0.0d0
2553           Ugder(1,2,i-2)=0.0d0
2554           Ugder(2,1,i-2)=0.0d0
2555           Ugder(2,2,i-2)=0.0d0
2556           obrot2_der(1,i-2)=0.0d0
2557           obrot2_der(2,i-2)=0.0d0
2558           Ug2der(1,1,i-2)=0.0d0
2559           Ug2der(1,2,i-2)=0.0d0
2560           Ug2der(2,1,i-2)=0.0d0
2561           Ug2der(2,2,i-2)=0.0d0
2562         endif
2563 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2564         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2565           iti = itortyp(itype(i-2))
2566         else
2567           iti=ntortyp+1
2568         endif
2569 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2570         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2571           iti1 = itortyp(itype(i-1))
2572         else
2573           iti1=ntortyp+1
2574         endif
2575 cd        write (iout,*) '*******i',i,' iti1',iti
2576 cd        write (iout,*) 'b1',b1(:,iti)
2577 cd        write (iout,*) 'b2',b2(:,iti)
2578 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2579 c        if (i .gt. iatel_s+2) then
2580         if (i .gt. nnt+2) then
2581           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2582           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2583           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2584      &    then
2585           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2586           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2587           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2588           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2589           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2590           endif
2591         else
2592           do k=1,2
2593             Ub2(k,i-2)=0.0d0
2594             Ctobr(k,i-2)=0.0d0
2595             Dtobr2(k,i-2)=0.0d0
2596             do l=1,2
2597               EUg(l,k,i-2)=0.0d0
2598               CUg(l,k,i-2)=0.0d0
2599               DUg(l,k,i-2)=0.0d0
2600               DtUg2(l,k,i-2)=0.0d0
2601             enddo
2602           enddo
2603         endif
2604         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2605         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2606         do k=1,2
2607           muder(k,i-2)=Ub2der(k,i-2)
2608         enddo
2609 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2610         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2611           iti1 = itortyp(itype(i-1))
2612         else
2613           iti1=ntortyp+1
2614         endif
2615         do k=1,2
2616           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2617         enddo
2618 cd        write (iout,*) 'mu ',mu(:,i-2)
2619 cd        write (iout,*) 'mu1',mu1(:,i-2)
2620 cd        write (iout,*) 'mu2',mu2(:,i-2)
2621         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2622      &  then
2623         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2624         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2625         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2626         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2627         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2628 C Vectors and matrices dependent on a single virtual-bond dihedral.
2629         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2630         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2631         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2632         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2633         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2634         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2635         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2636         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2637         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2638         endif
2639       enddo
2640 C Matrices dependent on two consecutive virtual-bond dihedrals.
2641 C The order of matrices is from left to right.
2642       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2643      &then
2644 c      do i=max0(ivec_start,2),ivec_end
2645       do i=2,nres-1
2646         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2647         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2648         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2649         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2650         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2651         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2652         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2653         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2654       enddo
2655       endif
2656 #if defined(MPI) && defined(PARMAT)
2657 #ifdef DEBUG
2658 c      if (fg_rank.eq.0) then
2659         write (iout,*) "Arrays UG and UGDER before GATHER"
2660         do i=1,nres-1
2661           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2662      &     ((ug(l,k,i),l=1,2),k=1,2),
2663      &     ((ugder(l,k,i),l=1,2),k=1,2)
2664         enddo
2665         write (iout,*) "Arrays UG2 and UG2DER"
2666         do i=1,nres-1
2667           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2668      &     ((ug2(l,k,i),l=1,2),k=1,2),
2669      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2670         enddo
2671         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2672         do i=1,nres-1
2673           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2674      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2675      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2676         enddo
2677         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2678         do i=1,nres-1
2679           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2680      &     costab(i),sintab(i),costab2(i),sintab2(i)
2681         enddo
2682         write (iout,*) "Array MUDER"
2683         do i=1,nres-1
2684           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2685         enddo
2686 c      endif
2687 #endif
2688       if (nfgtasks.gt.1) then
2689         time00=MPI_Wtime()
2690 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2691 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2692 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2693 #ifdef MATGATHER
2694         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2704      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2705      &   FG_COMM1,IERR)
2706         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2707      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2708      &   FG_COMM1,IERR)
2709         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2710      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2711      &   FG_COMM1,IERR)
2712         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2713      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2714      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2715         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2716      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2717      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2718         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2719      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2720      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2721         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2722      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2723      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2724         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2725      &  then
2726         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2733      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2734      &   FG_COMM1,IERR)
2735        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2736      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2737      &   FG_COMM1,IERR)
2738         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2739      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2740      &   FG_COMM1,IERR)
2741         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2742      &   ivec_count(fg_rank1),
2743      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2758      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2759      &   FG_COMM1,IERR)
2760         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2761      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2762      &   FG_COMM1,IERR)
2763         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2764      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2765      &   FG_COMM1,IERR)
2766         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2767      &   ivec_count(fg_rank1),
2768      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2769      &   FG_COMM1,IERR)
2770         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2774      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2775      &   FG_COMM1,IERR)
2776         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2777      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2778      &   FG_COMM1,IERR)
2779        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2780      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2781      &   FG_COMM1,IERR)
2782         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2783      &   ivec_count(fg_rank1),
2784      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2785      &   FG_COMM1,IERR)
2786         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2787      &   ivec_count(fg_rank1),
2788      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2791      &   ivec_count(fg_rank1),
2792      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2793      &   MPI_MAT2,FG_COMM1,IERR)
2794         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2795      &   ivec_count(fg_rank1),
2796      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2797      &   MPI_MAT2,FG_COMM1,IERR)
2798         endif
2799 #else
2800 c Passes matrix info through the ring
2801       isend=fg_rank1
2802       irecv=fg_rank1-1
2803       if (irecv.lt.0) irecv=nfgtasks1-1
2804       iprev=irecv
2805       inext=fg_rank1+1
2806       if (inext.ge.nfgtasks1) inext=0
2807       do i=1,nfgtasks1-1
2808 c        write (iout,*) "isend",isend," irecv",irecv
2809 c        call flush(iout)
2810         lensend=lentyp(isend)
2811         lenrecv=lentyp(irecv)
2812 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2813 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2814 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2815 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2816 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2817 c        write (iout,*) "Gather ROTAT1"
2818 c        call flush(iout)
2819 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2820 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2821 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2822 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2823 c        write (iout,*) "Gather ROTAT2"
2824 c        call flush(iout)
2825         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2826      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2827      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2828      &   iprev,4400+irecv,FG_COMM,status,IERR)
2829 c        write (iout,*) "Gather ROTAT_OLD"
2830 c        call flush(iout)
2831         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2832      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2833      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2834      &   iprev,5500+irecv,FG_COMM,status,IERR)
2835 c        write (iout,*) "Gather PRECOMP11"
2836 c        call flush(iout)
2837         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2838      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2839      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2840      &   iprev,6600+irecv,FG_COMM,status,IERR)
2841 c        write (iout,*) "Gather PRECOMP12"
2842 c        call flush(iout)
2843         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2844      &  then
2845         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2846      &   MPI_ROTAT2(lensend),inext,7700+isend,
2847      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2848      &   iprev,7700+irecv,FG_COMM,status,IERR)
2849 c        write (iout,*) "Gather PRECOMP21"
2850 c        call flush(iout)
2851         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2852      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2853      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2854      &   iprev,8800+irecv,FG_COMM,status,IERR)
2855 c        write (iout,*) "Gather PRECOMP22"
2856 c        call flush(iout)
2857         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2858      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2859      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2860      &   MPI_PRECOMP23(lenrecv),
2861      &   iprev,9900+irecv,FG_COMM,status,IERR)
2862 c        write (iout,*) "Gather PRECOMP23"
2863 c        call flush(iout)
2864         endif
2865         isend=irecv
2866         irecv=irecv-1
2867         if (irecv.lt.0) irecv=nfgtasks1-1
2868       enddo
2869 #endif
2870         time_gather=time_gather+MPI_Wtime()-time00
2871       endif
2872 #ifdef DEBUG
2873 c      if (fg_rank.eq.0) then
2874         write (iout,*) "Arrays UG and UGDER"
2875         do i=1,nres-1
2876           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2877      &     ((ug(l,k,i),l=1,2),k=1,2),
2878      &     ((ugder(l,k,i),l=1,2),k=1,2)
2879         enddo
2880         write (iout,*) "Arrays UG2 and UG2DER"
2881         do i=1,nres-1
2882           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2883      &     ((ug2(l,k,i),l=1,2),k=1,2),
2884      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2885         enddo
2886         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2887         do i=1,nres-1
2888           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2889      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2890      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2891         enddo
2892         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2893         do i=1,nres-1
2894           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2895      &     costab(i),sintab(i),costab2(i),sintab2(i)
2896         enddo
2897         write (iout,*) "Array MUDER"
2898         do i=1,nres-1
2899           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2900         enddo
2901 c      endif
2902 #endif
2903 #endif
2904 cd      do i=1,nres
2905 cd        iti = itortyp(itype(i))
2906 cd        write (iout,*) i
2907 cd        do j=1,2
2908 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2909 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2910 cd        enddo
2911 cd      enddo
2912       return
2913       end
2914 C--------------------------------------------------------------------------
2915       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2916 C
2917 C This subroutine calculates the average interaction energy and its gradient
2918 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2919 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2920 C The potential depends both on the distance of peptide-group centers and on
2921 C the orientation of the CA-CA virtual bonds.
2922 C
2923       implicit real*8 (a-h,o-z)
2924 #ifdef MPI
2925       include 'mpif.h'
2926 #endif
2927       include 'DIMENSIONS'
2928       include 'COMMON.CONTROL'
2929       include 'COMMON.SETUP'
2930       include 'COMMON.IOUNITS'
2931       include 'COMMON.GEO'
2932       include 'COMMON.VAR'
2933       include 'COMMON.LOCAL'
2934       include 'COMMON.CHAIN'
2935       include 'COMMON.DERIV'
2936       include 'COMMON.INTERACT'
2937       include 'COMMON.CONTACTS'
2938       include 'COMMON.TORSION'
2939       include 'COMMON.VECTORS'
2940       include 'COMMON.FFIELD'
2941       include 'COMMON.TIME1'
2942       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2943      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2944       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2945      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2946       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2947      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2948      &    num_conti,j1,j2
2949 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2950 #ifdef MOMENT
2951       double precision scal_el /1.0d0/
2952 #else
2953       double precision scal_el /0.5d0/
2954 #endif
2955 C 12/13/98
2956 C 13-go grudnia roku pamietnego...
2957       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2958      &                   0.0d0,1.0d0,0.0d0,
2959      &                   0.0d0,0.0d0,1.0d0/
2960 cd      write(iout,*) 'In EELEC'
2961 cd      do i=1,nloctyp
2962 cd        write(iout,*) 'Type',i
2963 cd        write(iout,*) 'B1',B1(:,i)
2964 cd        write(iout,*) 'B2',B2(:,i)
2965 cd        write(iout,*) 'CC',CC(:,:,i)
2966 cd        write(iout,*) 'DD',DD(:,:,i)
2967 cd        write(iout,*) 'EE',EE(:,:,i)
2968 cd      enddo
2969 cd      call check_vecgrad
2970 cd      stop
2971       if (icheckgrad.eq.1) then
2972         do i=1,nres-1
2973           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2974           do k=1,3
2975             dc_norm(k,i)=dc(k,i)*fac
2976           enddo
2977 c          write (iout,*) 'i',i,' fac',fac
2978         enddo
2979       endif
2980       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2981      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2982      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2983 c        call vec_and_deriv
2984 #ifdef TIMING
2985         time01=MPI_Wtime()
2986 #endif
2987         call set_matrices
2988 #ifdef TIMING
2989         time_mat=time_mat+MPI_Wtime()-time01
2990 #endif
2991       endif
2992 cd      do i=1,nres-1
2993 cd        write (iout,*) 'i=',i
2994 cd        do k=1,3
2995 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2996 cd        enddo
2997 cd        do k=1,3
2998 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2999 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3000 cd        enddo
3001 cd      enddo
3002       t_eelecij=0.0d0
3003       ees=0.0D0
3004       evdw1=0.0D0
3005       eel_loc=0.0d0
3006       eello_turn3=0.0d0
3007       eello_turn4=0.0d0
3008       ind=0
3009       do i=1,nres
3010         num_cont_hb(i)=0
3011       enddo
3012 cd      print '(a)','Enter EELEC'
3013 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3014       do i=1,nres
3015         gel_loc_loc(i)=0.0d0
3016         gcorr_loc(i)=0.0d0
3017       enddo
3018 c
3019 c
3020 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3021 C
3022 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3023 C
3024       do i=iturn3_start,iturn3_end
3025         dxi=dc(1,i)
3026         dyi=dc(2,i)
3027         dzi=dc(3,i)
3028         dx_normi=dc_norm(1,i)
3029         dy_normi=dc_norm(2,i)
3030         dz_normi=dc_norm(3,i)
3031         xmedi=c(1,i)+0.5d0*dxi
3032         ymedi=c(2,i)+0.5d0*dyi
3033         zmedi=c(3,i)+0.5d0*dzi
3034         num_conti=0
3035         call eelecij(i,i+2,ees,evdw1,eel_loc)
3036         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3037         num_cont_hb(i)=num_conti
3038       enddo
3039       do i=iturn4_start,iturn4_end
3040         dxi=dc(1,i)
3041         dyi=dc(2,i)
3042         dzi=dc(3,i)
3043         dx_normi=dc_norm(1,i)
3044         dy_normi=dc_norm(2,i)
3045         dz_normi=dc_norm(3,i)
3046         xmedi=c(1,i)+0.5d0*dxi
3047         ymedi=c(2,i)+0.5d0*dyi
3048         zmedi=c(3,i)+0.5d0*dzi
3049         num_conti=num_cont_hb(i)
3050         call eelecij(i,i+3,ees,evdw1,eel_loc)
3051         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3052         num_cont_hb(i)=num_conti
3053       enddo   ! i
3054 c
3055 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3056 c
3057       do i=iatel_s,iatel_e
3058         dxi=dc(1,i)
3059         dyi=dc(2,i)
3060         dzi=dc(3,i)
3061         dx_normi=dc_norm(1,i)
3062         dy_normi=dc_norm(2,i)
3063         dz_normi=dc_norm(3,i)
3064         xmedi=c(1,i)+0.5d0*dxi
3065         ymedi=c(2,i)+0.5d0*dyi
3066         zmedi=c(3,i)+0.5d0*dzi
3067 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3068         num_conti=num_cont_hb(i)
3069         do j=ielstart(i),ielend(i)
3070           call eelecij(i,j,ees,evdw1,eel_loc)
3071         enddo ! j
3072         num_cont_hb(i)=num_conti
3073       enddo   ! i
3074 c      write (iout,*) "Number of loop steps in EELEC:",ind
3075 cd      do i=1,nres
3076 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3077 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3078 cd      enddo
3079 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3080 ccc      eel_loc=eel_loc+eello_turn3
3081 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3082       return
3083       end
3084 C-------------------------------------------------------------------------------
3085       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3086       implicit real*8 (a-h,o-z)
3087       include 'DIMENSIONS'
3088 #ifdef MPI
3089       include "mpif.h"
3090 #endif
3091       include 'COMMON.CONTROL'
3092       include 'COMMON.IOUNITS'
3093       include 'COMMON.GEO'
3094       include 'COMMON.VAR'
3095       include 'COMMON.LOCAL'
3096       include 'COMMON.CHAIN'
3097       include 'COMMON.DERIV'
3098       include 'COMMON.INTERACT'
3099       include 'COMMON.CONTACTS'
3100       include 'COMMON.TORSION'
3101       include 'COMMON.VECTORS'
3102       include 'COMMON.FFIELD'
3103       include 'COMMON.TIME1'
3104       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3105      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3106       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3107      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3108       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3109      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3110      &    num_conti,j1,j2
3111 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3112 #ifdef MOMENT
3113       double precision scal_el /1.0d0/
3114 #else
3115       double precision scal_el /0.5d0/
3116 #endif
3117 C 12/13/98
3118 C 13-go grudnia roku pamietnego...
3119       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3120      &                   0.0d0,1.0d0,0.0d0,
3121      &                   0.0d0,0.0d0,1.0d0/
3122 c          time00=MPI_Wtime()
3123 cd      write (iout,*) "eelecij",i,j
3124 c          ind=ind+1
3125           iteli=itel(i)
3126           itelj=itel(j)
3127           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3128           aaa=app(iteli,itelj)
3129           bbb=bpp(iteli,itelj)
3130           ael6i=ael6(iteli,itelj)
3131           ael3i=ael3(iteli,itelj)
3132           dxj=dc(1,j)
3133           dyj=dc(2,j)
3134           dzj=dc(3,j)
3135           dx_normj=dc_norm(1,j)
3136           dy_normj=dc_norm(2,j)
3137           dz_normj=dc_norm(3,j)
3138           xj=c(1,j)+0.5D0*dxj-xmedi
3139           yj=c(2,j)+0.5D0*dyj-ymedi
3140           zj=c(3,j)+0.5D0*dzj-zmedi
3141           rij=xj*xj+yj*yj+zj*zj
3142           rrmij=1.0D0/rij
3143           rij=dsqrt(rij)
3144           rmij=1.0D0/rij
3145           r3ij=rrmij*rmij
3146           r6ij=r3ij*r3ij
3147           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3148           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3149           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3150           fac=cosa-3.0D0*cosb*cosg
3151           ev1=aaa*r6ij*r6ij
3152 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3153           if (j.eq.i+2) ev1=scal_el*ev1
3154           ev2=bbb*r6ij
3155           fac3=ael6i*r6ij
3156           fac4=ael3i*r3ij
3157           evdwij=ev1+ev2
3158           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3159           el2=fac4*fac
3160           eesij=el1+el2
3161 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3162           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3163           ees=ees+eesij
3164           evdw1=evdw1+evdwij
3165 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3166 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3167 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3168 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3169
3170           if (energy_dec) then
3171               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3172               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3173           endif
3174
3175 C
3176 C Calculate contributions to the Cartesian gradient.
3177 C
3178 #ifdef SPLITELE
3179           facvdw=-6*rrmij*(ev1+evdwij)
3180           facel=-3*rrmij*(el1+eesij)
3181           fac1=fac
3182           erij(1)=xj*rmij
3183           erij(2)=yj*rmij
3184           erij(3)=zj*rmij
3185 *
3186 * Radial derivatives. First process both termini of the fragment (i,j)
3187 *
3188           ggg(1)=facel*xj
3189           ggg(2)=facel*yj
3190           ggg(3)=facel*zj
3191 c          do k=1,3
3192 c            ghalf=0.5D0*ggg(k)
3193 c            gelc(k,i)=gelc(k,i)+ghalf
3194 c            gelc(k,j)=gelc(k,j)+ghalf
3195 c          enddo
3196 c 9/28/08 AL Gradient compotents will be summed only at the end
3197           do k=1,3
3198             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3199             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3200           enddo
3201 *
3202 * Loop over residues i+1 thru j-1.
3203 *
3204 cgrad          do k=i+1,j-1
3205 cgrad            do l=1,3
3206 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3207 cgrad            enddo
3208 cgrad          enddo
3209           ggg(1)=facvdw*xj
3210           ggg(2)=facvdw*yj
3211           ggg(3)=facvdw*zj
3212 c          do k=1,3
3213 c            ghalf=0.5D0*ggg(k)
3214 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3215 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3216 c          enddo
3217 c 9/28/08 AL Gradient compotents will be summed only at the end
3218           do k=1,3
3219             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3220             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3221           enddo
3222 *
3223 * Loop over residues i+1 thru j-1.
3224 *
3225 cgrad          do k=i+1,j-1
3226 cgrad            do l=1,3
3227 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3228 cgrad            enddo
3229 cgrad          enddo
3230 #else
3231           facvdw=ev1+evdwij
3232           facel=el1+eesij
3233           fac1=fac
3234           fac=-3*rrmij*(facvdw+facvdw+facel)
3235           erij(1)=xj*rmij
3236           erij(2)=yj*rmij
3237           erij(3)=zj*rmij
3238 *
3239 * Radial derivatives. First process both termini of the fragment (i,j)
3240 *
3241           ggg(1)=fac*xj
3242           ggg(2)=fac*yj
3243           ggg(3)=fac*zj
3244 c          do k=1,3
3245 c            ghalf=0.5D0*ggg(k)
3246 c            gelc(k,i)=gelc(k,i)+ghalf
3247 c            gelc(k,j)=gelc(k,j)+ghalf
3248 c          enddo
3249 c 9/28/08 AL Gradient compotents will be summed only at the end
3250           do k=1,3
3251             gelc_long(k,j)=gelc(k,j)+ggg(k)
3252             gelc_long(k,i)=gelc(k,i)-ggg(k)
3253           enddo
3254 *
3255 * Loop over residues i+1 thru j-1.
3256 *
3257 cgrad          do k=i+1,j-1
3258 cgrad            do l=1,3
3259 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3260 cgrad            enddo
3261 cgrad          enddo
3262 c 9/28/08 AL Gradient compotents will be summed only at the end
3263           ggg(1)=facvdw*xj
3264           ggg(2)=facvdw*yj
3265           ggg(3)=facvdw*zj
3266           do k=1,3
3267             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3268             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3269           enddo
3270 #endif
3271 *
3272 * Angular part
3273 *
3274           ecosa=2.0D0*fac3*fac1+fac4
3275           fac4=-3.0D0*fac4
3276           fac3=-6.0D0*fac3
3277           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3278           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3279           do k=1,3
3280             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3281             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3282           enddo
3283 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3284 cd   &          (dcosg(k),k=1,3)
3285           do k=1,3
3286             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3287           enddo
3288 c          do k=1,3
3289 c            ghalf=0.5D0*ggg(k)
3290 c            gelc(k,i)=gelc(k,i)+ghalf
3291 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3292 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3293 c            gelc(k,j)=gelc(k,j)+ghalf
3294 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3295 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3296 c          enddo
3297 cgrad          do k=i+1,j-1
3298 cgrad            do l=1,3
3299 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3300 cgrad            enddo
3301 cgrad          enddo
3302           do k=1,3
3303             gelc(k,i)=gelc(k,i)
3304      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3305      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3306             gelc(k,j)=gelc(k,j)
3307      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3308      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3309             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3310             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3311           enddo
3312           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3313      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3314      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3315 C
3316 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3317 C   energy of a peptide unit is assumed in the form of a second-order
3318 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3319 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3320 C   are computed for EVERY pair of non-contiguous peptide groups.
3321 C
3322           if (j.lt.nres-1) then
3323             j1=j+1
3324             j2=j-1
3325           else
3326             j1=j-1
3327             j2=j-2
3328           endif
3329           kkk=0
3330           do k=1,2
3331             do l=1,2
3332               kkk=kkk+1
3333               muij(kkk)=mu(k,i)*mu(l,j)
3334             enddo
3335           enddo
3336 cd         write (iout,*) 'EELEC: i',i,' j',j
3337 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3338 cd          write(iout,*) 'muij',muij
3339           ury=scalar(uy(1,i),erij)
3340           urz=scalar(uz(1,i),erij)
3341           vry=scalar(uy(1,j),erij)
3342           vrz=scalar(uz(1,j),erij)
3343           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3344           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3345           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3346           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3347           fac=dsqrt(-ael6i)*r3ij
3348           a22=a22*fac
3349           a23=a23*fac
3350           a32=a32*fac
3351           a33=a33*fac
3352 cd          write (iout,'(4i5,4f10.5)')
3353 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3354 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3355 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3356 cd     &      uy(:,j),uz(:,j)
3357 cd          write (iout,'(4f10.5)')
3358 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3359 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3360 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3361 cd           write (iout,'(9f10.5/)')
3362 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3363 C Derivatives of the elements of A in virtual-bond vectors
3364           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3365           do k=1,3
3366             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3367             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3368             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3369             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3370             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3371             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3372             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3373             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3374             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3375             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3376             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3377             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3378           enddo
3379 C Compute radial contributions to the gradient
3380           facr=-3.0d0*rrmij
3381           a22der=a22*facr
3382           a23der=a23*facr
3383           a32der=a32*facr
3384           a33der=a33*facr
3385           agg(1,1)=a22der*xj
3386           agg(2,1)=a22der*yj
3387           agg(3,1)=a22der*zj
3388           agg(1,2)=a23der*xj
3389           agg(2,2)=a23der*yj
3390           agg(3,2)=a23der*zj
3391           agg(1,3)=a32der*xj
3392           agg(2,3)=a32der*yj
3393           agg(3,3)=a32der*zj
3394           agg(1,4)=a33der*xj
3395           agg(2,4)=a33der*yj
3396           agg(3,4)=a33der*zj
3397 C Add the contributions coming from er
3398           fac3=-3.0d0*fac
3399           do k=1,3
3400             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3401             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3402             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3403             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3404           enddo
3405           do k=1,3
3406 C Derivatives in DC(i)
3407 cgrad            ghalf1=0.5d0*agg(k,1)
3408 cgrad            ghalf2=0.5d0*agg(k,2)
3409 cgrad            ghalf3=0.5d0*agg(k,3)
3410 cgrad            ghalf4=0.5d0*agg(k,4)
3411             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3412      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3413             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3414      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3415             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3416      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3417             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3418      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3419 C Derivatives in DC(i+1)
3420             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3421      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3422             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3423      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3424             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3425      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3426             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3427      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3428 C Derivatives in DC(j)
3429             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3430      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3431             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3432      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3433             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3434      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3435             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3436      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3437 C Derivatives in DC(j+1) or DC(nres-1)
3438             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3439      &      -3.0d0*vryg(k,3)*ury)
3440             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3441      &      -3.0d0*vrzg(k,3)*ury)
3442             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3443      &      -3.0d0*vryg(k,3)*urz)
3444             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3445      &      -3.0d0*vrzg(k,3)*urz)
3446 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3447 cgrad              do l=1,4
3448 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3449 cgrad              enddo
3450 cgrad            endif
3451           enddo
3452           acipa(1,1)=a22
3453           acipa(1,2)=a23
3454           acipa(2,1)=a32
3455           acipa(2,2)=a33
3456           a22=-a22
3457           a23=-a23
3458           do l=1,2
3459             do k=1,3
3460               agg(k,l)=-agg(k,l)
3461               aggi(k,l)=-aggi(k,l)
3462               aggi1(k,l)=-aggi1(k,l)
3463               aggj(k,l)=-aggj(k,l)
3464               aggj1(k,l)=-aggj1(k,l)
3465             enddo
3466           enddo
3467           if (j.lt.nres-1) then
3468             a22=-a22
3469             a32=-a32
3470             do l=1,3,2
3471               do k=1,3
3472                 agg(k,l)=-agg(k,l)
3473                 aggi(k,l)=-aggi(k,l)
3474                 aggi1(k,l)=-aggi1(k,l)
3475                 aggj(k,l)=-aggj(k,l)
3476                 aggj1(k,l)=-aggj1(k,l)
3477               enddo
3478             enddo
3479           else
3480             a22=-a22
3481             a23=-a23
3482             a32=-a32
3483             a33=-a33
3484             do l=1,4
3485               do k=1,3
3486                 agg(k,l)=-agg(k,l)
3487                 aggi(k,l)=-aggi(k,l)
3488                 aggi1(k,l)=-aggi1(k,l)
3489                 aggj(k,l)=-aggj(k,l)
3490                 aggj1(k,l)=-aggj1(k,l)
3491               enddo
3492             enddo
3493           endif
3494           ENDIF ! WCORR
3495           IF (wel_loc.gt.0.0d0) THEN
3496 C Contribution to the local-electrostatic energy coming from the i-j pair
3497           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3498      &     +a33*muij(4)
3499 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3500
3501           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3502      &            'eelloc',i,j,eel_loc_ij
3503
3504           eel_loc=eel_loc+eel_loc_ij
3505 C Partial derivatives in virtual-bond dihedral angles gamma
3506           if (i.gt.1)
3507      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3508      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3509      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3510           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3511      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3512      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3513 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3514           do l=1,3
3515             ggg(l)=agg(l,1)*muij(1)+
3516      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3517             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3518             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3519 cgrad            ghalf=0.5d0*ggg(l)
3520 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3521 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3522           enddo
3523 cgrad          do k=i+1,j2
3524 cgrad            do l=1,3
3525 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3526 cgrad            enddo
3527 cgrad          enddo
3528 C Remaining derivatives of eello
3529           do l=1,3
3530             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3531      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3532             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3533      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3534             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3535      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3536             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3537      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3538           enddo
3539           ENDIF
3540 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3541 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3542           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3543      &       .and. num_conti.le.maxconts) then
3544 c            write (iout,*) i,j," entered corr"
3545 C
3546 C Calculate the contact function. The ith column of the array JCONT will
3547 C contain the numbers of atoms that make contacts with the atom I (of numbers
3548 C greater than I). The arrays FACONT and GACONT will contain the values of
3549 C the contact function and its derivative.
3550 c           r0ij=1.02D0*rpp(iteli,itelj)
3551 c           r0ij=1.11D0*rpp(iteli,itelj)
3552             r0ij=2.20D0*rpp(iteli,itelj)
3553 c           r0ij=1.55D0*rpp(iteli,itelj)
3554             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3555             if (fcont.gt.0.0D0) then
3556               num_conti=num_conti+1
3557               if (num_conti.gt.maxconts) then
3558                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3559      &                         ' will skip next contacts for this conf.'
3560               else
3561                 jcont_hb(num_conti,i)=j
3562 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3563 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3564                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3565      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3566 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3567 C  terms.
3568                 d_cont(num_conti,i)=rij
3569 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3570 C     --- Electrostatic-interaction matrix ---
3571                 a_chuj(1,1,num_conti,i)=a22
3572                 a_chuj(1,2,num_conti,i)=a23
3573                 a_chuj(2,1,num_conti,i)=a32
3574                 a_chuj(2,2,num_conti,i)=a33
3575 C     --- Gradient of rij
3576                 do kkk=1,3
3577                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3578                 enddo
3579                 kkll=0
3580                 do k=1,2
3581                   do l=1,2
3582                     kkll=kkll+1
3583                     do m=1,3
3584                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3585                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3586                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3587                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3588                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3589                     enddo
3590                   enddo
3591                 enddo
3592                 ENDIF
3593                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3594 C Calculate contact energies
3595                 cosa4=4.0D0*cosa
3596                 wij=cosa-3.0D0*cosb*cosg
3597                 cosbg1=cosb+cosg
3598                 cosbg2=cosb-cosg
3599 c               fac3=dsqrt(-ael6i)/r0ij**3
3600                 fac3=dsqrt(-ael6i)*r3ij
3601 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3602                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3603                 if (ees0tmp.gt.0) then
3604                   ees0pij=dsqrt(ees0tmp)
3605                 else
3606                   ees0pij=0
3607                 endif
3608 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3609                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3610                 if (ees0tmp.gt.0) then
3611                   ees0mij=dsqrt(ees0tmp)
3612                 else
3613                   ees0mij=0
3614                 endif
3615 c               ees0mij=0.0D0
3616                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3617                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3618 C Diagnostics. Comment out or remove after debugging!
3619 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3620 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3621 c               ees0m(num_conti,i)=0.0D0
3622 C End diagnostics.
3623 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3624 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3625 C Angular derivatives of the contact function
3626                 ees0pij1=fac3/ees0pij
3627                 ees0mij1=fac3/ees0mij
3628                 fac3p=-3.0D0*fac3*rrmij
3629                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3630                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3631 c               ees0mij1=0.0D0
3632                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3633                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3634                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3635                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3636                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3637                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3638                 ecosap=ecosa1+ecosa2
3639                 ecosbp=ecosb1+ecosb2
3640                 ecosgp=ecosg1+ecosg2
3641                 ecosam=ecosa1-ecosa2
3642                 ecosbm=ecosb1-ecosb2
3643                 ecosgm=ecosg1-ecosg2
3644 C Diagnostics
3645 c               ecosap=ecosa1
3646 c               ecosbp=ecosb1
3647 c               ecosgp=ecosg1
3648 c               ecosam=0.0D0
3649 c               ecosbm=0.0D0
3650 c               ecosgm=0.0D0
3651 C End diagnostics
3652                 facont_hb(num_conti,i)=fcont
3653                 fprimcont=fprimcont/rij
3654 cd              facont_hb(num_conti,i)=1.0D0
3655 C Following line is for diagnostics.
3656 cd              fprimcont=0.0D0
3657                 do k=1,3
3658                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3659                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3660                 enddo
3661                 do k=1,3
3662                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3663                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3664                 enddo
3665                 gggp(1)=gggp(1)+ees0pijp*xj
3666                 gggp(2)=gggp(2)+ees0pijp*yj
3667                 gggp(3)=gggp(3)+ees0pijp*zj
3668                 gggm(1)=gggm(1)+ees0mijp*xj
3669                 gggm(2)=gggm(2)+ees0mijp*yj
3670                 gggm(3)=gggm(3)+ees0mijp*zj
3671 C Derivatives due to the contact function
3672                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3673                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3674                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3675                 do k=1,3
3676 c
3677 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3678 c          following the change of gradient-summation algorithm.
3679 c
3680 cgrad                  ghalfp=0.5D0*gggp(k)
3681 cgrad                  ghalfm=0.5D0*gggm(k)
3682                   gacontp_hb1(k,num_conti,i)=!ghalfp
3683      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3684      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3685                   gacontp_hb2(k,num_conti,i)=!ghalfp
3686      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3687      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3688                   gacontp_hb3(k,num_conti,i)=gggp(k)
3689                   gacontm_hb1(k,num_conti,i)=!ghalfm
3690      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3691      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3692                   gacontm_hb2(k,num_conti,i)=!ghalfm
3693      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3694      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3695                   gacontm_hb3(k,num_conti,i)=gggm(k)
3696                 enddo
3697 C Diagnostics. Comment out or remove after debugging!
3698 cdiag           do k=1,3
3699 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3700 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3701 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3702 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3703 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3704 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3705 cdiag           enddo
3706               ENDIF ! wcorr
3707               endif  ! num_conti.le.maxconts
3708             endif  ! fcont.gt.0
3709           endif    ! j.gt.i+1
3710           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3711             do k=1,4
3712               do l=1,3
3713                 ghalf=0.5d0*agg(l,k)
3714                 aggi(l,k)=aggi(l,k)+ghalf
3715                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3716                 aggj(l,k)=aggj(l,k)+ghalf
3717               enddo
3718             enddo
3719             if (j.eq.nres-1 .and. i.lt.j-2) then
3720               do k=1,4
3721                 do l=1,3
3722                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3723                 enddo
3724               enddo
3725             endif
3726           endif
3727 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3728       return
3729       end
3730 C-----------------------------------------------------------------------------
3731       subroutine eturn3(i,eello_turn3)
3732 C Third- and fourth-order contributions from turns
3733       implicit real*8 (a-h,o-z)
3734       include 'DIMENSIONS'
3735       include 'COMMON.IOUNITS'
3736       include 'COMMON.GEO'
3737       include 'COMMON.VAR'
3738       include 'COMMON.LOCAL'
3739       include 'COMMON.CHAIN'
3740       include 'COMMON.DERIV'
3741       include 'COMMON.INTERACT'
3742       include 'COMMON.CONTACTS'
3743       include 'COMMON.TORSION'
3744       include 'COMMON.VECTORS'
3745       include 'COMMON.FFIELD'
3746       include 'COMMON.CONTROL'
3747       dimension ggg(3)
3748       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3749      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3750      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3751       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3752      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3753       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3754      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3755      &    num_conti,j1,j2
3756       j=i+2
3757 c      write (iout,*) "eturn3",i,j,j1,j2
3758       a_temp(1,1)=a22
3759       a_temp(1,2)=a23
3760       a_temp(2,1)=a32
3761       a_temp(2,2)=a33
3762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3763 C
3764 C               Third-order contributions
3765 C
3766 C                 (i+2)o----(i+3)
3767 C                      | |
3768 C                      | |
3769 C                 (i+1)o----i
3770 C
3771 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3772 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3773         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3774         call transpose2(auxmat(1,1),auxmat1(1,1))
3775         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3776         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3777         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3778      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3779 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3780 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3781 cd     &    ' eello_turn3_num',4*eello_turn3_num
3782 C Derivatives in gamma(i)
3783         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3784         call transpose2(auxmat2(1,1),auxmat3(1,1))
3785         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3786         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3787 C Derivatives in gamma(i+1)
3788         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3789         call transpose2(auxmat2(1,1),auxmat3(1,1))
3790         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3791         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3792      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3793 C Cartesian derivatives
3794         do l=1,3
3795 c            ghalf1=0.5d0*agg(l,1)
3796 c            ghalf2=0.5d0*agg(l,2)
3797 c            ghalf3=0.5d0*agg(l,3)
3798 c            ghalf4=0.5d0*agg(l,4)
3799           a_temp(1,1)=aggi(l,1)!+ghalf1
3800           a_temp(1,2)=aggi(l,2)!+ghalf2
3801           a_temp(2,1)=aggi(l,3)!+ghalf3
3802           a_temp(2,2)=aggi(l,4)!+ghalf4
3803           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3804           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3805      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3806           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3807           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3808           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3809           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3810           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3811           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3812      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3813           a_temp(1,1)=aggj(l,1)!+ghalf1
3814           a_temp(1,2)=aggj(l,2)!+ghalf2
3815           a_temp(2,1)=aggj(l,3)!+ghalf3
3816           a_temp(2,2)=aggj(l,4)!+ghalf4
3817           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3818           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3819      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3820           a_temp(1,1)=aggj1(l,1)
3821           a_temp(1,2)=aggj1(l,2)
3822           a_temp(2,1)=aggj1(l,3)
3823           a_temp(2,2)=aggj1(l,4)
3824           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3825           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3826      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3827         enddo
3828       return
3829       end
3830 C-------------------------------------------------------------------------------
3831       subroutine eturn4(i,eello_turn4)
3832 C Third- and fourth-order contributions from turns
3833       implicit real*8 (a-h,o-z)
3834       include 'DIMENSIONS'
3835       include 'COMMON.IOUNITS'
3836       include 'COMMON.GEO'
3837       include 'COMMON.VAR'
3838       include 'COMMON.LOCAL'
3839       include 'COMMON.CHAIN'
3840       include 'COMMON.DERIV'
3841       include 'COMMON.INTERACT'
3842       include 'COMMON.CONTACTS'
3843       include 'COMMON.TORSION'
3844       include 'COMMON.VECTORS'
3845       include 'COMMON.FFIELD'
3846       include 'COMMON.CONTROL'
3847       dimension ggg(3)
3848       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3849      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3850      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3851       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3852      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3853       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3854      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3855      &    num_conti,j1,j2
3856       j=i+3
3857 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3858 C
3859 C               Fourth-order contributions
3860 C
3861 C                 (i+3)o----(i+4)
3862 C                     /  |
3863 C               (i+2)o   |
3864 C                     \  |
3865 C                 (i+1)o----i
3866 C
3867 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3868 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3869 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3870         a_temp(1,1)=a22
3871         a_temp(1,2)=a23
3872         a_temp(2,1)=a32
3873         a_temp(2,2)=a33
3874         iti1=itortyp(itype(i+1))
3875         iti2=itortyp(itype(i+2))
3876         iti3=itortyp(itype(i+3))
3877 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3878         call transpose2(EUg(1,1,i+1),e1t(1,1))
3879         call transpose2(Eug(1,1,i+2),e2t(1,1))
3880         call transpose2(Eug(1,1,i+3),e3t(1,1))
3881         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3882         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3883         s1=scalar2(b1(1,iti2),auxvec(1))
3884         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3885         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3886         s2=scalar2(b1(1,iti1),auxvec(1))
3887         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3888         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3889         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3890         eello_turn4=eello_turn4-(s1+s2+s3)
3891         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3892      &      'eturn4',i,j,-(s1+s2+s3)
3893 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3894 cd     &    ' eello_turn4_num',8*eello_turn4_num
3895 C Derivatives in gamma(i)
3896         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3897         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3898         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3899         s1=scalar2(b1(1,iti2),auxvec(1))
3900         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3901         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3902         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3903 C Derivatives in gamma(i+1)
3904         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3905         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3906         s2=scalar2(b1(1,iti1),auxvec(1))
3907         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3908         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3909         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3910         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3911 C Derivatives in gamma(i+2)
3912         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3913         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3914         s1=scalar2(b1(1,iti2),auxvec(1))
3915         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3916         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3917         s2=scalar2(b1(1,iti1),auxvec(1))
3918         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3919         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3920         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3921         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3922 C Cartesian derivatives
3923 C Derivatives of this turn contributions in DC(i+2)
3924         if (j.lt.nres-1) then
3925           do l=1,3
3926             a_temp(1,1)=agg(l,1)
3927             a_temp(1,2)=agg(l,2)
3928             a_temp(2,1)=agg(l,3)
3929             a_temp(2,2)=agg(l,4)
3930             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3931             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3932             s1=scalar2(b1(1,iti2),auxvec(1))
3933             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3934             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3935             s2=scalar2(b1(1,iti1),auxvec(1))
3936             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3937             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3938             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3939             ggg(l)=-(s1+s2+s3)
3940             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3941           enddo
3942         endif
3943 C Remaining derivatives of this turn contribution
3944         do l=1,3
3945           a_temp(1,1)=aggi(l,1)
3946           a_temp(1,2)=aggi(l,2)
3947           a_temp(2,1)=aggi(l,3)
3948           a_temp(2,2)=aggi(l,4)
3949           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3950           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3951           s1=scalar2(b1(1,iti2),auxvec(1))
3952           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3953           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3954           s2=scalar2(b1(1,iti1),auxvec(1))
3955           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3956           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3957           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3958           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3959           a_temp(1,1)=aggi1(l,1)
3960           a_temp(1,2)=aggi1(l,2)
3961           a_temp(2,1)=aggi1(l,3)
3962           a_temp(2,2)=aggi1(l,4)
3963           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3964           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3965           s1=scalar2(b1(1,iti2),auxvec(1))
3966           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3967           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3968           s2=scalar2(b1(1,iti1),auxvec(1))
3969           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3970           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3971           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3972           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3973           a_temp(1,1)=aggj(l,1)
3974           a_temp(1,2)=aggj(l,2)
3975           a_temp(2,1)=aggj(l,3)
3976           a_temp(2,2)=aggj(l,4)
3977           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3978           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3979           s1=scalar2(b1(1,iti2),auxvec(1))
3980           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3981           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3982           s2=scalar2(b1(1,iti1),auxvec(1))
3983           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3984           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3985           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3986           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3987           a_temp(1,1)=aggj1(l,1)
3988           a_temp(1,2)=aggj1(l,2)
3989           a_temp(2,1)=aggj1(l,3)
3990           a_temp(2,2)=aggj1(l,4)
3991           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3992           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3993           s1=scalar2(b1(1,iti2),auxvec(1))
3994           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3995           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3996           s2=scalar2(b1(1,iti1),auxvec(1))
3997           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3998           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3999           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4000 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4001           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4002         enddo
4003       return
4004       end
4005 C-----------------------------------------------------------------------------
4006       subroutine vecpr(u,v,w)
4007       implicit real*8(a-h,o-z)
4008       dimension u(3),v(3),w(3)
4009       w(1)=u(2)*v(3)-u(3)*v(2)
4010       w(2)=-u(1)*v(3)+u(3)*v(1)
4011       w(3)=u(1)*v(2)-u(2)*v(1)
4012       return
4013       end
4014 C-----------------------------------------------------------------------------
4015       subroutine unormderiv(u,ugrad,unorm,ungrad)
4016 C This subroutine computes the derivatives of a normalized vector u, given
4017 C the derivatives computed without normalization conditions, ugrad. Returns
4018 C ungrad.
4019       implicit none
4020       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4021       double precision vec(3)
4022       double precision scalar
4023       integer i,j
4024 c      write (2,*) 'ugrad',ugrad
4025 c      write (2,*) 'u',u
4026       do i=1,3
4027         vec(i)=scalar(ugrad(1,i),u(1))
4028       enddo
4029 c      write (2,*) 'vec',vec
4030       do i=1,3
4031         do j=1,3
4032           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4033         enddo
4034       enddo
4035 c      write (2,*) 'ungrad',ungrad
4036       return
4037       end
4038 C-----------------------------------------------------------------------------
4039       subroutine escp_soft_sphere(evdw2,evdw2_14)
4040 C
4041 C This subroutine calculates the excluded-volume interaction energy between
4042 C peptide-group centers and side chains and its gradient in virtual-bond and
4043 C side-chain vectors.
4044 C
4045       implicit real*8 (a-h,o-z)
4046       include 'DIMENSIONS'
4047       include 'COMMON.GEO'
4048       include 'COMMON.VAR'
4049       include 'COMMON.LOCAL'
4050       include 'COMMON.CHAIN'
4051       include 'COMMON.DERIV'
4052       include 'COMMON.INTERACT'
4053       include 'COMMON.FFIELD'
4054       include 'COMMON.IOUNITS'
4055       include 'COMMON.CONTROL'
4056       dimension ggg(3)
4057       evdw2=0.0D0
4058       evdw2_14=0.0d0
4059       r0_scp=4.5d0
4060 cd    print '(a)','Enter ESCP'
4061 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4062       do i=iatscp_s,iatscp_e
4063         iteli=itel(i)
4064         xi=0.5D0*(c(1,i)+c(1,i+1))
4065         yi=0.5D0*(c(2,i)+c(2,i+1))
4066         zi=0.5D0*(c(3,i)+c(3,i+1))
4067
4068         do iint=1,nscp_gr(i)
4069
4070         do j=iscpstart(i,iint),iscpend(i,iint)
4071           itypj=itype(j)
4072 C Uncomment following three lines for SC-p interactions
4073 c         xj=c(1,nres+j)-xi
4074 c         yj=c(2,nres+j)-yi
4075 c         zj=c(3,nres+j)-zi
4076 C Uncomment following three lines for Ca-p interactions
4077           xj=c(1,j)-xi
4078           yj=c(2,j)-yi
4079           zj=c(3,j)-zi
4080           rij=xj*xj+yj*yj+zj*zj
4081           r0ij=r0_scp
4082           r0ijsq=r0ij*r0ij
4083           if (rij.lt.r0ijsq) then
4084             evdwij=0.25d0*(rij-r0ijsq)**2
4085             fac=rij-r0ijsq
4086           else
4087             evdwij=0.0d0
4088             fac=0.0d0
4089           endif
4090           evdw2=evdw2+evdwij
4091 C
4092 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4093 C
4094           ggg(1)=xj*fac
4095           ggg(2)=yj*fac
4096           ggg(3)=zj*fac
4097 cgrad          if (j.lt.i) then
4098 cd          write (iout,*) 'j<i'
4099 C Uncomment following three lines for SC-p interactions
4100 c           do k=1,3
4101 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4102 c           enddo
4103 cgrad          else
4104 cd          write (iout,*) 'j>i'
4105 cgrad            do k=1,3
4106 cgrad              ggg(k)=-ggg(k)
4107 C Uncomment following line for SC-p interactions
4108 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4109 cgrad            enddo
4110 cgrad          endif
4111 cgrad          do k=1,3
4112 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4113 cgrad          enddo
4114 cgrad          kstart=min0(i+1,j)
4115 cgrad          kend=max0(i-1,j-1)
4116 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4117 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4118 cgrad          do k=kstart,kend
4119 cgrad            do l=1,3
4120 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4121 cgrad            enddo
4122 cgrad          enddo
4123           do k=1,3
4124             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4125             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4126           enddo
4127         enddo
4128
4129         enddo ! iint
4130       enddo ! i
4131       return
4132       end
4133 C-----------------------------------------------------------------------------
4134       subroutine escp(evdw2,evdw2_14)
4135 C
4136 C This subroutine calculates the excluded-volume interaction energy between
4137 C peptide-group centers and side chains and its gradient in virtual-bond and
4138 C side-chain vectors.
4139 C
4140       implicit real*8 (a-h,o-z)
4141       include 'DIMENSIONS'
4142       include 'COMMON.GEO'
4143       include 'COMMON.VAR'
4144       include 'COMMON.LOCAL'
4145       include 'COMMON.CHAIN'
4146       include 'COMMON.DERIV'
4147       include 'COMMON.INTERACT'
4148       include 'COMMON.FFIELD'
4149       include 'COMMON.IOUNITS'
4150       include 'COMMON.CONTROL'
4151       dimension ggg(3)
4152       evdw2=0.0D0
4153       evdw2_14=0.0d0
4154 cd    print '(a)','Enter ESCP'
4155 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4156       do i=iatscp_s,iatscp_e
4157         iteli=itel(i)
4158         xi=0.5D0*(c(1,i)+c(1,i+1))
4159         yi=0.5D0*(c(2,i)+c(2,i+1))
4160         zi=0.5D0*(c(3,i)+c(3,i+1))
4161
4162         do iint=1,nscp_gr(i)
4163
4164         do j=iscpstart(i,iint),iscpend(i,iint)
4165           itypj=itype(j)
4166 C Uncomment following three lines for SC-p interactions
4167 c         xj=c(1,nres+j)-xi
4168 c         yj=c(2,nres+j)-yi
4169 c         zj=c(3,nres+j)-zi
4170 C Uncomment following three lines for Ca-p interactions
4171           xj=c(1,j)-xi
4172           yj=c(2,j)-yi
4173           zj=c(3,j)-zi
4174           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4175           fac=rrij**expon2
4176           e1=fac*fac*aad(itypj,iteli)
4177           e2=fac*bad(itypj,iteli)
4178           if (iabs(j-i) .le. 2) then
4179             e1=scal14*e1
4180             e2=scal14*e2
4181             evdw2_14=evdw2_14+e1+e2
4182           endif
4183           evdwij=e1+e2
4184           evdw2=evdw2+evdwij
4185           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4186      &        'evdw2',i,j,evdwij
4187 C
4188 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4189 C
4190           fac=-(evdwij+e1)*rrij
4191           ggg(1)=xj*fac
4192           ggg(2)=yj*fac
4193           ggg(3)=zj*fac
4194 cgrad          if (j.lt.i) then
4195 cd          write (iout,*) 'j<i'
4196 C Uncomment following three lines for SC-p interactions
4197 c           do k=1,3
4198 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4199 c           enddo
4200 cgrad          else
4201 cd          write (iout,*) 'j>i'
4202 cgrad            do k=1,3
4203 cgrad              ggg(k)=-ggg(k)
4204 C Uncomment following line for SC-p interactions
4205 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4206 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4207 cgrad            enddo
4208 cgrad          endif
4209 cgrad          do k=1,3
4210 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4211 cgrad          enddo
4212 cgrad          kstart=min0(i+1,j)
4213 cgrad          kend=max0(i-1,j-1)
4214 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4215 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4216 cgrad          do k=kstart,kend
4217 cgrad            do l=1,3
4218 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4219 cgrad            enddo
4220 cgrad          enddo
4221           do k=1,3
4222             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4223             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4224           enddo
4225         enddo
4226
4227         enddo ! iint
4228       enddo ! i
4229       do i=1,nct
4230         do j=1,3
4231           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4232           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4233           gradx_scp(j,i)=expon*gradx_scp(j,i)
4234         enddo
4235       enddo
4236 C******************************************************************************
4237 C
4238 C                              N O T E !!!
4239 C
4240 C To save time the factor EXPON has been extracted from ALL components
4241 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4242 C use!
4243 C
4244 C******************************************************************************
4245       return
4246       end
4247 C--------------------------------------------------------------------------
4248       subroutine edis(ehpb)
4249 C
4250 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4251 C
4252       implicit real*8 (a-h,o-z)
4253       include 'DIMENSIONS'
4254       include 'COMMON.SBRIDGE'
4255       include 'COMMON.CHAIN'
4256       include 'COMMON.DERIV'
4257       include 'COMMON.VAR'
4258       include 'COMMON.INTERACT'
4259       include 'COMMON.IOUNITS'
4260       dimension ggg(3)
4261       ehpb=0.0D0
4262 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4263 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4264       if (link_end.eq.0) return
4265       do i=link_start,link_end
4266 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4267 C CA-CA distance used in regularization of structure.
4268         ii=ihpb(i)
4269         jj=jhpb(i)
4270 C iii and jjj point to the residues for which the distance is assigned.
4271         if (ii.gt.nres) then
4272           iii=ii-nres
4273           jjj=jj-nres
4274         else
4275           iii=ii
4276           jjj=jj
4277         endif
4278 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4279 c     &    dhpb(i),dhpb1(i),forcon(i)
4280 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4281 C    distance and angle dependent SS bond potential.
4282 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4283 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4284         if (.not.dyn_ss .and. i.le.nss) then
4285 C 15/02/13 CC dynamic SSbond - additional check
4286          if (ii.gt.nres
4287      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4288           call ssbond_ene(iii,jjj,eij)
4289           ehpb=ehpb+2*eij
4290          endif
4291 cd          write (iout,*) "eij",eij
4292         else if (ii.gt.nres .and. jj.gt.nres) then
4293 c Restraints from contact prediction
4294           dd=dist(ii,jj)
4295           if (dhpb1(i).gt.0.0d0) then
4296             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4297             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4298 c            write (iout,*) "beta nmr",
4299 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4300           else
4301             dd=dist(ii,jj)
4302             rdis=dd-dhpb(i)
4303 C Get the force constant corresponding to this distance.
4304             waga=forcon(i)
4305 C Calculate the contribution to energy.
4306             ehpb=ehpb+waga*rdis*rdis
4307 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4308 C
4309 C Evaluate gradient.
4310 C
4311             fac=waga*rdis/dd
4312           endif
4313           do j=1,3
4314             ggg(j)=fac*(c(j,jj)-c(j,ii))
4315           enddo
4316           do j=1,3
4317             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4318             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4319           enddo
4320           do k=1,3
4321             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4322             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4323           enddo
4324         else
4325 C Calculate the distance between the two points and its difference from the
4326 C target distance.
4327           dd=dist(ii,jj)
4328           if (dhpb1(i).gt.0.0d0) then
4329             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4330             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4331 c            write (iout,*) "alph nmr",
4332 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4333           else
4334             rdis=dd-dhpb(i)
4335 C Get the force constant corresponding to this distance.
4336             waga=forcon(i)
4337 C Calculate the contribution to energy.
4338             ehpb=ehpb+waga*rdis*rdis
4339 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4340 C
4341 C Evaluate gradient.
4342 C
4343             fac=waga*rdis/dd
4344           endif
4345 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4346 cd   &   ' waga=',waga,' fac=',fac
4347             do j=1,3
4348               ggg(j)=fac*(c(j,jj)-c(j,ii))
4349             enddo
4350 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4351 C If this is a SC-SC distance, we need to calculate the contributions to the
4352 C Cartesian gradient in the SC vectors (ghpbx).
4353           if (iii.lt.ii) then
4354           do j=1,3
4355             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4356             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4357           enddo
4358           endif
4359 cgrad        do j=iii,jjj-1
4360 cgrad          do k=1,3
4361 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4362 cgrad          enddo
4363 cgrad        enddo
4364           do k=1,3
4365             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4366             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4367           enddo
4368         endif
4369       enddo
4370       ehpb=0.5D0*ehpb
4371       return
4372       end
4373 C--------------------------------------------------------------------------
4374       subroutine ssbond_ene(i,j,eij)
4375 C
4376 C Calculate the distance and angle dependent SS-bond potential energy
4377 C using a free-energy function derived based on RHF/6-31G** ab initio
4378 C calculations of diethyl disulfide.
4379 C
4380 C A. Liwo and U. Kozlowska, 11/24/03
4381 C
4382       implicit real*8 (a-h,o-z)
4383       include 'DIMENSIONS'
4384       include 'COMMON.SBRIDGE'
4385       include 'COMMON.CHAIN'
4386       include 'COMMON.DERIV'
4387       include 'COMMON.LOCAL'
4388       include 'COMMON.INTERACT'
4389       include 'COMMON.VAR'
4390       include 'COMMON.IOUNITS'
4391       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4392       itypi=itype(i)
4393       xi=c(1,nres+i)
4394       yi=c(2,nres+i)
4395       zi=c(3,nres+i)
4396       dxi=dc_norm(1,nres+i)
4397       dyi=dc_norm(2,nres+i)
4398       dzi=dc_norm(3,nres+i)
4399 c      dsci_inv=dsc_inv(itypi)
4400       dsci_inv=vbld_inv(nres+i)
4401       itypj=itype(j)
4402 c      dscj_inv=dsc_inv(itypj)
4403       dscj_inv=vbld_inv(nres+j)
4404       xj=c(1,nres+j)-xi
4405       yj=c(2,nres+j)-yi
4406       zj=c(3,nres+j)-zi
4407       dxj=dc_norm(1,nres+j)
4408       dyj=dc_norm(2,nres+j)
4409       dzj=dc_norm(3,nres+j)
4410       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4411       rij=dsqrt(rrij)
4412       erij(1)=xj*rij
4413       erij(2)=yj*rij
4414       erij(3)=zj*rij
4415       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4416       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4417       om12=dxi*dxj+dyi*dyj+dzi*dzj
4418       do k=1,3
4419         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4420         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4421       enddo
4422       rij=1.0d0/rij
4423       deltad=rij-d0cm
4424       deltat1=1.0d0-om1
4425       deltat2=1.0d0+om2
4426       deltat12=om2-om1+2.0d0
4427       cosphi=om12-om1*om2
4428       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4429      &  +akct*deltad*deltat12+ebr
4430      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4431 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4432 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4433 c     &  " deltat12",deltat12," eij",eij
4434       ed=2*akcm*deltad+akct*deltat12
4435       pom1=akct*deltad
4436       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4437       eom1=-2*akth*deltat1-pom1-om2*pom2
4438       eom2= 2*akth*deltat2+pom1-om1*pom2
4439       eom12=pom2
4440       do k=1,3
4441         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4442         ghpbx(k,i)=ghpbx(k,i)-ggk
4443      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4444      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4445         ghpbx(k,j)=ghpbx(k,j)+ggk
4446      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4447      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4448         ghpbc(k,i)=ghpbc(k,i)-ggk
4449         ghpbc(k,j)=ghpbc(k,j)+ggk
4450       enddo
4451 C
4452 C Calculate the components of the gradient in DC and X
4453 C
4454 cgrad      do k=i,j-1
4455 cgrad        do l=1,3
4456 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4457 cgrad        enddo
4458 cgrad      enddo
4459       return
4460       end
4461 C--------------------------------------------------------------------------
4462       subroutine ebond(estr)
4463 c
4464 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4465 c
4466       implicit real*8 (a-h,o-z)
4467       include 'DIMENSIONS'
4468       include 'COMMON.LOCAL'
4469       include 'COMMON.GEO'
4470       include 'COMMON.INTERACT'
4471       include 'COMMON.DERIV'
4472       include 'COMMON.VAR'
4473       include 'COMMON.CHAIN'
4474       include 'COMMON.IOUNITS'
4475       include 'COMMON.NAMES'
4476       include 'COMMON.FFIELD'
4477       include 'COMMON.CONTROL'
4478       include 'COMMON.SETUP'
4479       double precision u(3),ud(3)
4480       estr=0.0d0
4481       do i=ibondp_start,ibondp_end
4482         diff = vbld(i)-vbldp0
4483 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4484         estr=estr+diff*diff
4485         do j=1,3
4486           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4487         enddo
4488 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4489       enddo
4490       estr=0.5d0*AKP*estr
4491 c
4492 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4493 c
4494       do i=ibond_start,ibond_end
4495         iti=itype(i)
4496         if (iti.ne.10) then
4497           nbi=nbondterm(iti)
4498           if (nbi.eq.1) then
4499             diff=vbld(i+nres)-vbldsc0(1,iti)
4500 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4501 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4502             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4503             do j=1,3
4504               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4505             enddo
4506           else
4507             do j=1,nbi
4508               diff=vbld(i+nres)-vbldsc0(j,iti)
4509               ud(j)=aksc(j,iti)*diff
4510               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4511             enddo
4512             uprod=u(1)
4513             do j=2,nbi
4514               uprod=uprod*u(j)
4515             enddo
4516             usum=0.0d0
4517             usumsqder=0.0d0
4518             do j=1,nbi
4519               uprod1=1.0d0
4520               uprod2=1.0d0
4521               do k=1,nbi
4522                 if (k.ne.j) then
4523                   uprod1=uprod1*u(k)
4524                   uprod2=uprod2*u(k)*u(k)
4525                 endif
4526               enddo
4527               usum=usum+uprod1
4528               usumsqder=usumsqder+ud(j)*uprod2
4529             enddo
4530             estr=estr+uprod/usum
4531             do j=1,3
4532              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4533             enddo
4534           endif
4535         endif
4536       enddo
4537       return
4538       end
4539 #ifdef CRYST_THETA
4540 C--------------------------------------------------------------------------
4541       subroutine ebend(etheta)
4542 C
4543 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4544 C angles gamma and its derivatives in consecutive thetas and gammas.
4545 C
4546       implicit real*8 (a-h,o-z)
4547       include 'DIMENSIONS'
4548       include 'COMMON.LOCAL'
4549       include 'COMMON.GEO'
4550       include 'COMMON.INTERACT'
4551       include 'COMMON.DERIV'
4552       include 'COMMON.VAR'
4553       include 'COMMON.CHAIN'
4554       include 'COMMON.IOUNITS'
4555       include 'COMMON.NAMES'
4556       include 'COMMON.FFIELD'
4557       include 'COMMON.CONTROL'
4558       common /calcthet/ term1,term2,termm,diffak,ratak,
4559      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4560      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4561       double precision y(2),z(2)
4562       delta=0.02d0*pi
4563 c      time11=dexp(-2*time)
4564 c      time12=1.0d0
4565       etheta=0.0D0
4566 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4567       do i=ithet_start,ithet_end
4568 C Zero the energy function and its derivative at 0 or pi.
4569         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4570         it=itype(i-1)
4571         if (i.gt.3) then
4572 #ifdef OSF
4573           phii=phi(i)
4574           if (phii.ne.phii) phii=150.0
4575 #else
4576           phii=phi(i)
4577 #endif
4578           y(1)=dcos(phii)
4579           y(2)=dsin(phii)
4580         else
4581           y(1)=0.0D0
4582           y(2)=0.0D0
4583         endif
4584         if (i.lt.nres) then
4585 #ifdef OSF
4586           phii1=phi(i+1)
4587           if (phii1.ne.phii1) phii1=150.0
4588           phii1=pinorm(phii1)
4589           z(1)=cos(phii1)
4590 #else
4591           phii1=phi(i+1)
4592           z(1)=dcos(phii1)
4593 #endif
4594           z(2)=dsin(phii1)
4595         else
4596           z(1)=0.0D0
4597           z(2)=0.0D0
4598         endif
4599 C Calculate the "mean" value of theta from the part of the distribution
4600 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4601 C In following comments this theta will be referred to as t_c.
4602         thet_pred_mean=0.0d0
4603         do k=1,2
4604           athetk=athet(k,it)
4605           bthetk=bthet(k,it)
4606           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4607         enddo
4608         dthett=thet_pred_mean*ssd
4609         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4610 C Derivatives of the "mean" values in gamma1 and gamma2.
4611         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4612         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4613         if (theta(i).gt.pi-delta) then
4614           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4615      &         E_tc0)
4616           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4617           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4618           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4619      &        E_theta)
4620           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4621      &        E_tc)
4622         else if (theta(i).lt.delta) then
4623           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4624           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4625           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4626      &        E_theta)
4627           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4628           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4629      &        E_tc)
4630         else
4631           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4632      &        E_theta,E_tc)
4633         endif
4634         etheta=etheta+ethetai
4635         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4636      &      'ebend',i,ethetai
4637         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4638         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4639         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4640       enddo
4641 C Ufff.... We've done all this!!!
4642       return
4643       end
4644 C---------------------------------------------------------------------------
4645       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4646      &     E_tc)
4647       implicit real*8 (a-h,o-z)
4648       include 'DIMENSIONS'
4649       include 'COMMON.LOCAL'
4650       include 'COMMON.IOUNITS'
4651       common /calcthet/ term1,term2,termm,diffak,ratak,
4652      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4653      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4654 C Calculate the contributions to both Gaussian lobes.
4655 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4656 C The "polynomial part" of the "standard deviation" of this part of
4657 C the distribution.
4658         sig=polthet(3,it)
4659         do j=2,0,-1
4660           sig=sig*thet_pred_mean+polthet(j,it)
4661         enddo
4662 C Derivative of the "interior part" of the "standard deviation of the"
4663 C gamma-dependent Gaussian lobe in t_c.
4664         sigtc=3*polthet(3,it)
4665         do j=2,1,-1
4666           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4667         enddo
4668         sigtc=sig*sigtc
4669 C Set the parameters of both Gaussian lobes of the distribution.
4670 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4671         fac=sig*sig+sigc0(it)
4672         sigcsq=fac+fac
4673         sigc=1.0D0/sigcsq
4674 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4675         sigsqtc=-4.0D0*sigcsq*sigtc
4676 c       print *,i,sig,sigtc,sigsqtc
4677 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4678         sigtc=-sigtc/(fac*fac)
4679 C Following variable is sigma(t_c)**(-2)
4680         sigcsq=sigcsq*sigcsq
4681         sig0i=sig0(it)
4682         sig0inv=1.0D0/sig0i**2
4683         delthec=thetai-thet_pred_mean
4684         delthe0=thetai-theta0i
4685         term1=-0.5D0*sigcsq*delthec*delthec
4686         term2=-0.5D0*sig0inv*delthe0*delthe0
4687 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4688 C NaNs in taking the logarithm. We extract the largest exponent which is added
4689 C to the energy (this being the log of the distribution) at the end of energy
4690 C term evaluation for this virtual-bond angle.
4691         if (term1.gt.term2) then
4692           termm=term1
4693           term2=dexp(term2-termm)
4694           term1=1.0d0
4695         else
4696           termm=term2
4697           term1=dexp(term1-termm)
4698           term2=1.0d0
4699         endif
4700 C The ratio between the gamma-independent and gamma-dependent lobes of
4701 C the distribution is a Gaussian function of thet_pred_mean too.
4702         diffak=gthet(2,it)-thet_pred_mean
4703         ratak=diffak/gthet(3,it)**2
4704         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4705 C Let's differentiate it in thet_pred_mean NOW.
4706         aktc=ak*ratak
4707 C Now put together the distribution terms to make complete distribution.
4708         termexp=term1+ak*term2
4709         termpre=sigc+ak*sig0i
4710 C Contribution of the bending energy from this theta is just the -log of
4711 C the sum of the contributions from the two lobes and the pre-exponential
4712 C factor. Simple enough, isn't it?
4713         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4714 C NOW the derivatives!!!
4715 C 6/6/97 Take into account the deformation.
4716         E_theta=(delthec*sigcsq*term1
4717      &       +ak*delthe0*sig0inv*term2)/termexp
4718         E_tc=((sigtc+aktc*sig0i)/termpre
4719      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4720      &       aktc*term2)/termexp)
4721       return
4722       end
4723 c-----------------------------------------------------------------------------
4724       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4725       implicit real*8 (a-h,o-z)
4726       include 'DIMENSIONS'
4727       include 'COMMON.LOCAL'
4728       include 'COMMON.IOUNITS'
4729       common /calcthet/ term1,term2,termm,diffak,ratak,
4730      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4731      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4732       delthec=thetai-thet_pred_mean
4733       delthe0=thetai-theta0i
4734 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4735       t3 = thetai-thet_pred_mean
4736       t6 = t3**2
4737       t9 = term1
4738       t12 = t3*sigcsq
4739       t14 = t12+t6*sigsqtc
4740       t16 = 1.0d0
4741       t21 = thetai-theta0i
4742       t23 = t21**2
4743       t26 = term2
4744       t27 = t21*t26
4745       t32 = termexp
4746       t40 = t32**2
4747       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4748      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4749      & *(-t12*t9-ak*sig0inv*t27)
4750       return
4751       end
4752 #else
4753 C--------------------------------------------------------------------------
4754       subroutine ebend(etheta)
4755 C
4756 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4757 C angles gamma and its derivatives in consecutive thetas and gammas.
4758 C ab initio-derived potentials from
4759 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4760 C
4761       implicit real*8 (a-h,o-z)
4762       include 'DIMENSIONS'
4763       include 'COMMON.LOCAL'
4764       include 'COMMON.GEO'
4765       include 'COMMON.INTERACT'
4766       include 'COMMON.DERIV'
4767       include 'COMMON.VAR'
4768       include 'COMMON.CHAIN'
4769       include 'COMMON.IOUNITS'
4770       include 'COMMON.NAMES'
4771       include 'COMMON.FFIELD'
4772       include 'COMMON.CONTROL'
4773       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4774      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4775      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4776      & sinph1ph2(maxdouble,maxdouble)
4777       logical lprn /.false./, lprn1 /.false./
4778       etheta=0.0D0
4779       do i=ithet_start,ithet_end
4780         dethetai=0.0d0
4781         dephii=0.0d0
4782         dephii1=0.0d0
4783         theti2=0.5d0*theta(i)
4784         ityp2=ithetyp(itype(i-1))
4785         do k=1,nntheterm
4786           coskt(k)=dcos(k*theti2)
4787           sinkt(k)=dsin(k*theti2)
4788         enddo
4789         if (i.gt.3) then
4790 #ifdef OSF
4791           phii=phi(i)
4792           if (phii.ne.phii) phii=150.0
4793 #else
4794           phii=phi(i)
4795 #endif
4796           ityp1=ithetyp(itype(i-2))
4797           do k=1,nsingle
4798             cosph1(k)=dcos(k*phii)
4799             sinph1(k)=dsin(k*phii)
4800           enddo
4801         else
4802           phii=0.0d0
4803           ityp1=nthetyp+1
4804           do k=1,nsingle
4805             cosph1(k)=0.0d0
4806             sinph1(k)=0.0d0
4807           enddo
4808         endif
4809         if (i.lt.nres) then
4810 #ifdef OSF
4811           phii1=phi(i+1)
4812           if (phii1.ne.phii1) phii1=150.0
4813           phii1=pinorm(phii1)
4814 #else
4815           phii1=phi(i+1)
4816 #endif
4817           ityp3=ithetyp(itype(i))
4818           do k=1,nsingle
4819             cosph2(k)=dcos(k*phii1)
4820             sinph2(k)=dsin(k*phii1)
4821           enddo
4822         else
4823           phii1=0.0d0
4824           ityp3=nthetyp+1
4825           do k=1,nsingle
4826             cosph2(k)=0.0d0
4827             sinph2(k)=0.0d0
4828           enddo
4829         endif
4830         ethetai=aa0thet(ityp1,ityp2,ityp3)
4831         do k=1,ndouble
4832           do l=1,k-1
4833             ccl=cosph1(l)*cosph2(k-l)
4834             ssl=sinph1(l)*sinph2(k-l)
4835             scl=sinph1(l)*cosph2(k-l)
4836             csl=cosph1(l)*sinph2(k-l)
4837             cosph1ph2(l,k)=ccl-ssl
4838             cosph1ph2(k,l)=ccl+ssl
4839             sinph1ph2(l,k)=scl+csl
4840             sinph1ph2(k,l)=scl-csl
4841           enddo
4842         enddo
4843         if (lprn) then
4844         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4845      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4846         write (iout,*) "coskt and sinkt"
4847         do k=1,nntheterm
4848           write (iout,*) k,coskt(k),sinkt(k)
4849         enddo
4850         endif
4851         do k=1,ntheterm
4852           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4853           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4854      &      *coskt(k)
4855           if (lprn)
4856      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4857      &     " ethetai",ethetai
4858         enddo
4859         if (lprn) then
4860         write (iout,*) "cosph and sinph"
4861         do k=1,nsingle
4862           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4863         enddo
4864         write (iout,*) "cosph1ph2 and sinph2ph2"
4865         do k=2,ndouble
4866           do l=1,k-1
4867             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4868      &         sinph1ph2(l,k),sinph1ph2(k,l)
4869           enddo
4870         enddo
4871         write(iout,*) "ethetai",ethetai
4872         endif
4873         do m=1,ntheterm2
4874           do k=1,nsingle
4875             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4876      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4877      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4878      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4879             ethetai=ethetai+sinkt(m)*aux
4880             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4881             dephii=dephii+k*sinkt(m)*(
4882      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4883      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4884             dephii1=dephii1+k*sinkt(m)*(
4885      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4886      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4887             if (lprn)
4888      &      write (iout,*) "m",m," k",k," bbthet",
4889      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4890      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4891      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4892      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4893           enddo
4894         enddo
4895         if (lprn)
4896      &  write(iout,*) "ethetai",ethetai
4897         do m=1,ntheterm3
4898           do k=2,ndouble
4899             do l=1,k-1
4900               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4901      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4902      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4903      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4904               ethetai=ethetai+sinkt(m)*aux
4905               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4906               dephii=dephii+l*sinkt(m)*(
4907      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4908      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4909      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4910      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4911               dephii1=dephii1+(k-l)*sinkt(m)*(
4912      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4913      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4914      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4915      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4916               if (lprn) then
4917               write (iout,*) "m",m," k",k," l",l," ffthet",
4918      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4919      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4920      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4921      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4922               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4923      &            cosph1ph2(k,l)*sinkt(m),
4924      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4925               endif
4926             enddo
4927           enddo
4928         enddo
4929 10      continue
4930         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4931      &   i,theta(i)*rad2deg,phii*rad2deg,
4932      &   phii1*rad2deg,ethetai
4933         etheta=etheta+ethetai
4934         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4935         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4936         gloc(nphi+i-2,icg)=wang*dethetai
4937       enddo
4938       return
4939       end
4940 #endif
4941 #ifdef CRYST_SC
4942 c-----------------------------------------------------------------------------
4943       subroutine esc(escloc)
4944 C Calculate the local energy of a side chain and its derivatives in the
4945 C corresponding virtual-bond valence angles THETA and the spherical angles
4946 C ALPHA and OMEGA.
4947       implicit real*8 (a-h,o-z)
4948       include 'DIMENSIONS'
4949       include 'COMMON.GEO'
4950       include 'COMMON.LOCAL'
4951       include 'COMMON.VAR'
4952       include 'COMMON.INTERACT'
4953       include 'COMMON.DERIV'
4954       include 'COMMON.CHAIN'
4955       include 'COMMON.IOUNITS'
4956       include 'COMMON.NAMES'
4957       include 'COMMON.FFIELD'
4958       include 'COMMON.CONTROL'
4959       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4960      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4961       common /sccalc/ time11,time12,time112,theti,it,nlobit
4962       delta=0.02d0*pi
4963       escloc=0.0D0
4964 c     write (iout,'(a)') 'ESC'
4965       do i=loc_start,loc_end
4966         it=itype(i)
4967         if (it.eq.10) goto 1
4968         nlobit=nlob(it)
4969 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4970 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4971         theti=theta(i+1)-pipol
4972         x(1)=dtan(theti)
4973         x(2)=alph(i)
4974         x(3)=omeg(i)
4975
4976         if (x(2).gt.pi-delta) then
4977           xtemp(1)=x(1)
4978           xtemp(2)=pi-delta
4979           xtemp(3)=x(3)
4980           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4981           xtemp(2)=pi
4982           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4983           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4984      &        escloci,dersc(2))
4985           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4986      &        ddersc0(1),dersc(1))
4987           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4988      &        ddersc0(3),dersc(3))
4989           xtemp(2)=pi-delta
4990           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4991           xtemp(2)=pi
4992           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4993           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4994      &            dersc0(2),esclocbi,dersc02)
4995           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4996      &            dersc12,dersc01)
4997           call splinthet(x(2),0.5d0*delta,ss,ssd)
4998           dersc0(1)=dersc01
4999           dersc0(2)=dersc02
5000           dersc0(3)=0.0d0
5001           do k=1,3
5002             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5003           enddo
5004           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5005 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5006 c    &             esclocbi,ss,ssd
5007           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5008 c         escloci=esclocbi
5009 c         write (iout,*) escloci
5010         else if (x(2).lt.delta) then
5011           xtemp(1)=x(1)
5012           xtemp(2)=delta
5013           xtemp(3)=x(3)
5014           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5015           xtemp(2)=0.0d0
5016           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5017           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5018      &        escloci,dersc(2))
5019           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5020      &        ddersc0(1),dersc(1))
5021           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5022      &        ddersc0(3),dersc(3))
5023           xtemp(2)=delta
5024           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5025           xtemp(2)=0.0d0
5026           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5027           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5028      &            dersc0(2),esclocbi,dersc02)
5029           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5030      &            dersc12,dersc01)
5031           dersc0(1)=dersc01
5032           dersc0(2)=dersc02
5033           dersc0(3)=0.0d0
5034           call splinthet(x(2),0.5d0*delta,ss,ssd)
5035           do k=1,3
5036             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5037           enddo
5038           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5039 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5040 c    &             esclocbi,ss,ssd
5041           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5042 c         write (iout,*) escloci
5043         else
5044           call enesc(x,escloci,dersc,ddummy,.false.)
5045         endif
5046
5047         escloc=escloc+escloci
5048         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5049      &     'escloc',i,escloci
5050 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5051
5052         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5053      &   wscloc*dersc(1)
5054         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5055         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5056     1   continue
5057       enddo
5058       return
5059       end
5060 C---------------------------------------------------------------------------
5061       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5062       implicit real*8 (a-h,o-z)
5063       include 'DIMENSIONS'
5064       include 'COMMON.GEO'
5065       include 'COMMON.LOCAL'
5066       include 'COMMON.IOUNITS'
5067       common /sccalc/ time11,time12,time112,theti,it,nlobit
5068       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5069       double precision contr(maxlob,-1:1)
5070       logical mixed
5071 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5072         escloc_i=0.0D0
5073         do j=1,3
5074           dersc(j)=0.0D0
5075           if (mixed) ddersc(j)=0.0d0
5076         enddo
5077         x3=x(3)
5078
5079 C Because of periodicity of the dependence of the SC energy in omega we have
5080 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5081 C To avoid underflows, first compute & store the exponents.
5082
5083         do iii=-1,1
5084
5085           x(3)=x3+iii*dwapi
5086
5087           do j=1,nlobit
5088             do k=1,3
5089               z(k)=x(k)-censc(k,j,it)
5090             enddo
5091             do k=1,3
5092               Axk=0.0D0
5093               do l=1,3
5094                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5095               enddo
5096               Ax(k,j,iii)=Axk
5097             enddo
5098             expfac=0.0D0
5099             do k=1,3
5100               expfac=expfac+Ax(k,j,iii)*z(k)
5101             enddo
5102             contr(j,iii)=expfac
5103           enddo ! j
5104
5105         enddo ! iii
5106
5107         x(3)=x3
5108 C As in the case of ebend, we want to avoid underflows in exponentiation and
5109 C subsequent NaNs and INFs in energy calculation.
5110 C Find the largest exponent
5111         emin=contr(1,-1)
5112         do iii=-1,1
5113           do j=1,nlobit
5114             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5115           enddo
5116         enddo
5117         emin=0.5D0*emin
5118 cd      print *,'it=',it,' emin=',emin
5119
5120 C Compute the contribution to SC energy and derivatives
5121         do iii=-1,1
5122
5123           do j=1,nlobit
5124 #ifdef OSF
5125             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5126             if(adexp.ne.adexp) adexp=1.0
5127             expfac=dexp(adexp)
5128 #else
5129             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5130 #endif
5131 cd          print *,'j=',j,' expfac=',expfac
5132             escloc_i=escloc_i+expfac
5133             do k=1,3
5134               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5135             enddo
5136             if (mixed) then
5137               do k=1,3,2
5138                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5139      &            +gaussc(k,2,j,it))*expfac
5140               enddo
5141             endif
5142           enddo
5143
5144         enddo ! iii
5145
5146         dersc(1)=dersc(1)/cos(theti)**2
5147         ddersc(1)=ddersc(1)/cos(theti)**2
5148         ddersc(3)=ddersc(3)
5149
5150         escloci=-(dlog(escloc_i)-emin)
5151         do j=1,3
5152           dersc(j)=dersc(j)/escloc_i
5153         enddo
5154         if (mixed) then
5155           do j=1,3,2
5156             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5157           enddo
5158         endif
5159       return
5160       end
5161 C------------------------------------------------------------------------------
5162       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5163       implicit real*8 (a-h,o-z)
5164       include 'DIMENSIONS'
5165       include 'COMMON.GEO'
5166       include 'COMMON.LOCAL'
5167       include 'COMMON.IOUNITS'
5168       common /sccalc/ time11,time12,time112,theti,it,nlobit
5169       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5170       double precision contr(maxlob)
5171       logical mixed
5172
5173       escloc_i=0.0D0
5174
5175       do j=1,3
5176         dersc(j)=0.0D0
5177       enddo
5178
5179       do j=1,nlobit
5180         do k=1,2
5181           z(k)=x(k)-censc(k,j,it)
5182         enddo
5183         z(3)=dwapi
5184         do k=1,3
5185           Axk=0.0D0
5186           do l=1,3
5187             Axk=Axk+gaussc(l,k,j,it)*z(l)
5188           enddo
5189           Ax(k,j)=Axk
5190         enddo
5191         expfac=0.0D0
5192         do k=1,3
5193           expfac=expfac+Ax(k,j)*z(k)
5194         enddo
5195         contr(j)=expfac
5196       enddo ! j
5197
5198 C As in the case of ebend, we want to avoid underflows in exponentiation and
5199 C subsequent NaNs and INFs in energy calculation.
5200 C Find the largest exponent
5201       emin=contr(1)
5202       do j=1,nlobit
5203         if (emin.gt.contr(j)) emin=contr(j)
5204       enddo
5205       emin=0.5D0*emin
5206
5207 C Compute the contribution to SC energy and derivatives
5208
5209       dersc12=0.0d0
5210       do j=1,nlobit
5211         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5212         escloc_i=escloc_i+expfac
5213         do k=1,2
5214           dersc(k)=dersc(k)+Ax(k,j)*expfac
5215         enddo
5216         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5217      &            +gaussc(1,2,j,it))*expfac
5218         dersc(3)=0.0d0
5219       enddo
5220
5221       dersc(1)=dersc(1)/cos(theti)**2
5222       dersc12=dersc12/cos(theti)**2
5223       escloci=-(dlog(escloc_i)-emin)
5224       do j=1,2
5225         dersc(j)=dersc(j)/escloc_i
5226       enddo
5227       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5228       return
5229       end
5230 #else
5231 c----------------------------------------------------------------------------------
5232       subroutine esc(escloc)
5233 C Calculate the local energy of a side chain and its derivatives in the
5234 C corresponding virtual-bond valence angles THETA and the spherical angles
5235 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5236 C added by Urszula Kozlowska. 07/11/2007
5237 C
5238       implicit real*8 (a-h,o-z)
5239       include 'DIMENSIONS'
5240       include 'COMMON.GEO'
5241       include 'COMMON.LOCAL'
5242       include 'COMMON.VAR'
5243       include 'COMMON.SCROT'
5244       include 'COMMON.INTERACT'
5245       include 'COMMON.DERIV'
5246       include 'COMMON.CHAIN'
5247       include 'COMMON.IOUNITS'
5248       include 'COMMON.NAMES'
5249       include 'COMMON.FFIELD'
5250       include 'COMMON.CONTROL'
5251       include 'COMMON.VECTORS'
5252       double precision x_prime(3),y_prime(3),z_prime(3)
5253      &    , sumene,dsc_i,dp2_i,x(65),
5254      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5255      &    de_dxx,de_dyy,de_dzz,de_dt
5256       double precision s1_t,s1_6_t,s2_t,s2_6_t
5257       double precision
5258      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5259      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5260      & dt_dCi(3),dt_dCi1(3)
5261       common /sccalc/ time11,time12,time112,theti,it,nlobit
5262       delta=0.02d0*pi
5263       escloc=0.0D0
5264       do i=loc_start,loc_end
5265         costtab(i+1) =dcos(theta(i+1))
5266         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5267         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5268         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5269         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5270         cosfac=dsqrt(cosfac2)
5271         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5272         sinfac=dsqrt(sinfac2)
5273         it=itype(i)
5274         if (it.eq.10) goto 1
5275 c
5276 C  Compute the axes of tghe local cartesian coordinates system; store in
5277 c   x_prime, y_prime and z_prime
5278 c
5279         do j=1,3
5280           x_prime(j) = 0.00
5281           y_prime(j) = 0.00
5282           z_prime(j) = 0.00
5283         enddo
5284 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5285 C     &   dc_norm(3,i+nres)
5286         do j = 1,3
5287           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5288           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5289         enddo
5290         do j = 1,3
5291           z_prime(j) = -uz(j,i-1)
5292         enddo
5293 c       write (2,*) "i",i
5294 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5295 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5296 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5297 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5298 c      & " xy",scalar(x_prime(1),y_prime(1)),
5299 c      & " xz",scalar(x_prime(1),z_prime(1)),
5300 c      & " yy",scalar(y_prime(1),y_prime(1)),
5301 c      & " yz",scalar(y_prime(1),z_prime(1)),
5302 c      & " zz",scalar(z_prime(1),z_prime(1))
5303 c
5304 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5305 C to local coordinate system. Store in xx, yy, zz.
5306 c
5307         xx=0.0d0
5308         yy=0.0d0
5309         zz=0.0d0
5310         do j = 1,3
5311           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5312           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5313           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5314         enddo
5315
5316         xxtab(i)=xx
5317         yytab(i)=yy
5318         zztab(i)=zz
5319 C
5320 C Compute the energy of the ith side cbain
5321 C
5322 c        write (2,*) "xx",xx," yy",yy," zz",zz
5323         it=itype(i)
5324         do j = 1,65
5325           x(j) = sc_parmin(j,it)
5326         enddo
5327 #ifdef CHECK_COORD
5328 Cc diagnostics - remove later
5329         xx1 = dcos(alph(2))
5330         yy1 = dsin(alph(2))*dcos(omeg(2))
5331         zz1 = -dsin(alph(2))*dsin(omeg(2))
5332         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5333      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5334      &    xx1,yy1,zz1
5335 C,"  --- ", xx_w,yy_w,zz_w
5336 c end diagnostics
5337 #endif
5338         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5339      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5340      &   + x(10)*yy*zz
5341         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5342      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5343      & + x(20)*yy*zz
5344         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5345      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5346      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5347      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5348      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5349      &  +x(40)*xx*yy*zz
5350         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5351      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5352      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5353      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5354      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5355      &  +x(60)*xx*yy*zz
5356         dsc_i   = 0.743d0+x(61)
5357         dp2_i   = 1.9d0+x(62)
5358         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5359      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5360         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5361      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5362         s1=(1+x(63))/(0.1d0 + dscp1)
5363         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5364         s2=(1+x(65))/(0.1d0 + dscp2)
5365         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5366         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5367      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5368 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5369 c     &   sumene4,
5370 c     &   dscp1,dscp2,sumene
5371 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5372         escloc = escloc + sumene
5373 c        write (2,*) "i",i," escloc",sumene,escloc
5374 #ifdef DEBUG
5375 C
5376 C This section to check the numerical derivatives of the energy of ith side
5377 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5378 C #define DEBUG in the code to turn it on.
5379 C
5380         write (2,*) "sumene               =",sumene
5381         aincr=1.0d-7
5382         xxsave=xx
5383         xx=xx+aincr
5384         write (2,*) xx,yy,zz
5385         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5386         de_dxx_num=(sumenep-sumene)/aincr
5387         xx=xxsave
5388         write (2,*) "xx+ sumene from enesc=",sumenep
5389         yysave=yy
5390         yy=yy+aincr
5391         write (2,*) xx,yy,zz
5392         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5393         de_dyy_num=(sumenep-sumene)/aincr
5394         yy=yysave
5395         write (2,*) "yy+ sumene from enesc=",sumenep
5396         zzsave=zz
5397         zz=zz+aincr
5398         write (2,*) xx,yy,zz
5399         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5400         de_dzz_num=(sumenep-sumene)/aincr
5401         zz=zzsave
5402         write (2,*) "zz+ sumene from enesc=",sumenep
5403         costsave=cost2tab(i+1)
5404         sintsave=sint2tab(i+1)
5405         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5406         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5407         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5408         de_dt_num=(sumenep-sumene)/aincr
5409         write (2,*) " t+ sumene from enesc=",sumenep
5410         cost2tab(i+1)=costsave
5411         sint2tab(i+1)=sintsave
5412 C End of diagnostics section.
5413 #endif
5414 C
5415 C Compute the gradient of esc
5416 C
5417         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5418         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5419         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5420         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5421         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5422         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5423         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5424         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5425         pom1=(sumene3*sint2tab(i+1)+sumene1)
5426      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5427         pom2=(sumene4*cost2tab(i+1)+sumene2)
5428      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5429         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5430         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5431      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5432      &  +x(40)*yy*zz
5433         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5434         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5435      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5436      &  +x(60)*yy*zz
5437         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5438      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5439      &        +(pom1+pom2)*pom_dx
5440 #ifdef DEBUG
5441         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5442 #endif
5443 C
5444         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5445         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5446      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5447      &  +x(40)*xx*zz
5448         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5449         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5450      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5451      &  +x(59)*zz**2 +x(60)*xx*zz
5452         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5453      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5454      &        +(pom1-pom2)*pom_dy
5455 #ifdef DEBUG
5456         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5457 #endif
5458 C
5459         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5460      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5461      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5462      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5463      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5464      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5465      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5466      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5467 #ifdef DEBUG
5468         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5469 #endif
5470 C
5471         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5472      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5473      &  +pom1*pom_dt1+pom2*pom_dt2
5474 #ifdef DEBUG
5475         write(2,*), "de_dt = ", de_dt,de_dt_num
5476 #endif
5477 c
5478 C
5479        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5480        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5481        cosfac2xx=cosfac2*xx
5482        sinfac2yy=sinfac2*yy
5483        do k = 1,3
5484          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5485      &      vbld_inv(i+1)
5486          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5487      &      vbld_inv(i)
5488          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5489          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5490 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5491 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5492 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5493 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5494          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5495          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5496          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5497          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5498          dZZ_Ci1(k)=0.0d0
5499          dZZ_Ci(k)=0.0d0
5500          do j=1,3
5501            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5502            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5503          enddo
5504
5505          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5506          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5507          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5508 c
5509          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5510          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5511        enddo
5512
5513        do k=1,3
5514          dXX_Ctab(k,i)=dXX_Ci(k)
5515          dXX_C1tab(k,i)=dXX_Ci1(k)
5516          dYY_Ctab(k,i)=dYY_Ci(k)
5517          dYY_C1tab(k,i)=dYY_Ci1(k)
5518          dZZ_Ctab(k,i)=dZZ_Ci(k)
5519          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5520          dXX_XYZtab(k,i)=dXX_XYZ(k)
5521          dYY_XYZtab(k,i)=dYY_XYZ(k)
5522          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5523        enddo
5524
5525        do k = 1,3
5526 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5527 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5528 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5529 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5530 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5531 c     &    dt_dci(k)
5532 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5533 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5534          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5535      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5536          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5537      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5538          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5539      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5540        enddo
5541 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5542 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5543
5544 C to check gradient call subroutine check_grad
5545
5546     1 continue
5547       enddo
5548       return
5549       end
5550 c------------------------------------------------------------------------------
5551       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5552       implicit none
5553       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5554      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5555       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5556      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5557      &   + x(10)*yy*zz
5558       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5559      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5560      & + x(20)*yy*zz
5561       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5562      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5563      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5564      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5565      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5566      &  +x(40)*xx*yy*zz
5567       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5568      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5569      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5570      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5571      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5572      &  +x(60)*xx*yy*zz
5573       dsc_i   = 0.743d0+x(61)
5574       dp2_i   = 1.9d0+x(62)
5575       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5576      &          *(xx*cost2+yy*sint2))
5577       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5578      &          *(xx*cost2-yy*sint2))
5579       s1=(1+x(63))/(0.1d0 + dscp1)
5580       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5581       s2=(1+x(65))/(0.1d0 + dscp2)
5582       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5583       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5584      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5585       enesc=sumene
5586       return
5587       end
5588 #endif
5589 c------------------------------------------------------------------------------
5590       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5591 C
5592 C This procedure calculates two-body contact function g(rij) and its derivative:
5593 C
5594 C           eps0ij                                     !       x < -1
5595 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5596 C            0                                         !       x > 1
5597 C
5598 C where x=(rij-r0ij)/delta
5599 C
5600 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5601 C
5602       implicit none
5603       double precision rij,r0ij,eps0ij,fcont,fprimcont
5604       double precision x,x2,x4,delta
5605 c     delta=0.02D0*r0ij
5606 c      delta=0.2D0*r0ij
5607       x=(rij-r0ij)/delta
5608       if (x.lt.-1.0D0) then
5609         fcont=eps0ij
5610         fprimcont=0.0D0
5611       else if (x.le.1.0D0) then
5612         x2=x*x
5613         x4=x2*x2
5614         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5615         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5616       else
5617         fcont=0.0D0
5618         fprimcont=0.0D0
5619       endif
5620       return
5621       end
5622 c------------------------------------------------------------------------------
5623       subroutine splinthet(theti,delta,ss,ssder)
5624       implicit real*8 (a-h,o-z)
5625       include 'DIMENSIONS'
5626       include 'COMMON.VAR'
5627       include 'COMMON.GEO'
5628       thetup=pi-delta
5629       thetlow=delta
5630       if (theti.gt.pipol) then
5631         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5632       else
5633         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5634         ssder=-ssder
5635       endif
5636       return
5637       end
5638 c------------------------------------------------------------------------------
5639       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5640       implicit none
5641       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5642       double precision ksi,ksi2,ksi3,a1,a2,a3
5643       a1=fprim0*delta/(f1-f0)
5644       a2=3.0d0-2.0d0*a1
5645       a3=a1-2.0d0
5646       ksi=(x-x0)/delta
5647       ksi2=ksi*ksi
5648       ksi3=ksi2*ksi
5649       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5650       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5651       return
5652       end
5653 c------------------------------------------------------------------------------
5654       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5655       implicit none
5656       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5657       double precision ksi,ksi2,ksi3,a1,a2,a3
5658       ksi=(x-x0)/delta
5659       ksi2=ksi*ksi
5660       ksi3=ksi2*ksi
5661       a1=fprim0x*delta
5662       a2=3*(f1x-f0x)-2*fprim0x*delta
5663       a3=fprim0x*delta-2*(f1x-f0x)
5664       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5665       return
5666       end
5667 C-----------------------------------------------------------------------------
5668 #ifdef CRYST_TOR
5669 C-----------------------------------------------------------------------------
5670       subroutine etor(etors,edihcnstr)
5671       implicit real*8 (a-h,o-z)
5672       include 'DIMENSIONS'
5673       include 'COMMON.VAR'
5674       include 'COMMON.GEO'
5675       include 'COMMON.LOCAL'
5676       include 'COMMON.TORSION'
5677       include 'COMMON.INTERACT'
5678       include 'COMMON.DERIV'
5679       include 'COMMON.CHAIN'
5680       include 'COMMON.NAMES'
5681       include 'COMMON.IOUNITS'
5682       include 'COMMON.FFIELD'
5683       include 'COMMON.TORCNSTR'
5684       include 'COMMON.CONTROL'
5685       logical lprn
5686 C Set lprn=.true. for debugging
5687       lprn=.false.
5688 c      lprn=.true.
5689       etors=0.0D0
5690       do i=iphi_start,iphi_end
5691       etors_ii=0.0D0
5692         itori=itortyp(itype(i-2))
5693         itori1=itortyp(itype(i-1))
5694         phii=phi(i)
5695         gloci=0.0D0
5696 C Proline-Proline pair is a special case...
5697         if (itori.eq.3 .and. itori1.eq.3) then
5698           if (phii.gt.-dwapi3) then
5699             cosphi=dcos(3*phii)
5700             fac=1.0D0/(1.0D0-cosphi)
5701             etorsi=v1(1,3,3)*fac
5702             etorsi=etorsi+etorsi
5703             etors=etors+etorsi-v1(1,3,3)
5704             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5705             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5706           endif
5707           do j=1,3
5708             v1ij=v1(j+1,itori,itori1)
5709             v2ij=v2(j+1,itori,itori1)
5710             cosphi=dcos(j*phii)
5711             sinphi=dsin(j*phii)
5712             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5713             if (energy_dec) etors_ii=etors_ii+
5714      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5715             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5716           enddo
5717         else
5718           do j=1,nterm_old
5719             v1ij=v1(j,itori,itori1)
5720             v2ij=v2(j,itori,itori1)
5721             cosphi=dcos(j*phii)
5722             sinphi=dsin(j*phii)
5723             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5724             if (energy_dec) etors_ii=etors_ii+
5725      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5726             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5727           enddo
5728         endif
5729         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5730      &        'etor',i,etors_ii
5731         if (lprn)
5732      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5733      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5734      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5735         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5736         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5737       enddo
5738 ! 6/20/98 - dihedral angle constraints
5739       edihcnstr=0.0d0
5740       do i=1,ndih_constr
5741         itori=idih_constr(i)
5742         phii=phi(itori)
5743         difi=phii-phi0(i)
5744         if (difi.gt.drange(i)) then
5745           difi=difi-drange(i)
5746           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5747           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5748         else if (difi.lt.-drange(i)) then
5749           difi=difi+drange(i)
5750           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5751           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5752         endif
5753 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5754 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5755       enddo
5756 !      write (iout,*) 'edihcnstr',edihcnstr
5757       return
5758       end
5759 c------------------------------------------------------------------------------
5760       subroutine etor_d(etors_d)
5761       etors_d=0.0d0
5762       return
5763       end
5764 c----------------------------------------------------------------------------
5765 #else
5766       subroutine etor(etors,edihcnstr)
5767       implicit real*8 (a-h,o-z)
5768       include 'DIMENSIONS'
5769       include 'COMMON.VAR'
5770       include 'COMMON.GEO'
5771       include 'COMMON.LOCAL'
5772       include 'COMMON.TORSION'
5773       include 'COMMON.INTERACT'
5774       include 'COMMON.DERIV'
5775       include 'COMMON.CHAIN'
5776       include 'COMMON.NAMES'
5777       include 'COMMON.IOUNITS'
5778       include 'COMMON.FFIELD'
5779       include 'COMMON.TORCNSTR'
5780       include 'COMMON.CONTROL'
5781       logical lprn
5782 C Set lprn=.true. for debugging
5783       lprn=.false.
5784 c     lprn=.true.
5785       etors=0.0D0
5786       do i=iphi_start,iphi_end
5787       etors_ii=0.0D0
5788         itori=itortyp(itype(i-2))
5789         itori1=itortyp(itype(i-1))
5790         phii=phi(i)
5791         gloci=0.0D0
5792 C Regular cosine and sine terms
5793         do j=1,nterm(itori,itori1)
5794           v1ij=v1(j,itori,itori1)
5795           v2ij=v2(j,itori,itori1)
5796           cosphi=dcos(j*phii)
5797           sinphi=dsin(j*phii)
5798           etors=etors+v1ij*cosphi+v2ij*sinphi
5799           if (energy_dec) etors_ii=etors_ii+
5800      &                v1ij*cosphi+v2ij*sinphi
5801           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5802         enddo
5803 C Lorentz terms
5804 C                         v1
5805 C  E = SUM ----------------------------------- - v1
5806 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5807 C
5808         cosphi=dcos(0.5d0*phii)
5809         sinphi=dsin(0.5d0*phii)
5810         do j=1,nlor(itori,itori1)
5811           vl1ij=vlor1(j,itori,itori1)
5812           vl2ij=vlor2(j,itori,itori1)
5813           vl3ij=vlor3(j,itori,itori1)
5814           pom=vl2ij*cosphi+vl3ij*sinphi
5815           pom1=1.0d0/(pom*pom+1.0d0)
5816           etors=etors+vl1ij*pom1
5817           if (energy_dec) etors_ii=etors_ii+
5818      &                vl1ij*pom1
5819           pom=-pom*pom1*pom1
5820           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5821         enddo
5822 C Subtract the constant term
5823         etors=etors-v0(itori,itori1)
5824           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5825      &         'etor',i,etors_ii-v0(itori,itori1)
5826         if (lprn)
5827      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5828      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5829      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5830         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5831 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5832       enddo
5833 ! 6/20/98 - dihedral angle constraints
5834       edihcnstr=0.0d0
5835 c      do i=1,ndih_constr
5836       do i=idihconstr_start,idihconstr_end
5837         itori=idih_constr(i)
5838         phii=phi(itori)
5839         difi=pinorm(phii-phi0(i))
5840         if (difi.gt.drange(i)) then
5841           difi=difi-drange(i)
5842           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5843           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5844         else if (difi.lt.-drange(i)) then
5845           difi=difi+drange(i)
5846           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5847           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5848         else
5849           difi=0.0
5850         endif
5851 c        write (iout,*) "gloci", gloc(i-3,icg)
5852 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5853 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5854 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5855       enddo
5856 cd       write (iout,*) 'edihcnstr',edihcnstr
5857       return
5858       end
5859 c----------------------------------------------------------------------------
5860       subroutine etor_d(etors_d)
5861 C 6/23/01 Compute double torsional energy
5862       implicit real*8 (a-h,o-z)
5863       include 'DIMENSIONS'
5864       include 'COMMON.VAR'
5865       include 'COMMON.GEO'
5866       include 'COMMON.LOCAL'
5867       include 'COMMON.TORSION'
5868       include 'COMMON.INTERACT'
5869       include 'COMMON.DERIV'
5870       include 'COMMON.CHAIN'
5871       include 'COMMON.NAMES'
5872       include 'COMMON.IOUNITS'
5873       include 'COMMON.FFIELD'
5874       include 'COMMON.TORCNSTR'
5875       logical lprn
5876 C Set lprn=.true. for debugging
5877       lprn=.false.
5878 c     lprn=.true.
5879       etors_d=0.0D0
5880       do i=iphid_start,iphid_end
5881         itori=itortyp(itype(i-2))
5882         itori1=itortyp(itype(i-1))
5883         itori2=itortyp(itype(i))
5884         phii=phi(i)
5885         phii1=phi(i+1)
5886         gloci1=0.0D0
5887         gloci2=0.0D0
5888         do j=1,ntermd_1(itori,itori1,itori2)
5889           v1cij=v1c(1,j,itori,itori1,itori2)
5890           v1sij=v1s(1,j,itori,itori1,itori2)
5891           v2cij=v1c(2,j,itori,itori1,itori2)
5892           v2sij=v1s(2,j,itori,itori1,itori2)
5893           cosphi1=dcos(j*phii)
5894           sinphi1=dsin(j*phii)
5895           cosphi2=dcos(j*phii1)
5896           sinphi2=dsin(j*phii1)
5897           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5898      &     v2cij*cosphi2+v2sij*sinphi2
5899           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5900           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5901         enddo
5902         do k=2,ntermd_2(itori,itori1,itori2)
5903           do l=1,k-1
5904             v1cdij = v2c(k,l,itori,itori1,itori2)
5905             v2cdij = v2c(l,k,itori,itori1,itori2)
5906             v1sdij = v2s(k,l,itori,itori1,itori2)
5907             v2sdij = v2s(l,k,itori,itori1,itori2)
5908             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5909             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5910             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5911             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5912             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5913      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5914             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5915      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5916             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5917      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5918           enddo
5919         enddo
5920         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5921         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5922 c        write (iout,*) "gloci", gloc(i-3,icg)
5923       enddo
5924       return
5925       end
5926 #endif
5927 c------------------------------------------------------------------------------
5928       subroutine eback_sc_corr(esccor)
5929 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5930 c        conformational states; temporarily implemented as differences
5931 c        between UNRES torsional potentials (dependent on three types of
5932 c        residues) and the torsional potentials dependent on all 20 types
5933 c        of residues computed from AM1  energy surfaces of terminally-blocked
5934 c        amino-acid residues.
5935       implicit real*8 (a-h,o-z)
5936       include 'DIMENSIONS'
5937       include 'COMMON.VAR'
5938       include 'COMMON.GEO'
5939       include 'COMMON.LOCAL'
5940       include 'COMMON.TORSION'
5941       include 'COMMON.SCCOR'
5942       include 'COMMON.INTERACT'
5943       include 'COMMON.DERIV'
5944       include 'COMMON.CHAIN'
5945       include 'COMMON.NAMES'
5946       include 'COMMON.IOUNITS'
5947       include 'COMMON.FFIELD'
5948       include 'COMMON.CONTROL'
5949       logical lprn
5950 C Set lprn=.true. for debugging
5951       lprn=.false.
5952 c      lprn=.true.
5953 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5954       esccor=0.0D0
5955       do i=itau_start,itau_end
5956         esccor_ii=0.0D0
5957         isccori=isccortyp(itype(i-2))
5958         isccori1=isccortyp(itype(i-1))
5959         phii=phi(i)
5960 cccc  Added 9 May 2012
5961 cc Tauangle is torsional engle depending on the value of first digit
5962 c(see comment below)
5963 cc Omicron is flat angle depending on the value of first digit
5964 c(see comment below)
5965
5966
5967         do intertyp=1,3 !intertyp
5968 cc Added 09 May 2012 (Adasko)
5969 cc  Intertyp means interaction type of backbone mainchain correlation:
5970 c   1 = SC...Ca...Ca...Ca
5971 c   2 = Ca...Ca...Ca...SC
5972 c   3 = SC...Ca...Ca...SCi
5973         gloci=0.0D0
5974         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5975      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5976      &      (itype(i-1).eq.21)))
5977      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5978      &     .or.(itype(i-2).eq.21)))
5979      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5980      &      (itype(i-1).eq.21)))) cycle
5981         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5982         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5983      & cycle
5984         do j=1,nterm_sccor(isccori,isccori1)
5985           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5986           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5987           cosphi=dcos(j*tauangle(intertyp,i))
5988           sinphi=dsin(j*tauangle(intertyp,i))
5989           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5990           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5991         enddo
5992         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5993 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5994 c     &gloc_sc(intertyp,i-3,icg)
5995         if (lprn)
5996      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5997      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5998      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5999      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6000         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6001        enddo !intertyp
6002       enddo
6003 c        do i=1,nres
6004 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6005 c        enddo
6006       return
6007       end
6008 c----------------------------------------------------------------------------
6009       subroutine multibody(ecorr)
6010 C This subroutine calculates multi-body contributions to energy following
6011 C the idea of Skolnick et al. If side chains I and J make a contact and
6012 C at the same time side chains I+1 and J+1 make a contact, an extra
6013 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6014       implicit real*8 (a-h,o-z)
6015       include 'DIMENSIONS'
6016       include 'COMMON.IOUNITS'
6017       include 'COMMON.DERIV'
6018       include 'COMMON.INTERACT'
6019       include 'COMMON.CONTACTS'
6020       double precision gx(3),gx1(3)
6021       logical lprn
6022
6023 C Set lprn=.true. for debugging
6024       lprn=.false.
6025
6026       if (lprn) then
6027         write (iout,'(a)') 'Contact function values:'
6028         do i=nnt,nct-2
6029           write (iout,'(i2,20(1x,i2,f10.5))')
6030      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6031         enddo
6032       endif
6033       ecorr=0.0D0
6034       do i=nnt,nct
6035         do j=1,3
6036           gradcorr(j,i)=0.0D0
6037           gradxorr(j,i)=0.0D0
6038         enddo
6039       enddo
6040       do i=nnt,nct-2
6041
6042         DO ISHIFT = 3,4
6043
6044         i1=i+ishift
6045         num_conti=num_cont(i)
6046         num_conti1=num_cont(i1)
6047         do jj=1,num_conti
6048           j=jcont(jj,i)
6049           do kk=1,num_conti1
6050             j1=jcont(kk,i1)
6051             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6052 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6053 cd   &                   ' ishift=',ishift
6054 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6055 C The system gains extra energy.
6056               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6057             endif   ! j1==j+-ishift
6058           enddo     ! kk
6059         enddo       ! jj
6060
6061         ENDDO ! ISHIFT
6062
6063       enddo         ! i
6064       return
6065       end
6066 c------------------------------------------------------------------------------
6067       double precision function esccorr(i,j,k,l,jj,kk)
6068       implicit real*8 (a-h,o-z)
6069       include 'DIMENSIONS'
6070       include 'COMMON.IOUNITS'
6071       include 'COMMON.DERIV'
6072       include 'COMMON.INTERACT'
6073       include 'COMMON.CONTACTS'
6074       double precision gx(3),gx1(3)
6075       logical lprn
6076       lprn=.false.
6077       eij=facont(jj,i)
6078       ekl=facont(kk,k)
6079 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6080 C Calculate the multi-body contribution to energy.
6081 C Calculate multi-body contributions to the gradient.
6082 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6083 cd   & k,l,(gacont(m,kk,k),m=1,3)
6084       do m=1,3
6085         gx(m) =ekl*gacont(m,jj,i)
6086         gx1(m)=eij*gacont(m,kk,k)
6087         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6088         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6089         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6090         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6091       enddo
6092       do m=i,j-1
6093         do ll=1,3
6094           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6095         enddo
6096       enddo
6097       do m=k,l-1
6098         do ll=1,3
6099           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6100         enddo
6101       enddo
6102       esccorr=-eij*ekl
6103       return
6104       end
6105 c------------------------------------------------------------------------------
6106       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6107 C This subroutine calculates multi-body contributions to hydrogen-bonding
6108       implicit real*8 (a-h,o-z)
6109       include 'DIMENSIONS'
6110       include 'COMMON.IOUNITS'
6111 #ifdef MPI
6112       include "mpif.h"
6113       parameter (max_cont=maxconts)
6114       parameter (max_dim=26)
6115       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6116       double precision zapas(max_dim,maxconts,max_fg_procs),
6117      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6118       common /przechowalnia/ zapas
6119       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6120      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6121 #endif
6122       include 'COMMON.SETUP'
6123       include 'COMMON.FFIELD'
6124       include 'COMMON.DERIV'
6125       include 'COMMON.INTERACT'
6126       include 'COMMON.CONTACTS'
6127       include 'COMMON.CONTROL'
6128       include 'COMMON.LOCAL'
6129       double precision gx(3),gx1(3),time00
6130       logical lprn,ldone
6131
6132 C Set lprn=.true. for debugging
6133       lprn=.false.
6134 #ifdef MPI
6135       n_corr=0
6136       n_corr1=0
6137       if (nfgtasks.le.1) goto 30
6138       if (lprn) then
6139         write (iout,'(a)') 'Contact function values before RECEIVE:'
6140         do i=nnt,nct-2
6141           write (iout,'(2i3,50(1x,i2,f5.2))')
6142      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6143      &    j=1,num_cont_hb(i))
6144         enddo
6145       endif
6146       call flush(iout)
6147       do i=1,ntask_cont_from
6148         ncont_recv(i)=0
6149       enddo
6150       do i=1,ntask_cont_to
6151         ncont_sent(i)=0
6152       enddo
6153 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6154 c     & ntask_cont_to
6155 C Make the list of contacts to send to send to other procesors
6156 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6157 c      call flush(iout)
6158       do i=iturn3_start,iturn3_end
6159 c        write (iout,*) "make contact list turn3",i," num_cont",
6160 c     &    num_cont_hb(i)
6161         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6162       enddo
6163       do i=iturn4_start,iturn4_end
6164 c        write (iout,*) "make contact list turn4",i," num_cont",
6165 c     &   num_cont_hb(i)
6166         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6167       enddo
6168       do ii=1,nat_sent
6169         i=iat_sent(ii)
6170 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6171 c     &    num_cont_hb(i)
6172         do j=1,num_cont_hb(i)
6173         do k=1,4
6174           jjc=jcont_hb(j,i)
6175           iproc=iint_sent_local(k,jjc,ii)
6176 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6177           if (iproc.gt.0) then
6178             ncont_sent(iproc)=ncont_sent(iproc)+1
6179             nn=ncont_sent(iproc)
6180             zapas(1,nn,iproc)=i
6181             zapas(2,nn,iproc)=jjc
6182             zapas(3,nn,iproc)=facont_hb(j,i)
6183             zapas(4,nn,iproc)=ees0p(j,i)
6184             zapas(5,nn,iproc)=ees0m(j,i)
6185             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6186             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6187             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6188             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6189             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6190             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6191             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6192             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6193             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6194             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6195             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6196             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6197             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6198             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6199             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6200             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6201             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6202             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6203             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6204             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6205             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6206           endif
6207         enddo
6208         enddo
6209       enddo
6210       if (lprn) then
6211       write (iout,*)
6212      &  "Numbers of contacts to be sent to other processors",
6213      &  (ncont_sent(i),i=1,ntask_cont_to)
6214       write (iout,*) "Contacts sent"
6215       do ii=1,ntask_cont_to
6216         nn=ncont_sent(ii)
6217         iproc=itask_cont_to(ii)
6218         write (iout,*) nn," contacts to processor",iproc,
6219      &   " of CONT_TO_COMM group"
6220         do i=1,nn
6221           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6222         enddo
6223       enddo
6224       call flush(iout)
6225       endif
6226       CorrelType=477
6227       CorrelID=fg_rank+1
6228       CorrelType1=478
6229       CorrelID1=nfgtasks+fg_rank+1
6230       ireq=0
6231 C Receive the numbers of needed contacts from other processors
6232       do ii=1,ntask_cont_from
6233         iproc=itask_cont_from(ii)
6234         ireq=ireq+1
6235         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6236      &    FG_COMM,req(ireq),IERR)
6237       enddo
6238 c      write (iout,*) "IRECV ended"
6239 c      call flush(iout)
6240 C Send the number of contacts needed by other processors
6241       do ii=1,ntask_cont_to
6242         iproc=itask_cont_to(ii)
6243         ireq=ireq+1
6244         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6245      &    FG_COMM,req(ireq),IERR)
6246       enddo
6247 c      write (iout,*) "ISEND ended"
6248 c      write (iout,*) "number of requests (nn)",ireq
6249       call flush(iout)
6250       if (ireq.gt.0)
6251      &  call MPI_Waitall(ireq,req,status_array,ierr)
6252 c      write (iout,*)
6253 c     &  "Numbers of contacts to be received from other processors",
6254 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6255 c      call flush(iout)
6256 C Receive contacts
6257       ireq=0
6258       do ii=1,ntask_cont_from
6259         iproc=itask_cont_from(ii)
6260         nn=ncont_recv(ii)
6261 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6262 c     &   " of CONT_TO_COMM group"
6263         call flush(iout)
6264         if (nn.gt.0) then
6265           ireq=ireq+1
6266           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6267      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6268 c          write (iout,*) "ireq,req",ireq,req(ireq)
6269         endif
6270       enddo
6271 C Send the contacts to processors that need them
6272       do ii=1,ntask_cont_to
6273         iproc=itask_cont_to(ii)
6274         nn=ncont_sent(ii)
6275 c        write (iout,*) nn," contacts to processor",iproc,
6276 c     &   " of CONT_TO_COMM group"
6277         if (nn.gt.0) then
6278           ireq=ireq+1
6279           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6280      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6281 c          write (iout,*) "ireq,req",ireq,req(ireq)
6282 c          do i=1,nn
6283 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6284 c          enddo
6285         endif
6286       enddo
6287 c      write (iout,*) "number of requests (contacts)",ireq
6288 c      write (iout,*) "req",(req(i),i=1,4)
6289 c      call flush(iout)
6290       if (ireq.gt.0)
6291      & call MPI_Waitall(ireq,req,status_array,ierr)
6292       do iii=1,ntask_cont_from
6293         iproc=itask_cont_from(iii)
6294         nn=ncont_recv(iii)
6295         if (lprn) then
6296         write (iout,*) "Received",nn," contacts from processor",iproc,
6297      &   " of CONT_FROM_COMM group"
6298         call flush(iout)
6299         do i=1,nn
6300           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6301         enddo
6302         call flush(iout)
6303         endif
6304         do i=1,nn
6305           ii=zapas_recv(1,i,iii)
6306 c Flag the received contacts to prevent double-counting
6307           jj=-zapas_recv(2,i,iii)
6308 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6309 c          call flush(iout)
6310           nnn=num_cont_hb(ii)+1
6311           num_cont_hb(ii)=nnn
6312           jcont_hb(nnn,ii)=jj
6313           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6314           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6315           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6316           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6317           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6318           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6319           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6320           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6321           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6322           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6323           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6324           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6325           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6326           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6327           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6328           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6329           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6330           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6331           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6332           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6333           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6334           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6335           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6336           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6337         enddo
6338       enddo
6339       call flush(iout)
6340       if (lprn) then
6341         write (iout,'(a)') 'Contact function values after receive:'
6342         do i=nnt,nct-2
6343           write (iout,'(2i3,50(1x,i3,f5.2))')
6344      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6345      &    j=1,num_cont_hb(i))
6346         enddo
6347         call flush(iout)
6348       endif
6349    30 continue
6350 #endif
6351       if (lprn) then
6352         write (iout,'(a)') 'Contact function values:'
6353         do i=nnt,nct-2
6354           write (iout,'(2i3,50(1x,i3,f5.2))')
6355      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6356      &    j=1,num_cont_hb(i))
6357         enddo
6358       endif
6359       ecorr=0.0D0
6360 C Remove the loop below after debugging !!!
6361       do i=nnt,nct
6362         do j=1,3
6363           gradcorr(j,i)=0.0D0
6364           gradxorr(j,i)=0.0D0
6365         enddo
6366       enddo
6367 C Calculate the local-electrostatic correlation terms
6368       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6369         i1=i+1
6370         num_conti=num_cont_hb(i)
6371         num_conti1=num_cont_hb(i+1)
6372         do jj=1,num_conti
6373           j=jcont_hb(jj,i)
6374           jp=iabs(j)
6375           do kk=1,num_conti1
6376             j1=jcont_hb(kk,i1)
6377             jp1=iabs(j1)
6378 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6379 c     &         ' jj=',jj,' kk=',kk
6380             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6381      &          .or. j.lt.0 .and. j1.gt.0) .and.
6382      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6383 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6384 C The system gains extra energy.
6385               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6386               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6387      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6388               n_corr=n_corr+1
6389             else if (j1.eq.j) then
6390 C Contacts I-J and I-(J+1) occur simultaneously.
6391 C The system loses extra energy.
6392 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6393             endif
6394           enddo ! kk
6395           do kk=1,num_conti
6396             j1=jcont_hb(kk,i)
6397 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6398 c    &         ' jj=',jj,' kk=',kk
6399             if (j1.eq.j+1) then
6400 C Contacts I-J and (I+1)-J occur simultaneously.
6401 C The system loses extra energy.
6402 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6403             endif ! j1==j+1
6404           enddo ! kk
6405         enddo ! jj
6406       enddo ! i
6407       return
6408       end
6409 c------------------------------------------------------------------------------
6410       subroutine add_hb_contact(ii,jj,itask)
6411       implicit real*8 (a-h,o-z)
6412       include "DIMENSIONS"
6413       include "COMMON.IOUNITS"
6414       integer max_cont
6415       integer max_dim
6416       parameter (max_cont=maxconts)
6417       parameter (max_dim=26)
6418       include "COMMON.CONTACTS"
6419       double precision zapas(max_dim,maxconts,max_fg_procs),
6420      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6421       common /przechowalnia/ zapas
6422       integer i,j,ii,jj,iproc,itask(4),nn
6423 c      write (iout,*) "itask",itask
6424       do i=1,2
6425         iproc=itask(i)
6426         if (iproc.gt.0) then
6427           do j=1,num_cont_hb(ii)
6428             jjc=jcont_hb(j,ii)
6429 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6430             if (jjc.eq.jj) then
6431               ncont_sent(iproc)=ncont_sent(iproc)+1
6432               nn=ncont_sent(iproc)
6433               zapas(1,nn,iproc)=ii
6434               zapas(2,nn,iproc)=jjc
6435               zapas(3,nn,iproc)=facont_hb(j,ii)
6436               zapas(4,nn,iproc)=ees0p(j,ii)
6437               zapas(5,nn,iproc)=ees0m(j,ii)
6438               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6439               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6440               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6441               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6442               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6443               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6444               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6445               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6446               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6447               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6448               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6449               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6450               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6451               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6452               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6453               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6454               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6455               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6456               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6457               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6458               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6459               exit
6460             endif
6461           enddo
6462         endif
6463       enddo
6464       return
6465       end
6466 c------------------------------------------------------------------------------
6467       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6468      &  n_corr1)
6469 C This subroutine calculates multi-body contributions to hydrogen-bonding
6470       implicit real*8 (a-h,o-z)
6471       include 'DIMENSIONS'
6472       include 'COMMON.IOUNITS'
6473 #ifdef MPI
6474       include "mpif.h"
6475       parameter (max_cont=maxconts)
6476       parameter (max_dim=70)
6477       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6478       double precision zapas(max_dim,maxconts,max_fg_procs),
6479      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6480       common /przechowalnia/ zapas
6481       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6482      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6483 #endif
6484       include 'COMMON.SETUP'
6485       include 'COMMON.FFIELD'
6486       include 'COMMON.DERIV'
6487       include 'COMMON.LOCAL'
6488       include 'COMMON.INTERACT'
6489       include 'COMMON.CONTACTS'
6490       include 'COMMON.CHAIN'
6491       include 'COMMON.CONTROL'
6492       double precision gx(3),gx1(3)
6493       integer num_cont_hb_old(maxres)
6494       logical lprn,ldone
6495       double precision eello4,eello5,eelo6,eello_turn6
6496       external eello4,eello5,eello6,eello_turn6
6497 C Set lprn=.true. for debugging
6498       lprn=.false.
6499       eturn6=0.0d0
6500 #ifdef MPI
6501       do i=1,nres
6502         num_cont_hb_old(i)=num_cont_hb(i)
6503       enddo
6504       n_corr=0
6505       n_corr1=0
6506       if (nfgtasks.le.1) goto 30
6507       if (lprn) then
6508         write (iout,'(a)') 'Contact function values before RECEIVE:'
6509         do i=nnt,nct-2
6510           write (iout,'(2i3,50(1x,i2,f5.2))')
6511      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6512      &    j=1,num_cont_hb(i))
6513         enddo
6514       endif
6515       call flush(iout)
6516       do i=1,ntask_cont_from
6517         ncont_recv(i)=0
6518       enddo
6519       do i=1,ntask_cont_to
6520         ncont_sent(i)=0
6521       enddo
6522 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6523 c     & ntask_cont_to
6524 C Make the list of contacts to send to send to other procesors
6525       do i=iturn3_start,iturn3_end
6526 c        write (iout,*) "make contact list turn3",i," num_cont",
6527 c     &    num_cont_hb(i)
6528         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6529       enddo
6530       do i=iturn4_start,iturn4_end
6531 c        write (iout,*) "make contact list turn4",i," num_cont",
6532 c     &   num_cont_hb(i)
6533         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6534       enddo
6535       do ii=1,nat_sent
6536         i=iat_sent(ii)
6537 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6538 c     &    num_cont_hb(i)
6539         do j=1,num_cont_hb(i)
6540         do k=1,4
6541           jjc=jcont_hb(j,i)
6542           iproc=iint_sent_local(k,jjc,ii)
6543 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6544           if (iproc.ne.0) then
6545             ncont_sent(iproc)=ncont_sent(iproc)+1
6546             nn=ncont_sent(iproc)
6547             zapas(1,nn,iproc)=i
6548             zapas(2,nn,iproc)=jjc
6549             zapas(3,nn,iproc)=d_cont(j,i)
6550             ind=3
6551             do kk=1,3
6552               ind=ind+1
6553               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6554             enddo
6555             do kk=1,2
6556               do ll=1,2
6557                 ind=ind+1
6558                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6559               enddo
6560             enddo
6561             do jj=1,5
6562               do kk=1,3
6563                 do ll=1,2
6564                   do mm=1,2
6565                     ind=ind+1
6566                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6567                   enddo
6568                 enddo
6569               enddo
6570             enddo
6571           endif
6572         enddo
6573         enddo
6574       enddo
6575       if (lprn) then
6576       write (iout,*)
6577      &  "Numbers of contacts to be sent to other processors",
6578      &  (ncont_sent(i),i=1,ntask_cont_to)
6579       write (iout,*) "Contacts sent"
6580       do ii=1,ntask_cont_to
6581         nn=ncont_sent(ii)
6582         iproc=itask_cont_to(ii)
6583         write (iout,*) nn," contacts to processor",iproc,
6584      &   " of CONT_TO_COMM group"
6585         do i=1,nn
6586           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6587         enddo
6588       enddo
6589       call flush(iout)
6590       endif
6591       CorrelType=477
6592       CorrelID=fg_rank+1
6593       CorrelType1=478
6594       CorrelID1=nfgtasks+fg_rank+1
6595       ireq=0
6596 C Receive the numbers of needed contacts from other processors
6597       do ii=1,ntask_cont_from
6598         iproc=itask_cont_from(ii)
6599         ireq=ireq+1
6600         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6601      &    FG_COMM,req(ireq),IERR)
6602       enddo
6603 c      write (iout,*) "IRECV ended"
6604 c      call flush(iout)
6605 C Send the number of contacts needed by other processors
6606       do ii=1,ntask_cont_to
6607         iproc=itask_cont_to(ii)
6608         ireq=ireq+1
6609         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6610      &    FG_COMM,req(ireq),IERR)
6611       enddo
6612 c      write (iout,*) "ISEND ended"
6613 c      write (iout,*) "number of requests (nn)",ireq
6614       call flush(iout)
6615       if (ireq.gt.0)
6616      &  call MPI_Waitall(ireq,req,status_array,ierr)
6617 c      write (iout,*)
6618 c     &  "Numbers of contacts to be received from other processors",
6619 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6620 c      call flush(iout)
6621 C Receive contacts
6622       ireq=0
6623       do ii=1,ntask_cont_from
6624         iproc=itask_cont_from(ii)
6625         nn=ncont_recv(ii)
6626 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6627 c     &   " of CONT_TO_COMM group"
6628         call flush(iout)
6629         if (nn.gt.0) then
6630           ireq=ireq+1
6631           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6632      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6633 c          write (iout,*) "ireq,req",ireq,req(ireq)
6634         endif
6635       enddo
6636 C Send the contacts to processors that need them
6637       do ii=1,ntask_cont_to
6638         iproc=itask_cont_to(ii)
6639         nn=ncont_sent(ii)
6640 c        write (iout,*) nn," contacts to processor",iproc,
6641 c     &   " of CONT_TO_COMM group"
6642         if (nn.gt.0) then
6643           ireq=ireq+1
6644           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6645      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6646 c          write (iout,*) "ireq,req",ireq,req(ireq)
6647 c          do i=1,nn
6648 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6649 c          enddo
6650         endif
6651       enddo
6652 c      write (iout,*) "number of requests (contacts)",ireq
6653 c      write (iout,*) "req",(req(i),i=1,4)
6654 c      call flush(iout)
6655       if (ireq.gt.0)
6656      & call MPI_Waitall(ireq,req,status_array,ierr)
6657       do iii=1,ntask_cont_from
6658         iproc=itask_cont_from(iii)
6659         nn=ncont_recv(iii)
6660         if (lprn) then
6661         write (iout,*) "Received",nn," contacts from processor",iproc,
6662      &   " of CONT_FROM_COMM group"
6663         call flush(iout)
6664         do i=1,nn
6665           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6666         enddo
6667         call flush(iout)
6668         endif
6669         do i=1,nn
6670           ii=zapas_recv(1,i,iii)
6671 c Flag the received contacts to prevent double-counting
6672           jj=-zapas_recv(2,i,iii)
6673 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6674 c          call flush(iout)
6675           nnn=num_cont_hb(ii)+1
6676           num_cont_hb(ii)=nnn
6677           jcont_hb(nnn,ii)=jj
6678           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6679           ind=3
6680           do kk=1,3
6681             ind=ind+1
6682             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6683           enddo
6684           do kk=1,2
6685             do ll=1,2
6686               ind=ind+1
6687               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6688             enddo
6689           enddo
6690           do jj=1,5
6691             do kk=1,3
6692               do ll=1,2
6693                 do mm=1,2
6694                   ind=ind+1
6695                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6696                 enddo
6697               enddo
6698             enddo
6699           enddo
6700         enddo
6701       enddo
6702       call flush(iout)
6703       if (lprn) then
6704         write (iout,'(a)') 'Contact function values after receive:'
6705         do i=nnt,nct-2
6706           write (iout,'(2i3,50(1x,i3,5f6.3))')
6707      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6708      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6709         enddo
6710         call flush(iout)
6711       endif
6712    30 continue
6713 #endif
6714       if (lprn) then
6715         write (iout,'(a)') 'Contact function values:'
6716         do i=nnt,nct-2
6717           write (iout,'(2i3,50(1x,i2,5f6.3))')
6718      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6719      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6720         enddo
6721       endif
6722       ecorr=0.0D0
6723       ecorr5=0.0d0
6724       ecorr6=0.0d0
6725 C Remove the loop below after debugging !!!
6726       do i=nnt,nct
6727         do j=1,3
6728           gradcorr(j,i)=0.0D0
6729           gradxorr(j,i)=0.0D0
6730         enddo
6731       enddo
6732 C Calculate the dipole-dipole interaction energies
6733       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6734       do i=iatel_s,iatel_e+1
6735         num_conti=num_cont_hb(i)
6736         do jj=1,num_conti
6737           j=jcont_hb(jj,i)
6738 #ifdef MOMENT
6739           call dipole(i,j,jj)
6740 #endif
6741         enddo
6742       enddo
6743       endif
6744 C Calculate the local-electrostatic correlation terms
6745 c                write (iout,*) "gradcorr5 in eello5 before loop"
6746 c                do iii=1,nres
6747 c                  write (iout,'(i5,3f10.5)')
6748 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6749 c                enddo
6750       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6751 c        write (iout,*) "corr loop i",i
6752         i1=i+1
6753         num_conti=num_cont_hb(i)
6754         num_conti1=num_cont_hb(i+1)
6755         do jj=1,num_conti
6756           j=jcont_hb(jj,i)
6757           jp=iabs(j)
6758           do kk=1,num_conti1
6759             j1=jcont_hb(kk,i1)
6760             jp1=iabs(j1)
6761 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6762 c     &         ' jj=',jj,' kk=',kk
6763 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6764             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6765      &          .or. j.lt.0 .and. j1.gt.0) .and.
6766      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6767 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6768 C The system gains extra energy.
6769               n_corr=n_corr+1
6770               sqd1=dsqrt(d_cont(jj,i))
6771               sqd2=dsqrt(d_cont(kk,i1))
6772               sred_geom = sqd1*sqd2
6773               IF (sred_geom.lt.cutoff_corr) THEN
6774                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6775      &            ekont,fprimcont)
6776 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6777 cd     &         ' jj=',jj,' kk=',kk
6778                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6779                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6780                 do l=1,3
6781                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6782                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6783                 enddo
6784                 n_corr1=n_corr1+1
6785 cd               write (iout,*) 'sred_geom=',sred_geom,
6786 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6787 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6788 cd               write (iout,*) "g_contij",g_contij
6789 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6790 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6791                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6792                 if (wcorr4.gt.0.0d0)
6793      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6794                   if (energy_dec.and.wcorr4.gt.0.0d0)
6795      1                 write (iout,'(a6,4i5,0pf7.3)')
6796      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6797 c                write (iout,*) "gradcorr5 before eello5"
6798 c                do iii=1,nres
6799 c                  write (iout,'(i5,3f10.5)')
6800 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6801 c                enddo
6802                 if (wcorr5.gt.0.0d0)
6803      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6804 c                write (iout,*) "gradcorr5 after eello5"
6805 c                do iii=1,nres
6806 c                  write (iout,'(i5,3f10.5)')
6807 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6808 c                enddo
6809                   if (energy_dec.and.wcorr5.gt.0.0d0)
6810      1                 write (iout,'(a6,4i5,0pf7.3)')
6811      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6812 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6813 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6814                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6815      &               .or. wturn6.eq.0.0d0))then
6816 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6817                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6818                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6819      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6820 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6821 cd     &            'ecorr6=',ecorr6
6822 cd                write (iout,'(4e15.5)') sred_geom,
6823 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6824 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6825 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6826                 else if (wturn6.gt.0.0d0
6827      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6828 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6829                   eturn6=eturn6+eello_turn6(i,jj,kk)
6830                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6831      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6832 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6833                 endif
6834               ENDIF
6835 1111          continue
6836             endif
6837           enddo ! kk
6838         enddo ! jj
6839       enddo ! i
6840       do i=1,nres
6841         num_cont_hb(i)=num_cont_hb_old(i)
6842       enddo
6843 c                write (iout,*) "gradcorr5 in eello5"
6844 c                do iii=1,nres
6845 c                  write (iout,'(i5,3f10.5)')
6846 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6847 c                enddo
6848       return
6849       end
6850 c------------------------------------------------------------------------------
6851       subroutine add_hb_contact_eello(ii,jj,itask)
6852       implicit real*8 (a-h,o-z)
6853       include "DIMENSIONS"
6854       include "COMMON.IOUNITS"
6855       integer max_cont
6856       integer max_dim
6857       parameter (max_cont=maxconts)
6858       parameter (max_dim=70)
6859       include "COMMON.CONTACTS"
6860       double precision zapas(max_dim,maxconts,max_fg_procs),
6861      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6862       common /przechowalnia/ zapas
6863       integer i,j,ii,jj,iproc,itask(4),nn
6864 c      write (iout,*) "itask",itask
6865       do i=1,2
6866         iproc=itask(i)
6867         if (iproc.gt.0) then
6868           do j=1,num_cont_hb(ii)
6869             jjc=jcont_hb(j,ii)
6870 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6871             if (jjc.eq.jj) then
6872               ncont_sent(iproc)=ncont_sent(iproc)+1
6873               nn=ncont_sent(iproc)
6874               zapas(1,nn,iproc)=ii
6875               zapas(2,nn,iproc)=jjc
6876               zapas(3,nn,iproc)=d_cont(j,ii)
6877               ind=3
6878               do kk=1,3
6879                 ind=ind+1
6880                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6881               enddo
6882               do kk=1,2
6883                 do ll=1,2
6884                   ind=ind+1
6885                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6886                 enddo
6887               enddo
6888               do jj=1,5
6889                 do kk=1,3
6890                   do ll=1,2
6891                     do mm=1,2
6892                       ind=ind+1
6893                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6894                     enddo
6895                   enddo
6896                 enddo
6897               enddo
6898               exit
6899             endif
6900           enddo
6901         endif
6902       enddo
6903       return
6904       end
6905 c------------------------------------------------------------------------------
6906       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6907       implicit real*8 (a-h,o-z)
6908       include 'DIMENSIONS'
6909       include 'COMMON.IOUNITS'
6910       include 'COMMON.DERIV'
6911       include 'COMMON.INTERACT'
6912       include 'COMMON.CONTACTS'
6913       double precision gx(3),gx1(3)
6914       logical lprn
6915       lprn=.false.
6916       eij=facont_hb(jj,i)
6917       ekl=facont_hb(kk,k)
6918       ees0pij=ees0p(jj,i)
6919       ees0pkl=ees0p(kk,k)
6920       ees0mij=ees0m(jj,i)
6921       ees0mkl=ees0m(kk,k)
6922       ekont=eij*ekl
6923       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6924 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6925 C Following 4 lines for diagnostics.
6926 cd    ees0pkl=0.0D0
6927 cd    ees0pij=1.0D0
6928 cd    ees0mkl=0.0D0
6929 cd    ees0mij=1.0D0
6930 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6931 c     & 'Contacts ',i,j,
6932 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6933 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6934 c     & 'gradcorr_long'
6935 C Calculate the multi-body contribution to energy.
6936 c      ecorr=ecorr+ekont*ees
6937 C Calculate multi-body contributions to the gradient.
6938       coeffpees0pij=coeffp*ees0pij
6939       coeffmees0mij=coeffm*ees0mij
6940       coeffpees0pkl=coeffp*ees0pkl
6941       coeffmees0mkl=coeffm*ees0mkl
6942       do ll=1,3
6943 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6944         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6945      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6946      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6947         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6948      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6949      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6950 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6951         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6952      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6953      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6954         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6955      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6956      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6957         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6958      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6959      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6960         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6961         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6962         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6963      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6964      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6965         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6966         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6967 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6968       enddo
6969 c      write (iout,*)
6970 cgrad      do m=i+1,j-1
6971 cgrad        do ll=1,3
6972 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6973 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6974 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6975 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6976 cgrad        enddo
6977 cgrad      enddo
6978 cgrad      do m=k+1,l-1
6979 cgrad        do ll=1,3
6980 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6981 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6982 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6983 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6984 cgrad        enddo
6985 cgrad      enddo
6986 c      write (iout,*) "ehbcorr",ekont*ees
6987       ehbcorr=ekont*ees
6988       return
6989       end
6990 #ifdef MOMENT
6991 C---------------------------------------------------------------------------
6992       subroutine dipole(i,j,jj)
6993       implicit real*8 (a-h,o-z)
6994       include 'DIMENSIONS'
6995       include 'COMMON.IOUNITS'
6996       include 'COMMON.CHAIN'
6997       include 'COMMON.FFIELD'
6998       include 'COMMON.DERIV'
6999       include 'COMMON.INTERACT'
7000       include 'COMMON.CONTACTS'
7001       include 'COMMON.TORSION'
7002       include 'COMMON.VAR'
7003       include 'COMMON.GEO'
7004       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7005      &  auxmat(2,2)
7006       iti1 = itortyp(itype(i+1))
7007       if (j.lt.nres-1) then
7008         itj1 = itortyp(itype(j+1))
7009       else
7010         itj1=ntortyp+1
7011       endif
7012       do iii=1,2
7013         dipi(iii,1)=Ub2(iii,i)
7014         dipderi(iii)=Ub2der(iii,i)
7015         dipi(iii,2)=b1(iii,iti1)
7016         dipj(iii,1)=Ub2(iii,j)
7017         dipderj(iii)=Ub2der(iii,j)
7018         dipj(iii,2)=b1(iii,itj1)
7019       enddo
7020       kkk=0
7021       do iii=1,2
7022         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7023         do jjj=1,2
7024           kkk=kkk+1
7025           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7026         enddo
7027       enddo
7028       do kkk=1,5
7029         do lll=1,3
7030           mmm=0
7031           do iii=1,2
7032             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7033      &        auxvec(1))
7034             do jjj=1,2
7035               mmm=mmm+1
7036               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7037             enddo
7038           enddo
7039         enddo
7040       enddo
7041       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7042       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7043       do iii=1,2
7044         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7045       enddo
7046       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7047       do iii=1,2
7048         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7049       enddo
7050       return
7051       end
7052 #endif
7053 C---------------------------------------------------------------------------
7054       subroutine calc_eello(i,j,k,l,jj,kk)
7055 C
7056 C This subroutine computes matrices and vectors needed to calculate
7057 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7058 C
7059       implicit real*8 (a-h,o-z)
7060       include 'DIMENSIONS'
7061       include 'COMMON.IOUNITS'
7062       include 'COMMON.CHAIN'
7063       include 'COMMON.DERIV'
7064       include 'COMMON.INTERACT'
7065       include 'COMMON.CONTACTS'
7066       include 'COMMON.TORSION'
7067       include 'COMMON.VAR'
7068       include 'COMMON.GEO'
7069       include 'COMMON.FFIELD'
7070       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7071      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7072       logical lprn
7073       common /kutas/ lprn
7074 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7075 cd     & ' jj=',jj,' kk=',kk
7076 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7077 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7078 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7079       do iii=1,2
7080         do jjj=1,2
7081           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7082           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7083         enddo
7084       enddo
7085       call transpose2(aa1(1,1),aa1t(1,1))
7086       call transpose2(aa2(1,1),aa2t(1,1))
7087       do kkk=1,5
7088         do lll=1,3
7089           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7090      &      aa1tder(1,1,lll,kkk))
7091           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7092      &      aa2tder(1,1,lll,kkk))
7093         enddo
7094       enddo
7095       if (l.eq.j+1) then
7096 C parallel orientation of the two CA-CA-CA frames.
7097         if (i.gt.1) then
7098           iti=itortyp(itype(i))
7099         else
7100           iti=ntortyp+1
7101         endif
7102         itk1=itortyp(itype(k+1))
7103         itj=itortyp(itype(j))
7104         if (l.lt.nres-1) then
7105           itl1=itortyp(itype(l+1))
7106         else
7107           itl1=ntortyp+1
7108         endif
7109 C A1 kernel(j+1) A2T
7110 cd        do iii=1,2
7111 cd          write (iout,'(3f10.5,5x,3f10.5)')
7112 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7113 cd        enddo
7114         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7115      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7116      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7117 C Following matrices are needed only for 6-th order cumulants
7118         IF (wcorr6.gt.0.0d0) THEN
7119         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7120      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7121      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7122         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7123      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7124      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7125      &   ADtEAderx(1,1,1,1,1,1))
7126         lprn=.false.
7127         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7128      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7129      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7130      &   ADtEA1derx(1,1,1,1,1,1))
7131         ENDIF
7132 C End 6-th order cumulants
7133 cd        lprn=.false.
7134 cd        if (lprn) then
7135 cd        write (2,*) 'In calc_eello6'
7136 cd        do iii=1,2
7137 cd          write (2,*) 'iii=',iii
7138 cd          do kkk=1,5
7139 cd            write (2,*) 'kkk=',kkk
7140 cd            do jjj=1,2
7141 cd              write (2,'(3(2f10.5),5x)')
7142 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7143 cd            enddo
7144 cd          enddo
7145 cd        enddo
7146 cd        endif
7147         call transpose2(EUgder(1,1,k),auxmat(1,1))
7148         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7149         call transpose2(EUg(1,1,k),auxmat(1,1))
7150         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7151         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7152         do iii=1,2
7153           do kkk=1,5
7154             do lll=1,3
7155               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7156      &          EAEAderx(1,1,lll,kkk,iii,1))
7157             enddo
7158           enddo
7159         enddo
7160 C A1T kernel(i+1) A2
7161         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7162      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7163      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7164 C Following matrices are needed only for 6-th order cumulants
7165         IF (wcorr6.gt.0.0d0) THEN
7166         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7167      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7168      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7169         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7170      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7171      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7172      &   ADtEAderx(1,1,1,1,1,2))
7173         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7174      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7175      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7176      &   ADtEA1derx(1,1,1,1,1,2))
7177         ENDIF
7178 C End 6-th order cumulants
7179         call transpose2(EUgder(1,1,l),auxmat(1,1))
7180         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7181         call transpose2(EUg(1,1,l),auxmat(1,1))
7182         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7183         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7184         do iii=1,2
7185           do kkk=1,5
7186             do lll=1,3
7187               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7188      &          EAEAderx(1,1,lll,kkk,iii,2))
7189             enddo
7190           enddo
7191         enddo
7192 C AEAb1 and AEAb2
7193 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7194 C They are needed only when the fifth- or the sixth-order cumulants are
7195 C indluded.
7196         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7197         call transpose2(AEA(1,1,1),auxmat(1,1))
7198         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7199         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7200         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7201         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7202         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7203         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7204         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7205         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7206         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7207         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7208         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7209         call transpose2(AEA(1,1,2),auxmat(1,1))
7210         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7211         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7212         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7213         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7214         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7215         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7216         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7217         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7218         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7219         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7220         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7221 C Calculate the Cartesian derivatives of the vectors.
7222         do iii=1,2
7223           do kkk=1,5
7224             do lll=1,3
7225               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7226               call matvec2(auxmat(1,1),b1(1,iti),
7227      &          AEAb1derx(1,lll,kkk,iii,1,1))
7228               call matvec2(auxmat(1,1),Ub2(1,i),
7229      &          AEAb2derx(1,lll,kkk,iii,1,1))
7230               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7231      &          AEAb1derx(1,lll,kkk,iii,2,1))
7232               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7233      &          AEAb2derx(1,lll,kkk,iii,2,1))
7234               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7235               call matvec2(auxmat(1,1),b1(1,itj),
7236      &          AEAb1derx(1,lll,kkk,iii,1,2))
7237               call matvec2(auxmat(1,1),Ub2(1,j),
7238      &          AEAb2derx(1,lll,kkk,iii,1,2))
7239               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7240      &          AEAb1derx(1,lll,kkk,iii,2,2))
7241               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7242      &          AEAb2derx(1,lll,kkk,iii,2,2))
7243             enddo
7244           enddo
7245         enddo
7246         ENDIF
7247 C End vectors
7248       else
7249 C Antiparallel orientation of the two CA-CA-CA frames.
7250         if (i.gt.1) then
7251           iti=itortyp(itype(i))
7252         else
7253           iti=ntortyp+1
7254         endif
7255         itk1=itortyp(itype(k+1))
7256         itl=itortyp(itype(l))
7257         itj=itortyp(itype(j))
7258         if (j.lt.nres-1) then
7259           itj1=itortyp(itype(j+1))
7260         else
7261           itj1=ntortyp+1
7262         endif
7263 C A2 kernel(j-1)T A1T
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.,EUg(1,1,j),EUgder(1,1,j),
7266      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7267 C Following matrices are needed only for 6-th order cumulants
7268         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7269      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7270         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7271      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7272      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7273         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7274      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7275      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7276      &   ADtEAderx(1,1,1,1,1,1))
7277         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7278      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7279      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7280      &   ADtEA1derx(1,1,1,1,1,1))
7281         ENDIF
7282 C End 6-th order cumulants
7283         call transpose2(EUgder(1,1,k),auxmat(1,1))
7284         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7285         call transpose2(EUg(1,1,k),auxmat(1,1))
7286         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7287         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7288         do iii=1,2
7289           do kkk=1,5
7290             do lll=1,3
7291               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7292      &          EAEAderx(1,1,lll,kkk,iii,1))
7293             enddo
7294           enddo
7295         enddo
7296 C A2T kernel(i+1)T A1
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.,EUg(1,1,k),EUgder(1,1,k),
7299      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7300 C Following matrices are needed only for 6-th order cumulants
7301         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7302      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7303         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7304      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7305      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7306         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7307      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7308      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7309      &   ADtEAderx(1,1,1,1,1,2))
7310         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7311      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7312      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7313      &   ADtEA1derx(1,1,1,1,1,2))
7314         ENDIF
7315 C End 6-th order cumulants
7316         call transpose2(EUgder(1,1,j),auxmat(1,1))
7317         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7318         call transpose2(EUg(1,1,j),auxmat(1,1))
7319         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7320         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7321         do iii=1,2
7322           do kkk=1,5
7323             do lll=1,3
7324               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7325      &          EAEAderx(1,1,lll,kkk,iii,2))
7326             enddo
7327           enddo
7328         enddo
7329 C AEAb1 and AEAb2
7330 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7331 C They are needed only when the fifth- or the sixth-order cumulants are
7332 C indluded.
7333         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7334      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7335         call transpose2(AEA(1,1,1),auxmat(1,1))
7336         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7337         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7338         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7339         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7340         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7341         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7342         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7343         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7344         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7345         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7346         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7347         call transpose2(AEA(1,1,2),auxmat(1,1))
7348         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7349         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7350         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7351         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7352         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7353         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7354         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7355         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7356         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7357         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7358         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7359 C Calculate the Cartesian derivatives of the vectors.
7360         do iii=1,2
7361           do kkk=1,5
7362             do lll=1,3
7363               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7364               call matvec2(auxmat(1,1),b1(1,iti),
7365      &          AEAb1derx(1,lll,kkk,iii,1,1))
7366               call matvec2(auxmat(1,1),Ub2(1,i),
7367      &          AEAb2derx(1,lll,kkk,iii,1,1))
7368               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7369      &          AEAb1derx(1,lll,kkk,iii,2,1))
7370               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7371      &          AEAb2derx(1,lll,kkk,iii,2,1))
7372               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7373               call matvec2(auxmat(1,1),b1(1,itl),
7374      &          AEAb1derx(1,lll,kkk,iii,1,2))
7375               call matvec2(auxmat(1,1),Ub2(1,l),
7376      &          AEAb2derx(1,lll,kkk,iii,1,2))
7377               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7378      &          AEAb1derx(1,lll,kkk,iii,2,2))
7379               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7380      &          AEAb2derx(1,lll,kkk,iii,2,2))
7381             enddo
7382           enddo
7383         enddo
7384         ENDIF
7385 C End vectors
7386       endif
7387       return
7388       end
7389 C---------------------------------------------------------------------------
7390       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7391      &  KK,KKderg,AKA,AKAderg,AKAderx)
7392       implicit none
7393       integer nderg
7394       logical transp
7395       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7396      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7397      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7398       integer iii,kkk,lll
7399       integer jjj,mmm
7400       logical lprn
7401       common /kutas/ lprn
7402       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7403       do iii=1,nderg
7404         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7405      &    AKAderg(1,1,iii))
7406       enddo
7407 cd      if (lprn) write (2,*) 'In kernel'
7408       do kkk=1,5
7409 cd        if (lprn) write (2,*) 'kkk=',kkk
7410         do lll=1,3
7411           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7412      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7413 cd          if (lprn) then
7414 cd            write (2,*) 'lll=',lll
7415 cd            write (2,*) 'iii=1'
7416 cd            do jjj=1,2
7417 cd              write (2,'(3(2f10.5),5x)')
7418 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7419 cd            enddo
7420 cd          endif
7421           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7422      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7423 cd          if (lprn) then
7424 cd            write (2,*) 'lll=',lll
7425 cd            write (2,*) 'iii=2'
7426 cd            do jjj=1,2
7427 cd              write (2,'(3(2f10.5),5x)')
7428 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7429 cd            enddo
7430 cd          endif
7431         enddo
7432       enddo
7433       return
7434       end
7435 C---------------------------------------------------------------------------
7436       double precision function eello4(i,j,k,l,jj,kk)
7437       implicit real*8 (a-h,o-z)
7438       include 'DIMENSIONS'
7439       include 'COMMON.IOUNITS'
7440       include 'COMMON.CHAIN'
7441       include 'COMMON.DERIV'
7442       include 'COMMON.INTERACT'
7443       include 'COMMON.CONTACTS'
7444       include 'COMMON.TORSION'
7445       include 'COMMON.VAR'
7446       include 'COMMON.GEO'
7447       double precision pizda(2,2),ggg1(3),ggg2(3)
7448 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7449 cd        eello4=0.0d0
7450 cd        return
7451 cd      endif
7452 cd      print *,'eello4:',i,j,k,l,jj,kk
7453 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7454 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7455 cold      eij=facont_hb(jj,i)
7456 cold      ekl=facont_hb(kk,k)
7457 cold      ekont=eij*ekl
7458       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7459 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7460       gcorr_loc(k-1)=gcorr_loc(k-1)
7461      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7462       if (l.eq.j+1) then
7463         gcorr_loc(l-1)=gcorr_loc(l-1)
7464      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7465       else
7466         gcorr_loc(j-1)=gcorr_loc(j-1)
7467      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7468       endif
7469       do iii=1,2
7470         do kkk=1,5
7471           do lll=1,3
7472             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7473      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7474 cd            derx(lll,kkk,iii)=0.0d0
7475           enddo
7476         enddo
7477       enddo
7478 cd      gcorr_loc(l-1)=0.0d0
7479 cd      gcorr_loc(j-1)=0.0d0
7480 cd      gcorr_loc(k-1)=0.0d0
7481 cd      eel4=1.0d0
7482 cd      write (iout,*)'Contacts have occurred for peptide groups',
7483 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7484 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7485       if (j.lt.nres-1) then
7486         j1=j+1
7487         j2=j-1
7488       else
7489         j1=j-1
7490         j2=j-2
7491       endif
7492       if (l.lt.nres-1) then
7493         l1=l+1
7494         l2=l-1
7495       else
7496         l1=l-1
7497         l2=l-2
7498       endif
7499       do ll=1,3
7500 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7501 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7502         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7503         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7504 cgrad        ghalf=0.5d0*ggg1(ll)
7505         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7506         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7507         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7508         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7509         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7510         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7511 cgrad        ghalf=0.5d0*ggg2(ll)
7512         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7513         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7514         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7515         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7516         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7517         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7518       enddo
7519 cgrad      do m=i+1,j-1
7520 cgrad        do ll=1,3
7521 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7522 cgrad        enddo
7523 cgrad      enddo
7524 cgrad      do m=k+1,l-1
7525 cgrad        do ll=1,3
7526 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7527 cgrad        enddo
7528 cgrad      enddo
7529 cgrad      do m=i+2,j2
7530 cgrad        do ll=1,3
7531 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7532 cgrad        enddo
7533 cgrad      enddo
7534 cgrad      do m=k+2,l2
7535 cgrad        do ll=1,3
7536 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7537 cgrad        enddo
7538 cgrad      enddo
7539 cd      do iii=1,nres-3
7540 cd        write (2,*) iii,gcorr_loc(iii)
7541 cd      enddo
7542       eello4=ekont*eel4
7543 cd      write (2,*) 'ekont',ekont
7544 cd      write (iout,*) 'eello4',ekont*eel4
7545       return
7546       end
7547 C---------------------------------------------------------------------------
7548       double precision function eello5(i,j,k,l,jj,kk)
7549       implicit real*8 (a-h,o-z)
7550       include 'DIMENSIONS'
7551       include 'COMMON.IOUNITS'
7552       include 'COMMON.CHAIN'
7553       include 'COMMON.DERIV'
7554       include 'COMMON.INTERACT'
7555       include 'COMMON.CONTACTS'
7556       include 'COMMON.TORSION'
7557       include 'COMMON.VAR'
7558       include 'COMMON.GEO'
7559       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7560       double precision ggg1(3),ggg2(3)
7561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7562 C                                                                              C
7563 C                            Parallel chains                                   C
7564 C                                                                              C
7565 C          o             o                   o             o                   C
7566 C         /l\           / \             \   / \           / \   /              C
7567 C        /   \         /   \             \ /   \         /   \ /               C
7568 C       j| o |l1       | o |              o| o |         | o |o                C
7569 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7570 C      \i/   \         /   \ /             /   \         /   \                 C
7571 C       o    k1             o                                                  C
7572 C         (I)          (II)                (III)          (IV)                 C
7573 C                                                                              C
7574 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7575 C                                                                              C
7576 C                            Antiparallel chains                               C
7577 C                                                                              C
7578 C          o             o                   o             o                   C
7579 C         /j\           / \             \   / \           / \   /              C
7580 C        /   \         /   \             \ /   \         /   \ /               C
7581 C      j1| o |l        | o |              o| o |         | o |o                C
7582 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7583 C      \i/   \         /   \ /             /   \         /   \                 C
7584 C       o     k1            o                                                  C
7585 C         (I)          (II)                (III)          (IV)                 C
7586 C                                                                              C
7587 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7588 C                                                                              C
7589 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7590 C                                                                              C
7591 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7592 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7593 cd        eello5=0.0d0
7594 cd        return
7595 cd      endif
7596 cd      write (iout,*)
7597 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7598 cd     &   ' and',k,l
7599       itk=itortyp(itype(k))
7600       itl=itortyp(itype(l))
7601       itj=itortyp(itype(j))
7602       eello5_1=0.0d0
7603       eello5_2=0.0d0
7604       eello5_3=0.0d0
7605       eello5_4=0.0d0
7606 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7607 cd     &   eel5_3_num,eel5_4_num)
7608       do iii=1,2
7609         do kkk=1,5
7610           do lll=1,3
7611             derx(lll,kkk,iii)=0.0d0
7612           enddo
7613         enddo
7614       enddo
7615 cd      eij=facont_hb(jj,i)
7616 cd      ekl=facont_hb(kk,k)
7617 cd      ekont=eij*ekl
7618 cd      write (iout,*)'Contacts have occurred for peptide groups',
7619 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7620 cd      goto 1111
7621 C Contribution from the graph I.
7622 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7623 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7624       call transpose2(EUg(1,1,k),auxmat(1,1))
7625       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7626       vv(1)=pizda(1,1)-pizda(2,2)
7627       vv(2)=pizda(1,2)+pizda(2,1)
7628       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7629      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7630 C Explicit gradient in virtual-dihedral angles.
7631       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7632      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7633      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7634       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7635       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7636       vv(1)=pizda(1,1)-pizda(2,2)
7637       vv(2)=pizda(1,2)+pizda(2,1)
7638       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7639      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7640      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7641       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7642       vv(1)=pizda(1,1)-pizda(2,2)
7643       vv(2)=pizda(1,2)+pizda(2,1)
7644       if (l.eq.j+1) then
7645         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7646      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7647      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7648       else
7649         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7650      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7651      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7652       endif
7653 C Cartesian gradient
7654       do iii=1,2
7655         do kkk=1,5
7656           do lll=1,3
7657             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7658      &        pizda(1,1))
7659             vv(1)=pizda(1,1)-pizda(2,2)
7660             vv(2)=pizda(1,2)+pizda(2,1)
7661             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7662      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7663      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7664           enddo
7665         enddo
7666       enddo
7667 c      goto 1112
7668 c1111  continue
7669 C Contribution from graph II
7670       call transpose2(EE(1,1,itk),auxmat(1,1))
7671       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7672       vv(1)=pizda(1,1)+pizda(2,2)
7673       vv(2)=pizda(2,1)-pizda(1,2)
7674       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7675      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7676 C Explicit gradient in virtual-dihedral angles.
7677       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7678      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7679       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7680       vv(1)=pizda(1,1)+pizda(2,2)
7681       vv(2)=pizda(2,1)-pizda(1,2)
7682       if (l.eq.j+1) then
7683         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7684      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7685      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7686       else
7687         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7688      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7689      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7690       endif
7691 C Cartesian gradient
7692       do iii=1,2
7693         do kkk=1,5
7694           do lll=1,3
7695             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7696      &        pizda(1,1))
7697             vv(1)=pizda(1,1)+pizda(2,2)
7698             vv(2)=pizda(2,1)-pizda(1,2)
7699             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7700      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7701      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7702           enddo
7703         enddo
7704       enddo
7705 cd      goto 1112
7706 cd1111  continue
7707       if (l.eq.j+1) then
7708 cd        goto 1110
7709 C Parallel orientation
7710 C Contribution from graph III
7711         call transpose2(EUg(1,1,l),auxmat(1,1))
7712         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7713         vv(1)=pizda(1,1)-pizda(2,2)
7714         vv(2)=pizda(1,2)+pizda(2,1)
7715         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7716      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7717 C Explicit gradient in virtual-dihedral angles.
7718         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7719      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7720      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7721         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7722         vv(1)=pizda(1,1)-pizda(2,2)
7723         vv(2)=pizda(1,2)+pizda(2,1)
7724         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7725      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7726      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7727         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7728         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7729         vv(1)=pizda(1,1)-pizda(2,2)
7730         vv(2)=pizda(1,2)+pizda(2,1)
7731         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7732      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7734 C Cartesian gradient
7735         do iii=1,2
7736           do kkk=1,5
7737             do lll=1,3
7738               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7739      &          pizda(1,1))
7740               vv(1)=pizda(1,1)-pizda(2,2)
7741               vv(2)=pizda(1,2)+pizda(2,1)
7742               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7743      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7744      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7745             enddo
7746           enddo
7747         enddo
7748 cd        goto 1112
7749 C Contribution from graph IV
7750 cd1110    continue
7751         call transpose2(EE(1,1,itl),auxmat(1,1))
7752         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7753         vv(1)=pizda(1,1)+pizda(2,2)
7754         vv(2)=pizda(2,1)-pizda(1,2)
7755         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7756      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7757 C Explicit gradient in virtual-dihedral angles.
7758         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7759      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7760         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7761         vv(1)=pizda(1,1)+pizda(2,2)
7762         vv(2)=pizda(2,1)-pizda(1,2)
7763         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7764      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7765      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7766 C Cartesian gradient
7767         do iii=1,2
7768           do kkk=1,5
7769             do lll=1,3
7770               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7771      &          pizda(1,1))
7772               vv(1)=pizda(1,1)+pizda(2,2)
7773               vv(2)=pizda(2,1)-pizda(1,2)
7774               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7775      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7776      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7777             enddo
7778           enddo
7779         enddo
7780       else
7781 C Antiparallel orientation
7782 C Contribution from graph III
7783 c        goto 1110
7784         call transpose2(EUg(1,1,j),auxmat(1,1))
7785         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7786         vv(1)=pizda(1,1)-pizda(2,2)
7787         vv(2)=pizda(1,2)+pizda(2,1)
7788         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7789      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7790 C Explicit gradient in virtual-dihedral angles.
7791         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7792      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7793      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7794         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7795         vv(1)=pizda(1,1)-pizda(2,2)
7796         vv(2)=pizda(1,2)+pizda(2,1)
7797         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7798      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7799      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7800         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7801         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7802         vv(1)=pizda(1,1)-pizda(2,2)
7803         vv(2)=pizda(1,2)+pizda(2,1)
7804         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7805      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7806      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7807 C Cartesian gradient
7808         do iii=1,2
7809           do kkk=1,5
7810             do lll=1,3
7811               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7812      &          pizda(1,1))
7813               vv(1)=pizda(1,1)-pizda(2,2)
7814               vv(2)=pizda(1,2)+pizda(2,1)
7815               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7816      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7817      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7818             enddo
7819           enddo
7820         enddo
7821 cd        goto 1112
7822 C Contribution from graph IV
7823 1110    continue
7824         call transpose2(EE(1,1,itj),auxmat(1,1))
7825         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7826         vv(1)=pizda(1,1)+pizda(2,2)
7827         vv(2)=pizda(2,1)-pizda(1,2)
7828         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7829      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7830 C Explicit gradient in virtual-dihedral angles.
7831         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7832      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7833         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7834         vv(1)=pizda(1,1)+pizda(2,2)
7835         vv(2)=pizda(2,1)-pizda(1,2)
7836         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7837      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7838      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7839 C Cartesian gradient
7840         do iii=1,2
7841           do kkk=1,5
7842             do lll=1,3
7843               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7844      &          pizda(1,1))
7845               vv(1)=pizda(1,1)+pizda(2,2)
7846               vv(2)=pizda(2,1)-pizda(1,2)
7847               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7848      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7849      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7850             enddo
7851           enddo
7852         enddo
7853       endif
7854 1112  continue
7855       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7856 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7857 cd        write (2,*) 'ijkl',i,j,k,l
7858 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7859 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7860 cd      endif
7861 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7862 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7863 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7864 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7865       if (j.lt.nres-1) then
7866         j1=j+1
7867         j2=j-1
7868       else
7869         j1=j-1
7870         j2=j-2
7871       endif
7872       if (l.lt.nres-1) then
7873         l1=l+1
7874         l2=l-1
7875       else
7876         l1=l-1
7877         l2=l-2
7878       endif
7879 cd      eij=1.0d0
7880 cd      ekl=1.0d0
7881 cd      ekont=1.0d0
7882 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7883 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7884 C        summed up outside the subrouine as for the other subroutines
7885 C        handling long-range interactions. The old code is commented out
7886 C        with "cgrad" to keep track of changes.
7887       do ll=1,3
7888 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7889 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7890         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7891         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7892 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7893 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7894 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7895 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7896 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7897 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7898 c     &   gradcorr5ij,
7899 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7900 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7901 cgrad        ghalf=0.5d0*ggg1(ll)
7902 cd        ghalf=0.0d0
7903         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7904         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7905         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7906         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7907         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7908         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7909 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7910 cgrad        ghalf=0.5d0*ggg2(ll)
7911 cd        ghalf=0.0d0
7912         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7913         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7914         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7915         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7916         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7917         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7918       enddo
7919 cd      goto 1112
7920 cgrad      do m=i+1,j-1
7921 cgrad        do ll=1,3
7922 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7923 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7924 cgrad        enddo
7925 cgrad      enddo
7926 cgrad      do m=k+1,l-1
7927 cgrad        do ll=1,3
7928 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7929 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7930 cgrad        enddo
7931 cgrad      enddo
7932 c1112  continue
7933 cgrad      do m=i+2,j2
7934 cgrad        do ll=1,3
7935 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7936 cgrad        enddo
7937 cgrad      enddo
7938 cgrad      do m=k+2,l2
7939 cgrad        do ll=1,3
7940 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7941 cgrad        enddo
7942 cgrad      enddo
7943 cd      do iii=1,nres-3
7944 cd        write (2,*) iii,g_corr5_loc(iii)
7945 cd      enddo
7946       eello5=ekont*eel5
7947 cd      write (2,*) 'ekont',ekont
7948 cd      write (iout,*) 'eello5',ekont*eel5
7949       return
7950       end
7951 c--------------------------------------------------------------------------
7952       double precision function eello6(i,j,k,l,jj,kk)
7953       implicit real*8 (a-h,o-z)
7954       include 'DIMENSIONS'
7955       include 'COMMON.IOUNITS'
7956       include 'COMMON.CHAIN'
7957       include 'COMMON.DERIV'
7958       include 'COMMON.INTERACT'
7959       include 'COMMON.CONTACTS'
7960       include 'COMMON.TORSION'
7961       include 'COMMON.VAR'
7962       include 'COMMON.GEO'
7963       include 'COMMON.FFIELD'
7964       double precision ggg1(3),ggg2(3)
7965 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7966 cd        eello6=0.0d0
7967 cd        return
7968 cd      endif
7969 cd      write (iout,*)
7970 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7971 cd     &   ' and',k,l
7972       eello6_1=0.0d0
7973       eello6_2=0.0d0
7974       eello6_3=0.0d0
7975       eello6_4=0.0d0
7976       eello6_5=0.0d0
7977       eello6_6=0.0d0
7978 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7979 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7980       do iii=1,2
7981         do kkk=1,5
7982           do lll=1,3
7983             derx(lll,kkk,iii)=0.0d0
7984           enddo
7985         enddo
7986       enddo
7987 cd      eij=facont_hb(jj,i)
7988 cd      ekl=facont_hb(kk,k)
7989 cd      ekont=eij*ekl
7990 cd      eij=1.0d0
7991 cd      ekl=1.0d0
7992 cd      ekont=1.0d0
7993       if (l.eq.j+1) then
7994         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7995         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7996         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7997         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7998         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7999         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8000       else
8001         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8002         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8003         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8004         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8005         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8006           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8007         else
8008           eello6_5=0.0d0
8009         endif
8010         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8011       endif
8012 C If turn contributions are considered, they will be handled separately.
8013       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8014 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8015 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8016 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8017 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8018 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8019 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8020 cd      goto 1112
8021       if (j.lt.nres-1) then
8022         j1=j+1
8023         j2=j-1
8024       else
8025         j1=j-1
8026         j2=j-2
8027       endif
8028       if (l.lt.nres-1) then
8029         l1=l+1
8030         l2=l-1
8031       else
8032         l1=l-1
8033         l2=l-2
8034       endif
8035       do ll=1,3
8036 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8037 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8038 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8039 cgrad        ghalf=0.5d0*ggg1(ll)
8040 cd        ghalf=0.0d0
8041         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8042         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8043         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8044         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8045         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8046         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8047         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8048         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8049 cgrad        ghalf=0.5d0*ggg2(ll)
8050 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8051 cd        ghalf=0.0d0
8052         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8053         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8054         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8055         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8056         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8057         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8058       enddo
8059 cd      goto 1112
8060 cgrad      do m=i+1,j-1
8061 cgrad        do ll=1,3
8062 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8063 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8064 cgrad        enddo
8065 cgrad      enddo
8066 cgrad      do m=k+1,l-1
8067 cgrad        do ll=1,3
8068 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8069 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8070 cgrad        enddo
8071 cgrad      enddo
8072 cgrad1112  continue
8073 cgrad      do m=i+2,j2
8074 cgrad        do ll=1,3
8075 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8076 cgrad        enddo
8077 cgrad      enddo
8078 cgrad      do m=k+2,l2
8079 cgrad        do ll=1,3
8080 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8081 cgrad        enddo
8082 cgrad      enddo
8083 cd      do iii=1,nres-3
8084 cd        write (2,*) iii,g_corr6_loc(iii)
8085 cd      enddo
8086       eello6=ekont*eel6
8087 cd      write (2,*) 'ekont',ekont
8088 cd      write (iout,*) 'eello6',ekont*eel6
8089       return
8090       end
8091 c--------------------------------------------------------------------------
8092       double precision function eello6_graph1(i,j,k,l,imat,swap)
8093       implicit real*8 (a-h,o-z)
8094       include 'DIMENSIONS'
8095       include 'COMMON.IOUNITS'
8096       include 'COMMON.CHAIN'
8097       include 'COMMON.DERIV'
8098       include 'COMMON.INTERACT'
8099       include 'COMMON.CONTACTS'
8100       include 'COMMON.TORSION'
8101       include 'COMMON.VAR'
8102       include 'COMMON.GEO'
8103       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8104       logical swap
8105       logical lprn
8106       common /kutas/ lprn
8107 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8108 C
8109 C      Parallel       Antiparallel
8110 C
8111 C          o             o
8112 C         /l\           /j\
8113 C        /   \         /   \
8114 C       /| o |         | o |\
8115 C     \ j|/k\|  /   \  |/k\|l /
8116 C      \ /   \ /     \ /   \ /
8117 C       o     o       o     o
8118 C       i             i
8119 C
8120 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8121       itk=itortyp(itype(k))
8122       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8123       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8124       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8125       call transpose2(EUgC(1,1,k),auxmat(1,1))
8126       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8127       vv1(1)=pizda1(1,1)-pizda1(2,2)
8128       vv1(2)=pizda1(1,2)+pizda1(2,1)
8129       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8130       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8131       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8132       s5=scalar2(vv(1),Dtobr2(1,i))
8133 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8134       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8135       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8136      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8137      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8138      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8139      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8140      & +scalar2(vv(1),Dtobr2der(1,i)))
8141       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8142       vv1(1)=pizda1(1,1)-pizda1(2,2)
8143       vv1(2)=pizda1(1,2)+pizda1(2,1)
8144       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8145       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8146       if (l.eq.j+1) then
8147         g_corr6_loc(l-1)=g_corr6_loc(l-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       else
8153         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8154      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8155      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8156      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8157      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8158       endif
8159       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8160       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8161       vv1(1)=pizda1(1,1)-pizda1(2,2)
8162       vv1(2)=pizda1(1,2)+pizda1(2,1)
8163       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8164      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8165      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8166      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8167       do iii=1,2
8168         if (swap) then
8169           ind=3-iii
8170         else
8171           ind=iii
8172         endif
8173         do kkk=1,5
8174           do lll=1,3
8175             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8176             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8177             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8178             call transpose2(EUgC(1,1,k),auxmat(1,1))
8179             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8180      &        pizda1(1,1))
8181             vv1(1)=pizda1(1,1)-pizda1(2,2)
8182             vv1(2)=pizda1(1,2)+pizda1(2,1)
8183             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8184             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8185      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8186             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8187      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8188             s5=scalar2(vv(1),Dtobr2(1,i))
8189             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8190           enddo
8191         enddo
8192       enddo
8193       return
8194       end
8195 c----------------------------------------------------------------------------
8196       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8197       implicit real*8 (a-h,o-z)
8198       include 'DIMENSIONS'
8199       include 'COMMON.IOUNITS'
8200       include 'COMMON.CHAIN'
8201       include 'COMMON.DERIV'
8202       include 'COMMON.INTERACT'
8203       include 'COMMON.CONTACTS'
8204       include 'COMMON.TORSION'
8205       include 'COMMON.VAR'
8206       include 'COMMON.GEO'
8207       logical swap
8208       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8209      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8210       logical lprn
8211       common /kutas/ lprn
8212 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8213 C                                                                              C
8214 C      Parallel       Antiparallel                                             C
8215 C                                                                              C
8216 C          o             o                                                     C
8217 C     \   /l\           /j\   /                                                C
8218 C      \ /   \         /   \ /                                                 C
8219 C       o| o |         | o |o                                                  C
8220 C     \ j|/k\|      \  |/k\|l                                                  C
8221 C      \ /   \       \ /   \                                                   C
8222 C       o             o                                                        C
8223 C       i             i                                                        C
8224 C                                                                              C
8225 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8226 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8227 C AL 7/4/01 s1 would occur in the sixth-order moment,
8228 C           but not in a cluster cumulant
8229 #ifdef MOMENT
8230       s1=dip(1,jj,i)*dip(1,kk,k)
8231 #endif
8232       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8233       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8234       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8235       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8236       call transpose2(EUg(1,1,k),auxmat(1,1))
8237       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8238       vv(1)=pizda(1,1)-pizda(2,2)
8239       vv(2)=pizda(1,2)+pizda(2,1)
8240       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8241 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8242 #ifdef MOMENT
8243       eello6_graph2=-(s1+s2+s3+s4)
8244 #else
8245       eello6_graph2=-(s2+s3+s4)
8246 #endif
8247 c      eello6_graph2=-s3
8248 C Derivatives in gamma(i-1)
8249       if (i.gt.1) then
8250 #ifdef MOMENT
8251         s1=dipderg(1,jj,i)*dip(1,kk,k)
8252 #endif
8253         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8254         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8255         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8256         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8257 #ifdef MOMENT
8258         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8259 #else
8260         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8261 #endif
8262 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8263       endif
8264 C Derivatives in gamma(k-1)
8265 #ifdef MOMENT
8266       s1=dip(1,jj,i)*dipderg(1,kk,k)
8267 #endif
8268       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8269       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8270       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8271       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8272       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8273       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8274       vv(1)=pizda(1,1)-pizda(2,2)
8275       vv(2)=pizda(1,2)+pizda(2,1)
8276       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8277 #ifdef MOMENT
8278       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8279 #else
8280       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8281 #endif
8282 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8283 C Derivatives in gamma(j-1) or gamma(l-1)
8284       if (j.gt.1) then
8285 #ifdef MOMENT
8286         s1=dipderg(3,jj,i)*dip(1,kk,k)
8287 #endif
8288         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8289         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8290         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8291         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8292         vv(1)=pizda(1,1)-pizda(2,2)
8293         vv(2)=pizda(1,2)+pizda(2,1)
8294         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8295 #ifdef MOMENT
8296         if (swap) then
8297           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8298         else
8299           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8300         endif
8301 #endif
8302         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8303 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8304       endif
8305 C Derivatives in gamma(l-1) or gamma(j-1)
8306       if (l.gt.1) then
8307 #ifdef MOMENT
8308         s1=dip(1,jj,i)*dipderg(3,kk,k)
8309 #endif
8310         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8311         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8312         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8313         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8314         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8315         vv(1)=pizda(1,1)-pizda(2,2)
8316         vv(2)=pizda(1,2)+pizda(2,1)
8317         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8318 #ifdef MOMENT
8319         if (swap) then
8320           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8321         else
8322           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8323         endif
8324 #endif
8325         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8326 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8327       endif
8328 C Cartesian derivatives.
8329       if (lprn) then
8330         write (2,*) 'In eello6_graph2'
8331         do iii=1,2
8332           write (2,*) 'iii=',iii
8333           do kkk=1,5
8334             write (2,*) 'kkk=',kkk
8335             do jjj=1,2
8336               write (2,'(3(2f10.5),5x)')
8337      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8338             enddo
8339           enddo
8340         enddo
8341       endif
8342       do iii=1,2
8343         do kkk=1,5
8344           do lll=1,3
8345 #ifdef MOMENT
8346             if (iii.eq.1) then
8347               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8348             else
8349               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8350             endif
8351 #endif
8352             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8353      &        auxvec(1))
8354             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8355             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8356      &        auxvec(1))
8357             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8358             call transpose2(EUg(1,1,k),auxmat(1,1))
8359             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8360      &        pizda(1,1))
8361             vv(1)=pizda(1,1)-pizda(2,2)
8362             vv(2)=pizda(1,2)+pizda(2,1)
8363             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8364 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8365 #ifdef MOMENT
8366             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8367 #else
8368             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8369 #endif
8370             if (swap) then
8371               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8372             else
8373               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8374             endif
8375           enddo
8376         enddo
8377       enddo
8378       return
8379       end
8380 c----------------------------------------------------------------------------
8381       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8382       implicit real*8 (a-h,o-z)
8383       include 'DIMENSIONS'
8384       include 'COMMON.IOUNITS'
8385       include 'COMMON.CHAIN'
8386       include 'COMMON.DERIV'
8387       include 'COMMON.INTERACT'
8388       include 'COMMON.CONTACTS'
8389       include 'COMMON.TORSION'
8390       include 'COMMON.VAR'
8391       include 'COMMON.GEO'
8392       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8393       logical swap
8394 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8395 C                                                                              C
8396 C      Parallel       Antiparallel                                             C
8397 C                                                                              C
8398 C          o             o                                                     C
8399 C         /l\   /   \   /j\                                                    C
8400 C        /   \ /     \ /   \                                                   C
8401 C       /| o |o       o| o |\                                                  C
8402 C       j|/k\|  /      |/k\|l /                                                C
8403 C        /   \ /       /   \ /                                                 C
8404 C       /     o       /     o                                                  C
8405 C       i             i                                                        C
8406 C                                                                              C
8407 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8408 C
8409 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8410 C           energy moment and not to the cluster cumulant.
8411       iti=itortyp(itype(i))
8412       if (j.lt.nres-1) then
8413         itj1=itortyp(itype(j+1))
8414       else
8415         itj1=ntortyp+1
8416       endif
8417       itk=itortyp(itype(k))
8418       itk1=itortyp(itype(k+1))
8419       if (l.lt.nres-1) then
8420         itl1=itortyp(itype(l+1))
8421       else
8422         itl1=ntortyp+1
8423       endif
8424 #ifdef MOMENT
8425       s1=dip(4,jj,i)*dip(4,kk,k)
8426 #endif
8427       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8428       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8429       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8430       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8431       call transpose2(EE(1,1,itk),auxmat(1,1))
8432       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8433       vv(1)=pizda(1,1)+pizda(2,2)
8434       vv(2)=pizda(2,1)-pizda(1,2)
8435       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8436 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8437 cd     & "sum",-(s2+s3+s4)
8438 #ifdef MOMENT
8439       eello6_graph3=-(s1+s2+s3+s4)
8440 #else
8441       eello6_graph3=-(s2+s3+s4)
8442 #endif
8443 c      eello6_graph3=-s4
8444 C Derivatives in gamma(k-1)
8445       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8446       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8447       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8448       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8449 C Derivatives in gamma(l-1)
8450       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8451       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8452       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8453       vv(1)=pizda(1,1)+pizda(2,2)
8454       vv(2)=pizda(2,1)-pizda(1,2)
8455       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8456       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8457 C Cartesian derivatives.
8458       do iii=1,2
8459         do kkk=1,5
8460           do lll=1,3
8461 #ifdef MOMENT
8462             if (iii.eq.1) then
8463               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8464             else
8465               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8466             endif
8467 #endif
8468             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8469      &        auxvec(1))
8470             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8471             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8472      &        auxvec(1))
8473             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8474             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8475      &        pizda(1,1))
8476             vv(1)=pizda(1,1)+pizda(2,2)
8477             vv(2)=pizda(2,1)-pizda(1,2)
8478             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8479 #ifdef MOMENT
8480             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8481 #else
8482             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8483 #endif
8484             if (swap) then
8485               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8486             else
8487               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8488             endif
8489 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8490           enddo
8491         enddo
8492       enddo
8493       return
8494       end
8495 c----------------------------------------------------------------------------
8496       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8497       implicit real*8 (a-h,o-z)
8498       include 'DIMENSIONS'
8499       include 'COMMON.IOUNITS'
8500       include 'COMMON.CHAIN'
8501       include 'COMMON.DERIV'
8502       include 'COMMON.INTERACT'
8503       include 'COMMON.CONTACTS'
8504       include 'COMMON.TORSION'
8505       include 'COMMON.VAR'
8506       include 'COMMON.GEO'
8507       include 'COMMON.FFIELD'
8508       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8509      & auxvec1(2),auxmat1(2,2)
8510       logical swap
8511 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8512 C                                                                              C
8513 C      Parallel       Antiparallel                                             C
8514 C                                                                              C
8515 C          o             o                                                     C
8516 C         /l\   /   \   /j\                                                    C
8517 C        /   \ /     \ /   \                                                   C
8518 C       /| o |o       o| o |\                                                  C
8519 C     \ j|/k\|      \  |/k\|l                                                  C
8520 C      \ /   \       \ /   \                                                   C
8521 C       o     \       o     \                                                  C
8522 C       i             i                                                        C
8523 C                                                                              C
8524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8525 C
8526 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8527 C           energy moment and not to the cluster cumulant.
8528 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8529       iti=itortyp(itype(i))
8530       itj=itortyp(itype(j))
8531       if (j.lt.nres-1) then
8532         itj1=itortyp(itype(j+1))
8533       else
8534         itj1=ntortyp+1
8535       endif
8536       itk=itortyp(itype(k))
8537       if (k.lt.nres-1) then
8538         itk1=itortyp(itype(k+1))
8539       else
8540         itk1=ntortyp+1
8541       endif
8542       itl=itortyp(itype(l))
8543       if (l.lt.nres-1) then
8544         itl1=itortyp(itype(l+1))
8545       else
8546         itl1=ntortyp+1
8547       endif
8548 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8549 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8550 cd     & ' itl',itl,' itl1',itl1
8551 #ifdef MOMENT
8552       if (imat.eq.1) then
8553         s1=dip(3,jj,i)*dip(3,kk,k)
8554       else
8555         s1=dip(2,jj,j)*dip(2,kk,l)
8556       endif
8557 #endif
8558       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8559       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8560       if (j.eq.l+1) then
8561         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8562         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8563       else
8564         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8565         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8566       endif
8567       call transpose2(EUg(1,1,k),auxmat(1,1))
8568       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8569       vv(1)=pizda(1,1)-pizda(2,2)
8570       vv(2)=pizda(2,1)+pizda(1,2)
8571       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8572 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8573 #ifdef MOMENT
8574       eello6_graph4=-(s1+s2+s3+s4)
8575 #else
8576       eello6_graph4=-(s2+s3+s4)
8577 #endif
8578 C Derivatives in gamma(i-1)
8579       if (i.gt.1) then
8580 #ifdef MOMENT
8581         if (imat.eq.1) then
8582           s1=dipderg(2,jj,i)*dip(3,kk,k)
8583         else
8584           s1=dipderg(4,jj,j)*dip(2,kk,l)
8585         endif
8586 #endif
8587         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8588         if (j.eq.l+1) then
8589           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8590           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8591         else
8592           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8593           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8594         endif
8595         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8596         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8597 cd          write (2,*) 'turn6 derivatives'
8598 #ifdef MOMENT
8599           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8600 #else
8601           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8602 #endif
8603         else
8604 #ifdef MOMENT
8605           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8606 #else
8607           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8608 #endif
8609         endif
8610       endif
8611 C Derivatives in gamma(k-1)
8612 #ifdef MOMENT
8613       if (imat.eq.1) then
8614         s1=dip(3,jj,i)*dipderg(2,kk,k)
8615       else
8616         s1=dip(2,jj,j)*dipderg(4,kk,l)
8617       endif
8618 #endif
8619       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8620       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8621       if (j.eq.l+1) then
8622         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8623         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8624       else
8625         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8626         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8627       endif
8628       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8629       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8630       vv(1)=pizda(1,1)-pizda(2,2)
8631       vv(2)=pizda(2,1)+pizda(1,2)
8632       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8633       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8634 #ifdef MOMENT
8635         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8636 #else
8637         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8638 #endif
8639       else
8640 #ifdef MOMENT
8641         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8642 #else
8643         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8644 #endif
8645       endif
8646 C Derivatives in gamma(j-1) or gamma(l-1)
8647       if (l.eq.j+1 .and. l.gt.1) then
8648         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8649         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8650         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8651         vv(1)=pizda(1,1)-pizda(2,2)
8652         vv(2)=pizda(2,1)+pizda(1,2)
8653         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8654         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8655       else if (j.gt.1) then
8656         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8657         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8658         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8659         vv(1)=pizda(1,1)-pizda(2,2)
8660         vv(2)=pizda(2,1)+pizda(1,2)
8661         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8662         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8663           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8664         else
8665           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8666         endif
8667       endif
8668 C Cartesian derivatives.
8669       do iii=1,2
8670         do kkk=1,5
8671           do lll=1,3
8672 #ifdef MOMENT
8673             if (iii.eq.1) then
8674               if (imat.eq.1) then
8675                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8676               else
8677                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8678               endif
8679             else
8680               if (imat.eq.1) then
8681                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8682               else
8683                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8684               endif
8685             endif
8686 #endif
8687             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8688      &        auxvec(1))
8689             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8690             if (j.eq.l+1) then
8691               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8692      &          b1(1,itj1),auxvec(1))
8693               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8694             else
8695               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8696      &          b1(1,itl1),auxvec(1))
8697               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8698             endif
8699             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8700      &        pizda(1,1))
8701             vv(1)=pizda(1,1)-pizda(2,2)
8702             vv(2)=pizda(2,1)+pizda(1,2)
8703             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8704             if (swap) then
8705               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8706 #ifdef MOMENT
8707                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8708      &             -(s1+s2+s4)
8709 #else
8710                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8711      &             -(s2+s4)
8712 #endif
8713                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8714               else
8715 #ifdef MOMENT
8716                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8717 #else
8718                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8719 #endif
8720                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8721               endif
8722             else
8723 #ifdef MOMENT
8724               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8725 #else
8726               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8727 #endif
8728               if (l.eq.j+1) then
8729                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8730               else
8731                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8732               endif
8733             endif
8734           enddo
8735         enddo
8736       enddo
8737       return
8738       end
8739 c----------------------------------------------------------------------------
8740       double precision function eello_turn6(i,jj,kk)
8741       implicit real*8 (a-h,o-z)
8742       include 'DIMENSIONS'
8743       include 'COMMON.IOUNITS'
8744       include 'COMMON.CHAIN'
8745       include 'COMMON.DERIV'
8746       include 'COMMON.INTERACT'
8747       include 'COMMON.CONTACTS'
8748       include 'COMMON.TORSION'
8749       include 'COMMON.VAR'
8750       include 'COMMON.GEO'
8751       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8752      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8753      &  ggg1(3),ggg2(3)
8754       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8755      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8756 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8757 C           the respective energy moment and not to the cluster cumulant.
8758       s1=0.0d0
8759       s8=0.0d0
8760       s13=0.0d0
8761 c
8762       eello_turn6=0.0d0
8763       j=i+4
8764       k=i+1
8765       l=i+3
8766       iti=itortyp(itype(i))
8767       itk=itortyp(itype(k))
8768       itk1=itortyp(itype(k+1))
8769       itl=itortyp(itype(l))
8770       itj=itortyp(itype(j))
8771 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8772 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8773 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8774 cd        eello6=0.0d0
8775 cd        return
8776 cd      endif
8777 cd      write (iout,*)
8778 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8779 cd     &   ' and',k,l
8780 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8781       do iii=1,2
8782         do kkk=1,5
8783           do lll=1,3
8784             derx_turn(lll,kkk,iii)=0.0d0
8785           enddo
8786         enddo
8787       enddo
8788 cd      eij=1.0d0
8789 cd      ekl=1.0d0
8790 cd      ekont=1.0d0
8791       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8792 cd      eello6_5=0.0d0
8793 cd      write (2,*) 'eello6_5',eello6_5
8794 #ifdef MOMENT
8795       call transpose2(AEA(1,1,1),auxmat(1,1))
8796       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8797       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8798       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8799 #endif
8800       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8801       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8802       s2 = scalar2(b1(1,itk),vtemp1(1))
8803 #ifdef MOMENT
8804       call transpose2(AEA(1,1,2),atemp(1,1))
8805       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8806       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8807       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8808 #endif
8809       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8810       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8811       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8812 #ifdef MOMENT
8813       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8814       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8815       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8816       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8817       ss13 = scalar2(b1(1,itk),vtemp4(1))
8818       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8819 #endif
8820 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8821 c      s1=0.0d0
8822 c      s2=0.0d0
8823 c      s8=0.0d0
8824 c      s12=0.0d0
8825 c      s13=0.0d0
8826       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8827 C Derivatives in gamma(i+2)
8828       s1d =0.0d0
8829       s8d =0.0d0
8830 #ifdef MOMENT
8831       call transpose2(AEA(1,1,1),auxmatd(1,1))
8832       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8833       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8834       call transpose2(AEAderg(1,1,2),atempd(1,1))
8835       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8836       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8837 #endif
8838       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8839       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8840       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8841 c      s1d=0.0d0
8842 c      s2d=0.0d0
8843 c      s8d=0.0d0
8844 c      s12d=0.0d0
8845 c      s13d=0.0d0
8846       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8847 C Derivatives in gamma(i+3)
8848 #ifdef MOMENT
8849       call transpose2(AEA(1,1,1),auxmatd(1,1))
8850       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8851       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8852       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8853 #endif
8854       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8855       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8856       s2d = scalar2(b1(1,itk),vtemp1d(1))
8857 #ifdef MOMENT
8858       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8859       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8860 #endif
8861       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8862 #ifdef MOMENT
8863       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8864       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8865       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8866 #endif
8867 c      s1d=0.0d0
8868 c      s2d=0.0d0
8869 c      s8d=0.0d0
8870 c      s12d=0.0d0
8871 c      s13d=0.0d0
8872 #ifdef MOMENT
8873       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8874      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8875 #else
8876       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8877      &               -0.5d0*ekont*(s2d+s12d)
8878 #endif
8879 C Derivatives in gamma(i+4)
8880       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8881       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8882       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8883 #ifdef MOMENT
8884       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8885       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8886       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8887 #endif
8888 c      s1d=0.0d0
8889 c      s2d=0.0d0
8890 c      s8d=0.0d0
8891 C      s12d=0.0d0
8892 c      s13d=0.0d0
8893 #ifdef MOMENT
8894       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8895 #else
8896       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8897 #endif
8898 C Derivatives in gamma(i+5)
8899 #ifdef MOMENT
8900       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8901       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8902       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8903 #endif
8904       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8905       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8906       s2d = scalar2(b1(1,itk),vtemp1d(1))
8907 #ifdef MOMENT
8908       call transpose2(AEA(1,1,2),atempd(1,1))
8909       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8910       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8911 #endif
8912       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8913       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8914 #ifdef MOMENT
8915       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8916       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8917       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8918 #endif
8919 c      s1d=0.0d0
8920 c      s2d=0.0d0
8921 c      s8d=0.0d0
8922 c      s12d=0.0d0
8923 c      s13d=0.0d0
8924 #ifdef MOMENT
8925       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8926      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8927 #else
8928       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8929      &               -0.5d0*ekont*(s2d+s12d)
8930 #endif
8931 C Cartesian derivatives
8932       do iii=1,2
8933         do kkk=1,5
8934           do lll=1,3
8935 #ifdef MOMENT
8936             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8937             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8938             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8939 #endif
8940             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8941             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8942      &          vtemp1d(1))
8943             s2d = scalar2(b1(1,itk),vtemp1d(1))
8944 #ifdef MOMENT
8945             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8946             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8947             s8d = -(atempd(1,1)+atempd(2,2))*
8948      &           scalar2(cc(1,1,itl),vtemp2(1))
8949 #endif
8950             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8951      &           auxmatd(1,1))
8952             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8953             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8954 c      s1d=0.0d0
8955 c      s2d=0.0d0
8956 c      s8d=0.0d0
8957 c      s12d=0.0d0
8958 c      s13d=0.0d0
8959 #ifdef MOMENT
8960             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8961      &        - 0.5d0*(s1d+s2d)
8962 #else
8963             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8964      &        - 0.5d0*s2d
8965 #endif
8966 #ifdef MOMENT
8967             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8968      &        - 0.5d0*(s8d+s12d)
8969 #else
8970             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8971      &        - 0.5d0*s12d
8972 #endif
8973           enddo
8974         enddo
8975       enddo
8976 #ifdef MOMENT
8977       do kkk=1,5
8978         do lll=1,3
8979           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8980      &      achuj_tempd(1,1))
8981           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8982           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8983           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8984           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8985           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8986      &      vtemp4d(1))
8987           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8988           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8989           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8990         enddo
8991       enddo
8992 #endif
8993 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8994 cd     &  16*eel_turn6_num
8995 cd      goto 1112
8996       if (j.lt.nres-1) then
8997         j1=j+1
8998         j2=j-1
8999       else
9000         j1=j-1
9001         j2=j-2
9002       endif
9003       if (l.lt.nres-1) then
9004         l1=l+1
9005         l2=l-1
9006       else
9007         l1=l-1
9008         l2=l-2
9009       endif
9010       do ll=1,3
9011 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9012 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9013 cgrad        ghalf=0.5d0*ggg1(ll)
9014 cd        ghalf=0.0d0
9015         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9016         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9017         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9018      &    +ekont*derx_turn(ll,2,1)
9019         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9020         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9021      &    +ekont*derx_turn(ll,4,1)
9022         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9023         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9024         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9025 cgrad        ghalf=0.5d0*ggg2(ll)
9026 cd        ghalf=0.0d0
9027         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9028      &    +ekont*derx_turn(ll,2,2)
9029         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9030         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9031      &    +ekont*derx_turn(ll,4,2)
9032         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9033         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9034         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9035       enddo
9036 cd      goto 1112
9037 cgrad      do m=i+1,j-1
9038 cgrad        do ll=1,3
9039 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9040 cgrad        enddo
9041 cgrad      enddo
9042 cgrad      do m=k+1,l-1
9043 cgrad        do ll=1,3
9044 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9045 cgrad        enddo
9046 cgrad      enddo
9047 cgrad1112  continue
9048 cgrad      do m=i+2,j2
9049 cgrad        do ll=1,3
9050 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9051 cgrad        enddo
9052 cgrad      enddo
9053 cgrad      do m=k+2,l2
9054 cgrad        do ll=1,3
9055 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9056 cgrad        enddo
9057 cgrad      enddo
9058 cd      do iii=1,nres-3
9059 cd        write (2,*) iii,g_corr6_loc(iii)
9060 cd      enddo
9061       eello_turn6=ekont*eel_turn6
9062 cd      write (2,*) 'ekont',ekont
9063 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9064       return
9065       end
9066
9067 C-----------------------------------------------------------------------------
9068       double precision function scalar(u,v)
9069 !DIR$ INLINEALWAYS scalar
9070 #ifndef OSF
9071 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9072 #endif
9073       implicit none
9074       double precision u(3),v(3)
9075 cd      double precision sc
9076 cd      integer i
9077 cd      sc=0.0d0
9078 cd      do i=1,3
9079 cd        sc=sc+u(i)*v(i)
9080 cd      enddo
9081 cd      scalar=sc
9082
9083       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9084       return
9085       end
9086 crc-------------------------------------------------
9087       SUBROUTINE MATVEC2(A1,V1,V2)
9088 !DIR$ INLINEALWAYS MATVEC2
9089 #ifndef OSF
9090 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9091 #endif
9092       implicit real*8 (a-h,o-z)
9093       include 'DIMENSIONS'
9094       DIMENSION A1(2,2),V1(2),V2(2)
9095 c      DO 1 I=1,2
9096 c        VI=0.0
9097 c        DO 3 K=1,2
9098 c    3     VI=VI+A1(I,K)*V1(K)
9099 c        Vaux(I)=VI
9100 c    1 CONTINUE
9101
9102       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9103       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9104
9105       v2(1)=vaux1
9106       v2(2)=vaux2
9107       END
9108 C---------------------------------------
9109       SUBROUTINE MATMAT2(A1,A2,A3)
9110 #ifndef OSF
9111 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9112 #endif
9113       implicit real*8 (a-h,o-z)
9114       include 'DIMENSIONS'
9115       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9116 c      DIMENSION AI3(2,2)
9117 c        DO  J=1,2
9118 c          A3IJ=0.0
9119 c          DO K=1,2
9120 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9121 c          enddo
9122 c          A3(I,J)=A3IJ
9123 c       enddo
9124 c      enddo
9125
9126       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9127       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9128       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9129       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9130
9131       A3(1,1)=AI3_11
9132       A3(2,1)=AI3_21
9133       A3(1,2)=AI3_12
9134       A3(2,2)=AI3_22
9135       END
9136
9137 c-------------------------------------------------------------------------
9138       double precision function scalar2(u,v)
9139 !DIR$ INLINEALWAYS scalar2
9140       implicit none
9141       double precision u(2),v(2)
9142       double precision sc
9143       integer i
9144       scalar2=u(1)*v(1)+u(2)*v(2)
9145       return
9146       end
9147
9148 C-----------------------------------------------------------------------------
9149
9150       subroutine transpose2(a,at)
9151 !DIR$ INLINEALWAYS transpose2
9152 #ifndef OSF
9153 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9154 #endif
9155       implicit none
9156       double precision a(2,2),at(2,2)
9157       at(1,1)=a(1,1)
9158       at(1,2)=a(2,1)
9159       at(2,1)=a(1,2)
9160       at(2,2)=a(2,2)
9161       return
9162       end
9163 c--------------------------------------------------------------------------
9164       subroutine transpose(n,a,at)
9165       implicit none
9166       integer n,i,j
9167       double precision a(n,n),at(n,n)
9168       do i=1,n
9169         do j=1,n
9170           at(j,i)=a(i,j)
9171         enddo
9172       enddo
9173       return
9174       end
9175 C---------------------------------------------------------------------------
9176       subroutine prodmat3(a1,a2,kk,transp,prod)
9177 !DIR$ INLINEALWAYS prodmat3
9178 #ifndef OSF
9179 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9180 #endif
9181       implicit none
9182       integer i,j
9183       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9184       logical transp
9185 crc      double precision auxmat(2,2),prod_(2,2)
9186
9187       if (transp) then
9188 crc        call transpose2(kk(1,1),auxmat(1,1))
9189 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9190 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9191
9192            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9193      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9194            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9195      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9196            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9197      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9198            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9199      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9200
9201       else
9202 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9203 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9204
9205            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9206      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9207            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9208      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9209            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9210      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9211            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9212      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9213
9214       endif
9215 c      call transpose2(a2(1,1),a2t(1,1))
9216
9217 crc      print *,transp
9218 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9219 crc      print *,((prod(i,j),i=1,2),j=1,2)
9220
9221       return
9222       end
9223