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+nss*ebr+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+nss*ebr+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=',1pD16.6,' (SC-SC)'/
1061      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1062      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1063      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1064      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1065      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1066      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1067      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1068      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1069      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1070      & ' (SS bridges & dist. cnstr.)'/
1071      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1072      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1073      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1074      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1075      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1076      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1077      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1078      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.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             ELSE
1593             ind=ind+1
1594             itypj=itype(j)
1595 c            dscj_inv=dsc_inv(itypj)
1596             dscj_inv=vbld_inv(j+nres)
1597 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1598 c     &       1.0d0/vbld(j+nres)
1599 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1600             sig0ij=sigma(itypi,itypj)
1601             chi1=chi(itypi,itypj)
1602             chi2=chi(itypj,itypi)
1603             chi12=chi1*chi2
1604             chip1=chip(itypi)
1605             chip2=chip(itypj)
1606             chip12=chip1*chip2
1607             alf1=alp(itypi)
1608             alf2=alp(itypj)
1609             alf12=0.5D0*(alf1+alf2)
1610 C For diagnostics only!!!
1611 c           chi1=0.0D0
1612 c           chi2=0.0D0
1613 c           chi12=0.0D0
1614 c           chip1=0.0D0
1615 c           chip2=0.0D0
1616 c           chip12=0.0D0
1617 c           alf1=0.0D0
1618 c           alf2=0.0D0
1619 c           alf12=0.0D0
1620             xj=c(1,nres+j)-xi
1621             yj=c(2,nres+j)-yi
1622             zj=c(3,nres+j)-zi
1623             dxj=dc_norm(1,nres+j)
1624             dyj=dc_norm(2,nres+j)
1625             dzj=dc_norm(3,nres+j)
1626 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1627 c            write (iout,*) "j",j," dc_norm",
1628 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1629             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1630             rij=dsqrt(rrij)
1631 C Calculate angle-dependent terms of energy and contributions to their
1632 C derivatives.
1633             call sc_angular
1634             sigsq=1.0D0/sigsq
1635             sig=sig0ij*dsqrt(sigsq)
1636             rij_shift=1.0D0/rij-sig+sig0ij
1637 c for diagnostics; uncomment
1638 c            rij_shift=1.2*sig0ij
1639 C I hate to put IF's in the loops, but here don't have another choice!!!!
1640             if (rij_shift.le.0.0D0) then
1641               evdw=1.0D20
1642 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1643 cd     &        restyp(itypi),i,restyp(itypj),j,
1644 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1645               return
1646             endif
1647             sigder=-sig*sigsq
1648 c---------------------------------------------------------------
1649             rij_shift=1.0D0/rij_shift
1650             fac=rij_shift**expon
1651             e1=fac*fac*aa(itypi,itypj)
1652             e2=fac*bb(itypi,itypj)
1653             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1654             eps2der=evdwij*eps3rt
1655             eps3der=evdwij*eps2rt
1656 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1657 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1658             evdwij=evdwij*eps2rt*eps3rt
1659 #ifdef TSCSC
1660             if (bb(itypi,itypj).gt.0) then
1661                evdw_p=evdw_p+evdwij
1662             else
1663                evdw_m=evdw_m+evdwij
1664             endif
1665 #else
1666             evdw=evdw+evdwij
1667 #endif
1668             if (lprn) then
1669             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1670             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1671             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1672      &        restyp(itypi),i,restyp(itypj),j,
1673      &        epsi,sigm,chi1,chi2,chip1,chip2,
1674      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1675      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1676      &        evdwij
1677             endif
1678
1679             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1680      &                        'evdw',i,j,evdwij
1681
1682 C Calculate gradient components.
1683             e1=e1*eps1*eps2rt**2*eps3rt**2
1684             fac=-expon*(e1+evdwij)*rij_shift
1685             sigder=fac*sigder
1686             fac=rij*fac
1687 c            fac=0.0d0
1688 C Calculate the radial part of the gradient
1689             gg(1)=xj*fac
1690             gg(2)=yj*fac
1691             gg(3)=zj*fac
1692 C Calculate angular part of the gradient.
1693 #ifdef TSCSC
1694             if (bb(itypi,itypj).gt.0) then
1695                call sc_grad
1696             else
1697                call sc_grad_T
1698             endif
1699 #else
1700             call sc_grad
1701 #endif
1702             ENDIF    ! dyn_ss
1703           enddo      ! j
1704         enddo        ! iint
1705       enddo          ! i
1706 c      write (iout,*) "Number of loop steps in EGB:",ind
1707 cccc      energy_dec=.false.
1708       return
1709       end
1710 C-----------------------------------------------------------------------------
1711       subroutine egbv(evdw,evdw_p,evdw_m)
1712 C
1713 C This subroutine calculates the interaction energy of nonbonded side chains
1714 C assuming the Gay-Berne-Vorobjev potential of interaction.
1715 C
1716       implicit real*8 (a-h,o-z)
1717       include 'DIMENSIONS'
1718       include 'COMMON.GEO'
1719       include 'COMMON.VAR'
1720       include 'COMMON.LOCAL'
1721       include 'COMMON.CHAIN'
1722       include 'COMMON.DERIV'
1723       include 'COMMON.NAMES'
1724       include 'COMMON.INTERACT'
1725       include 'COMMON.IOUNITS'
1726       include 'COMMON.CALC'
1727       common /srutu/ icall
1728       logical lprn
1729       evdw=0.0D0
1730 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1731       evdw=0.0D0
1732       lprn=.false.
1733 c     if (icall.eq.0) lprn=.true.
1734       ind=0
1735       do i=iatsc_s,iatsc_e
1736         itypi=itype(i)
1737         itypi1=itype(i+1)
1738         xi=c(1,nres+i)
1739         yi=c(2,nres+i)
1740         zi=c(3,nres+i)
1741         dxi=dc_norm(1,nres+i)
1742         dyi=dc_norm(2,nres+i)
1743         dzi=dc_norm(3,nres+i)
1744 c        dsci_inv=dsc_inv(itypi)
1745         dsci_inv=vbld_inv(i+nres)
1746 C
1747 C Calculate SC interaction energy.
1748 C
1749         do iint=1,nint_gr(i)
1750           do j=istart(i,iint),iend(i,iint)
1751             ind=ind+1
1752             itypj=itype(j)
1753 c            dscj_inv=dsc_inv(itypj)
1754             dscj_inv=vbld_inv(j+nres)
1755             sig0ij=sigma(itypi,itypj)
1756             r0ij=r0(itypi,itypj)
1757             chi1=chi(itypi,itypj)
1758             chi2=chi(itypj,itypi)
1759             chi12=chi1*chi2
1760             chip1=chip(itypi)
1761             chip2=chip(itypj)
1762             chip12=chip1*chip2
1763             alf1=alp(itypi)
1764             alf2=alp(itypj)
1765             alf12=0.5D0*(alf1+alf2)
1766 C For diagnostics only!!!
1767 c           chi1=0.0D0
1768 c           chi2=0.0D0
1769 c           chi12=0.0D0
1770 c           chip1=0.0D0
1771 c           chip2=0.0D0
1772 c           chip12=0.0D0
1773 c           alf1=0.0D0
1774 c           alf2=0.0D0
1775 c           alf12=0.0D0
1776             xj=c(1,nres+j)-xi
1777             yj=c(2,nres+j)-yi
1778             zj=c(3,nres+j)-zi
1779             dxj=dc_norm(1,nres+j)
1780             dyj=dc_norm(2,nres+j)
1781             dzj=dc_norm(3,nres+j)
1782             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1783             rij=dsqrt(rrij)
1784 C Calculate angle-dependent terms of energy and contributions to their
1785 C derivatives.
1786             call sc_angular
1787             sigsq=1.0D0/sigsq
1788             sig=sig0ij*dsqrt(sigsq)
1789             rij_shift=1.0D0/rij-sig+r0ij
1790 C I hate to put IF's in the loops, but here don't have another choice!!!!
1791             if (rij_shift.le.0.0D0) then
1792               evdw=1.0D20
1793               return
1794             endif
1795             sigder=-sig*sigsq
1796 c---------------------------------------------------------------
1797             rij_shift=1.0D0/rij_shift
1798             fac=rij_shift**expon
1799             e1=fac*fac*aa(itypi,itypj)
1800             e2=fac*bb(itypi,itypj)
1801             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1802             eps2der=evdwij*eps3rt
1803             eps3der=evdwij*eps2rt
1804             fac_augm=rrij**expon
1805             e_augm=augm(itypi,itypj)*fac_augm
1806             evdwij=evdwij*eps2rt*eps3rt
1807 #ifdef TSCSC
1808             if (bb(itypi,itypj).gt.0) then
1809                evdw_p=evdw_p+evdwij+e_augm
1810             else
1811                evdw_m=evdw_m+evdwij+e_augm
1812             endif
1813 #else
1814             evdw=evdw+evdwij+e_augm
1815 #endif
1816             if (lprn) then
1817             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1818             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1819             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1820      &        restyp(itypi),i,restyp(itypj),j,
1821      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1822      &        chi1,chi2,chip1,chip2,
1823      &        eps1,eps2rt**2,eps3rt**2,
1824      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1825      &        evdwij+e_augm
1826             endif
1827 C Calculate gradient components.
1828             e1=e1*eps1*eps2rt**2*eps3rt**2
1829             fac=-expon*(e1+evdwij)*rij_shift
1830             sigder=fac*sigder
1831             fac=rij*fac-2*expon*rrij*e_augm
1832 C Calculate the radial part of the gradient
1833             gg(1)=xj*fac
1834             gg(2)=yj*fac
1835             gg(3)=zj*fac
1836 C Calculate angular part of the gradient.
1837 #ifdef TSCSC
1838             if (bb(itypi,itypj).gt.0) then
1839                call sc_grad
1840             else
1841                call sc_grad_T
1842             endif
1843 #else
1844             call sc_grad
1845 #endif
1846           enddo      ! j
1847         enddo        ! iint
1848       enddo          ! i
1849       end
1850 C-----------------------------------------------------------------------------
1851       subroutine sc_angular
1852 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1853 C om12. Called by ebp, egb, and egbv.
1854       implicit none
1855       include 'COMMON.CALC'
1856       include 'COMMON.IOUNITS'
1857       erij(1)=xj*rij
1858       erij(2)=yj*rij
1859       erij(3)=zj*rij
1860       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1861       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1862       om12=dxi*dxj+dyi*dyj+dzi*dzj
1863       chiom12=chi12*om12
1864 C Calculate eps1(om12) and its derivative in om12
1865       faceps1=1.0D0-om12*chiom12
1866       faceps1_inv=1.0D0/faceps1
1867       eps1=dsqrt(faceps1_inv)
1868 C Following variable is eps1*deps1/dom12
1869       eps1_om12=faceps1_inv*chiom12
1870 c diagnostics only
1871 c      faceps1_inv=om12
1872 c      eps1=om12
1873 c      eps1_om12=1.0d0
1874 c      write (iout,*) "om12",om12," eps1",eps1
1875 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1876 C and om12.
1877       om1om2=om1*om2
1878       chiom1=chi1*om1
1879       chiom2=chi2*om2
1880       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1881       sigsq=1.0D0-facsig*faceps1_inv
1882       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1883       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1884       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1885 c diagnostics only
1886 c      sigsq=1.0d0
1887 c      sigsq_om1=0.0d0
1888 c      sigsq_om2=0.0d0
1889 c      sigsq_om12=0.0d0
1890 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1891 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1892 c     &    " eps1",eps1
1893 C Calculate eps2 and its derivatives in om1, om2, and om12.
1894       chipom1=chip1*om1
1895       chipom2=chip2*om2
1896       chipom12=chip12*om12
1897       facp=1.0D0-om12*chipom12
1898       facp_inv=1.0D0/facp
1899       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1900 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1901 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1902 C Following variable is the square root of eps2
1903       eps2rt=1.0D0-facp1*facp_inv
1904 C Following three variables are the derivatives of the square root of eps
1905 C in om1, om2, and om12.
1906       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1907       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1908       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1909 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1910       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1911 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1912 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1913 c     &  " eps2rt_om12",eps2rt_om12
1914 C Calculate whole angle-dependent part of epsilon and contributions
1915 C to its derivatives
1916       return
1917       end
1918
1919 C----------------------------------------------------------------------------
1920       subroutine sc_grad_T
1921       implicit real*8 (a-h,o-z)
1922       include 'DIMENSIONS'
1923       include 'COMMON.CHAIN'
1924       include 'COMMON.DERIV'
1925       include 'COMMON.CALC'
1926       include 'COMMON.IOUNITS'
1927       double precision dcosom1(3),dcosom2(3)
1928       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1929       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1930       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1931      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1932 c diagnostics only
1933 c      eom1=0.0d0
1934 c      eom2=0.0d0
1935 c      eom12=evdwij*eps1_om12
1936 c end diagnostics
1937 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1938 c     &  " sigder",sigder
1939 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1940 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1941       do k=1,3
1942         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1943         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1944       enddo
1945       do k=1,3
1946         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1947       enddo
1948 c      write (iout,*) "gg",(gg(k),k=1,3)
1949       do k=1,3
1950         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1951      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1952      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1953         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1954      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1955      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1956 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1957 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1958 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1959 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1960       enddo
1961 C
1962 C Calculate the components of the gradient in DC and X
1963 C
1964 cgrad      do k=i,j-1
1965 cgrad        do l=1,3
1966 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1967 cgrad        enddo
1968 cgrad      enddo
1969       do l=1,3
1970         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1971         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1972       enddo
1973       return
1974       end
1975
1976 C----------------------------------------------------------------------------
1977       subroutine sc_grad
1978       implicit real*8 (a-h,o-z)
1979       include 'DIMENSIONS'
1980       include 'COMMON.CHAIN'
1981       include 'COMMON.DERIV'
1982       include 'COMMON.CALC'
1983       include 'COMMON.IOUNITS'
1984       double precision dcosom1(3),dcosom2(3)
1985       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1986       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1987       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1988      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1989 c diagnostics only
1990 c      eom1=0.0d0
1991 c      eom2=0.0d0
1992 c      eom12=evdwij*eps1_om12
1993 c end diagnostics
1994 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1995 c     &  " sigder",sigder
1996 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1997 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1998       do k=1,3
1999         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2000         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2001       enddo
2002       do k=1,3
2003         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2004       enddo
2005 c      write (iout,*) "gg",(gg(k),k=1,3)
2006       do k=1,3
2007         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2008      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2009      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2010         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2011      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2012      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2013 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2014 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2015 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2016 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2017       enddo
2018 C
2019 C Calculate the components of the gradient in DC and X
2020 C
2021 cgrad      do k=i,j-1
2022 cgrad        do l=1,3
2023 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2024 cgrad        enddo
2025 cgrad      enddo
2026       do l=1,3
2027         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2028         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2029       enddo
2030       return
2031       end
2032 C-----------------------------------------------------------------------
2033       subroutine e_softsphere(evdw)
2034 C
2035 C This subroutine calculates the interaction energy of nonbonded side chains
2036 C assuming the LJ potential of interaction.
2037 C
2038       implicit real*8 (a-h,o-z)
2039       include 'DIMENSIONS'
2040       parameter (accur=1.0d-10)
2041       include 'COMMON.GEO'
2042       include 'COMMON.VAR'
2043       include 'COMMON.LOCAL'
2044       include 'COMMON.CHAIN'
2045       include 'COMMON.DERIV'
2046       include 'COMMON.INTERACT'
2047       include 'COMMON.TORSION'
2048       include 'COMMON.SBRIDGE'
2049       include 'COMMON.NAMES'
2050       include 'COMMON.IOUNITS'
2051       include 'COMMON.CONTACTS'
2052       dimension gg(3)
2053 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2054       evdw=0.0D0
2055       do i=iatsc_s,iatsc_e
2056         itypi=itype(i)
2057         itypi1=itype(i+1)
2058         xi=c(1,nres+i)
2059         yi=c(2,nres+i)
2060         zi=c(3,nres+i)
2061 C
2062 C Calculate SC interaction energy.
2063 C
2064         do iint=1,nint_gr(i)
2065 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2066 cd   &                  'iend=',iend(i,iint)
2067           do j=istart(i,iint),iend(i,iint)
2068             itypj=itype(j)
2069             xj=c(1,nres+j)-xi
2070             yj=c(2,nres+j)-yi
2071             zj=c(3,nres+j)-zi
2072             rij=xj*xj+yj*yj+zj*zj
2073 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2074             r0ij=r0(itypi,itypj)
2075             r0ijsq=r0ij*r0ij
2076 c            print *,i,j,r0ij,dsqrt(rij)
2077             if (rij.lt.r0ijsq) then
2078               evdwij=0.25d0*(rij-r0ijsq)**2
2079               fac=rij-r0ijsq
2080             else
2081               evdwij=0.0d0
2082               fac=0.0d0
2083             endif
2084             evdw=evdw+evdwij
2085 C
2086 C Calculate the components of the gradient in DC and X
2087 C
2088             gg(1)=xj*fac
2089             gg(2)=yj*fac
2090             gg(3)=zj*fac
2091             do k=1,3
2092               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2093               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2094               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2095               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2096             enddo
2097 cgrad            do k=i,j-1
2098 cgrad              do l=1,3
2099 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2100 cgrad              enddo
2101 cgrad            enddo
2102           enddo ! j
2103         enddo ! iint
2104       enddo ! i
2105       return
2106       end
2107 C--------------------------------------------------------------------------
2108       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2109      &              eello_turn4)
2110 C
2111 C Soft-sphere potential of p-p interaction
2112 C
2113       implicit real*8 (a-h,o-z)
2114       include 'DIMENSIONS'
2115       include 'COMMON.CONTROL'
2116       include 'COMMON.IOUNITS'
2117       include 'COMMON.GEO'
2118       include 'COMMON.VAR'
2119       include 'COMMON.LOCAL'
2120       include 'COMMON.CHAIN'
2121       include 'COMMON.DERIV'
2122       include 'COMMON.INTERACT'
2123       include 'COMMON.CONTACTS'
2124       include 'COMMON.TORSION'
2125       include 'COMMON.VECTORS'
2126       include 'COMMON.FFIELD'
2127       dimension ggg(3)
2128 cd      write(iout,*) 'In EELEC_soft_sphere'
2129       ees=0.0D0
2130       evdw1=0.0D0
2131       eel_loc=0.0d0
2132       eello_turn3=0.0d0
2133       eello_turn4=0.0d0
2134       ind=0
2135       do i=iatel_s,iatel_e
2136         dxi=dc(1,i)
2137         dyi=dc(2,i)
2138         dzi=dc(3,i)
2139         xmedi=c(1,i)+0.5d0*dxi
2140         ymedi=c(2,i)+0.5d0*dyi
2141         zmedi=c(3,i)+0.5d0*dzi
2142         num_conti=0
2143 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2144         do j=ielstart(i),ielend(i)
2145           ind=ind+1
2146           iteli=itel(i)
2147           itelj=itel(j)
2148           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2149           r0ij=rpp(iteli,itelj)
2150           r0ijsq=r0ij*r0ij
2151           dxj=dc(1,j)
2152           dyj=dc(2,j)
2153           dzj=dc(3,j)
2154           xj=c(1,j)+0.5D0*dxj-xmedi
2155           yj=c(2,j)+0.5D0*dyj-ymedi
2156           zj=c(3,j)+0.5D0*dzj-zmedi
2157           rij=xj*xj+yj*yj+zj*zj
2158           if (rij.lt.r0ijsq) then
2159             evdw1ij=0.25d0*(rij-r0ijsq)**2
2160             fac=rij-r0ijsq
2161           else
2162             evdw1ij=0.0d0
2163             fac=0.0d0
2164           endif
2165           evdw1=evdw1+evdw1ij
2166 C
2167 C Calculate contributions to the Cartesian gradient.
2168 C
2169           ggg(1)=fac*xj
2170           ggg(2)=fac*yj
2171           ggg(3)=fac*zj
2172           do k=1,3
2173             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2174             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2175           enddo
2176 *
2177 * Loop over residues i+1 thru j-1.
2178 *
2179 cgrad          do k=i+1,j-1
2180 cgrad            do l=1,3
2181 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2182 cgrad            enddo
2183 cgrad          enddo
2184         enddo ! j
2185       enddo   ! i
2186 cgrad      do i=nnt,nct-1
2187 cgrad        do k=1,3
2188 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2189 cgrad        enddo
2190 cgrad        do j=i+1,nct-1
2191 cgrad          do k=1,3
2192 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2193 cgrad          enddo
2194 cgrad        enddo
2195 cgrad      enddo
2196       return
2197       end
2198 c------------------------------------------------------------------------------
2199       subroutine vec_and_deriv
2200       implicit real*8 (a-h,o-z)
2201       include 'DIMENSIONS'
2202 #ifdef MPI
2203       include 'mpif.h'
2204 #endif
2205       include 'COMMON.IOUNITS'
2206       include 'COMMON.GEO'
2207       include 'COMMON.VAR'
2208       include 'COMMON.LOCAL'
2209       include 'COMMON.CHAIN'
2210       include 'COMMON.VECTORS'
2211       include 'COMMON.SETUP'
2212       include 'COMMON.TIME1'
2213       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2214 C Compute the local reference systems. For reference system (i), the
2215 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2216 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2217 #ifdef PARVEC
2218       do i=ivec_start,ivec_end
2219 #else
2220       do i=1,nres-1
2221 #endif
2222           if (i.eq.nres-1) then
2223 C Case of the last full residue
2224 C Compute the Z-axis
2225             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2226             costh=dcos(pi-theta(nres))
2227             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2228             do k=1,3
2229               uz(k,i)=fac*uz(k,i)
2230             enddo
2231 C Compute the derivatives of uz
2232             uzder(1,1,1)= 0.0d0
2233             uzder(2,1,1)=-dc_norm(3,i-1)
2234             uzder(3,1,1)= dc_norm(2,i-1)
2235             uzder(1,2,1)= dc_norm(3,i-1)
2236             uzder(2,2,1)= 0.0d0
2237             uzder(3,2,1)=-dc_norm(1,i-1)
2238             uzder(1,3,1)=-dc_norm(2,i-1)
2239             uzder(2,3,1)= dc_norm(1,i-1)
2240             uzder(3,3,1)= 0.0d0
2241             uzder(1,1,2)= 0.0d0
2242             uzder(2,1,2)= dc_norm(3,i)
2243             uzder(3,1,2)=-dc_norm(2,i)
2244             uzder(1,2,2)=-dc_norm(3,i)
2245             uzder(2,2,2)= 0.0d0
2246             uzder(3,2,2)= dc_norm(1,i)
2247             uzder(1,3,2)= dc_norm(2,i)
2248             uzder(2,3,2)=-dc_norm(1,i)
2249             uzder(3,3,2)= 0.0d0
2250 C Compute the Y-axis
2251             facy=fac
2252             do k=1,3
2253               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2254             enddo
2255 C Compute the derivatives of uy
2256             do j=1,3
2257               do k=1,3
2258                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2259      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2260                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2261               enddo
2262               uyder(j,j,1)=uyder(j,j,1)-costh
2263               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2264             enddo
2265             do j=1,2
2266               do k=1,3
2267                 do l=1,3
2268                   uygrad(l,k,j,i)=uyder(l,k,j)
2269                   uzgrad(l,k,j,i)=uzder(l,k,j)
2270                 enddo
2271               enddo
2272             enddo
2273             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2274             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2275             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2276             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2277           else
2278 C Other residues
2279 C Compute the Z-axis
2280             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2281             costh=dcos(pi-theta(i+2))
2282             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2283             do k=1,3
2284               uz(k,i)=fac*uz(k,i)
2285             enddo
2286 C Compute the derivatives of uz
2287             uzder(1,1,1)= 0.0d0
2288             uzder(2,1,1)=-dc_norm(3,i+1)
2289             uzder(3,1,1)= dc_norm(2,i+1)
2290             uzder(1,2,1)= dc_norm(3,i+1)
2291             uzder(2,2,1)= 0.0d0
2292             uzder(3,2,1)=-dc_norm(1,i+1)
2293             uzder(1,3,1)=-dc_norm(2,i+1)
2294             uzder(2,3,1)= dc_norm(1,i+1)
2295             uzder(3,3,1)= 0.0d0
2296             uzder(1,1,2)= 0.0d0
2297             uzder(2,1,2)= dc_norm(3,i)
2298             uzder(3,1,2)=-dc_norm(2,i)
2299             uzder(1,2,2)=-dc_norm(3,i)
2300             uzder(2,2,2)= 0.0d0
2301             uzder(3,2,2)= dc_norm(1,i)
2302             uzder(1,3,2)= dc_norm(2,i)
2303             uzder(2,3,2)=-dc_norm(1,i)
2304             uzder(3,3,2)= 0.0d0
2305 C Compute the Y-axis
2306             facy=fac
2307             do k=1,3
2308               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2309             enddo
2310 C Compute the derivatives of uy
2311             do j=1,3
2312               do k=1,3
2313                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2314      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2315                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2316               enddo
2317               uyder(j,j,1)=uyder(j,j,1)-costh
2318               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2319             enddo
2320             do j=1,2
2321               do k=1,3
2322                 do l=1,3
2323                   uygrad(l,k,j,i)=uyder(l,k,j)
2324                   uzgrad(l,k,j,i)=uzder(l,k,j)
2325                 enddo
2326               enddo
2327             enddo
2328             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2329             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2330             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2331             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2332           endif
2333       enddo
2334       do i=1,nres-1
2335         vbld_inv_temp(1)=vbld_inv(i+1)
2336         if (i.lt.nres-1) then
2337           vbld_inv_temp(2)=vbld_inv(i+2)
2338           else
2339           vbld_inv_temp(2)=vbld_inv(i)
2340           endif
2341         do j=1,2
2342           do k=1,3
2343             do l=1,3
2344               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2345               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2346             enddo
2347           enddo
2348         enddo
2349       enddo
2350 #if defined(PARVEC) && defined(MPI)
2351       if (nfgtasks1.gt.1) then
2352         time00=MPI_Wtime()
2353 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2354 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2355 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2356         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2357      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2358      &   FG_COMM1,IERR)
2359         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2360      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2361      &   FG_COMM1,IERR)
2362         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2363      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2364      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2365         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2366      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2367      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2368         time_gather=time_gather+MPI_Wtime()-time00
2369       endif
2370 c      if (fg_rank.eq.0) then
2371 c        write (iout,*) "Arrays UY and UZ"
2372 c        do i=1,nres-1
2373 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2374 c     &     (uz(k,i),k=1,3)
2375 c        enddo
2376 c      endif
2377 #endif
2378       return
2379       end
2380 C-----------------------------------------------------------------------------
2381       subroutine check_vecgrad
2382       implicit real*8 (a-h,o-z)
2383       include 'DIMENSIONS'
2384       include 'COMMON.IOUNITS'
2385       include 'COMMON.GEO'
2386       include 'COMMON.VAR'
2387       include 'COMMON.LOCAL'
2388       include 'COMMON.CHAIN'
2389       include 'COMMON.VECTORS'
2390       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2391       dimension uyt(3,maxres),uzt(3,maxres)
2392       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2393       double precision delta /1.0d-7/
2394       call vec_and_deriv
2395 cd      do i=1,nres
2396 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2397 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2398 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2399 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2400 cd     &     (dc_norm(if90,i),if90=1,3)
2401 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2402 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2403 cd          write(iout,'(a)')
2404 cd      enddo
2405       do i=1,nres
2406         do j=1,2
2407           do k=1,3
2408             do l=1,3
2409               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2410               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2411             enddo
2412           enddo
2413         enddo
2414       enddo
2415       call vec_and_deriv
2416       do i=1,nres
2417         do j=1,3
2418           uyt(j,i)=uy(j,i)
2419           uzt(j,i)=uz(j,i)
2420         enddo
2421       enddo
2422       do i=1,nres
2423 cd        write (iout,*) 'i=',i
2424         do k=1,3
2425           erij(k)=dc_norm(k,i)
2426         enddo
2427         do j=1,3
2428           do k=1,3
2429             dc_norm(k,i)=erij(k)
2430           enddo
2431           dc_norm(j,i)=dc_norm(j,i)+delta
2432 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2433 c          do k=1,3
2434 c            dc_norm(k,i)=dc_norm(k,i)/fac
2435 c          enddo
2436 c          write (iout,*) (dc_norm(k,i),k=1,3)
2437 c          write (iout,*) (erij(k),k=1,3)
2438           call vec_and_deriv
2439           do k=1,3
2440             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2441             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2442             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2443             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2444           enddo
2445 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2446 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2447 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2448         enddo
2449         do k=1,3
2450           dc_norm(k,i)=erij(k)
2451         enddo
2452 cd        do k=1,3
2453 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2454 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2455 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2456 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2457 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2458 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2459 cd          write (iout,'(a)')
2460 cd        enddo
2461       enddo
2462       return
2463       end
2464 C--------------------------------------------------------------------------
2465       subroutine set_matrices
2466       implicit real*8 (a-h,o-z)
2467       include 'DIMENSIONS'
2468 #ifdef MPI
2469       include "mpif.h"
2470       include "COMMON.SETUP"
2471       integer IERR
2472       integer status(MPI_STATUS_SIZE)
2473 #endif
2474       include 'COMMON.IOUNITS'
2475       include 'COMMON.GEO'
2476       include 'COMMON.VAR'
2477       include 'COMMON.LOCAL'
2478       include 'COMMON.CHAIN'
2479       include 'COMMON.DERIV'
2480       include 'COMMON.INTERACT'
2481       include 'COMMON.CONTACTS'
2482       include 'COMMON.TORSION'
2483       include 'COMMON.VECTORS'
2484       include 'COMMON.FFIELD'
2485       double precision auxvec(2),auxmat(2,2)
2486 C
2487 C Compute the virtual-bond-torsional-angle dependent quantities needed
2488 C to calculate the el-loc multibody terms of various order.
2489 C
2490 #ifdef PARMAT
2491       do i=ivec_start+2,ivec_end+2
2492 #else
2493       do i=3,nres+1
2494 #endif
2495         if (i .lt. nres+1) then
2496           sin1=dsin(phi(i))
2497           cos1=dcos(phi(i))
2498           sintab(i-2)=sin1
2499           costab(i-2)=cos1
2500           obrot(1,i-2)=cos1
2501           obrot(2,i-2)=sin1
2502           sin2=dsin(2*phi(i))
2503           cos2=dcos(2*phi(i))
2504           sintab2(i-2)=sin2
2505           costab2(i-2)=cos2
2506           obrot2(1,i-2)=cos2
2507           obrot2(2,i-2)=sin2
2508           Ug(1,1,i-2)=-cos1
2509           Ug(1,2,i-2)=-sin1
2510           Ug(2,1,i-2)=-sin1
2511           Ug(2,2,i-2)= cos1
2512           Ug2(1,1,i-2)=-cos2
2513           Ug2(1,2,i-2)=-sin2
2514           Ug2(2,1,i-2)=-sin2
2515           Ug2(2,2,i-2)= cos2
2516         else
2517           costab(i-2)=1.0d0
2518           sintab(i-2)=0.0d0
2519           obrot(1,i-2)=1.0d0
2520           obrot(2,i-2)=0.0d0
2521           obrot2(1,i-2)=0.0d0
2522           obrot2(2,i-2)=0.0d0
2523           Ug(1,1,i-2)=1.0d0
2524           Ug(1,2,i-2)=0.0d0
2525           Ug(2,1,i-2)=0.0d0
2526           Ug(2,2,i-2)=1.0d0
2527           Ug2(1,1,i-2)=0.0d0
2528           Ug2(1,2,i-2)=0.0d0
2529           Ug2(2,1,i-2)=0.0d0
2530           Ug2(2,2,i-2)=0.0d0
2531         endif
2532         if (i .gt. 3 .and. i .lt. nres+1) then
2533           obrot_der(1,i-2)=-sin1
2534           obrot_der(2,i-2)= cos1
2535           Ugder(1,1,i-2)= sin1
2536           Ugder(1,2,i-2)=-cos1
2537           Ugder(2,1,i-2)=-cos1
2538           Ugder(2,2,i-2)=-sin1
2539           dwacos2=cos2+cos2
2540           dwasin2=sin2+sin2
2541           obrot2_der(1,i-2)=-dwasin2
2542           obrot2_der(2,i-2)= dwacos2
2543           Ug2der(1,1,i-2)= dwasin2
2544           Ug2der(1,2,i-2)=-dwacos2
2545           Ug2der(2,1,i-2)=-dwacos2
2546           Ug2der(2,2,i-2)=-dwasin2
2547         else
2548           obrot_der(1,i-2)=0.0d0
2549           obrot_der(2,i-2)=0.0d0
2550           Ugder(1,1,i-2)=0.0d0
2551           Ugder(1,2,i-2)=0.0d0
2552           Ugder(2,1,i-2)=0.0d0
2553           Ugder(2,2,i-2)=0.0d0
2554           obrot2_der(1,i-2)=0.0d0
2555           obrot2_der(2,i-2)=0.0d0
2556           Ug2der(1,1,i-2)=0.0d0
2557           Ug2der(1,2,i-2)=0.0d0
2558           Ug2der(2,1,i-2)=0.0d0
2559           Ug2der(2,2,i-2)=0.0d0
2560         endif
2561 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2562         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2563           iti = itortyp(itype(i-2))
2564         else
2565           iti=ntortyp+1
2566         endif
2567 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2568         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2569           iti1 = itortyp(itype(i-1))
2570         else
2571           iti1=ntortyp+1
2572         endif
2573 cd        write (iout,*) '*******i',i,' iti1',iti
2574 cd        write (iout,*) 'b1',b1(:,iti)
2575 cd        write (iout,*) 'b2',b2(:,iti)
2576 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2577 c        if (i .gt. iatel_s+2) then
2578         if (i .gt. nnt+2) then
2579           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2580           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2581           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2582      &    then
2583           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2584           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2585           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2586           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2587           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2588           endif
2589         else
2590           do k=1,2
2591             Ub2(k,i-2)=0.0d0
2592             Ctobr(k,i-2)=0.0d0
2593             Dtobr2(k,i-2)=0.0d0
2594             do l=1,2
2595               EUg(l,k,i-2)=0.0d0
2596               CUg(l,k,i-2)=0.0d0
2597               DUg(l,k,i-2)=0.0d0
2598               DtUg2(l,k,i-2)=0.0d0
2599             enddo
2600           enddo
2601         endif
2602         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2603         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2604         do k=1,2
2605           muder(k,i-2)=Ub2der(k,i-2)
2606         enddo
2607 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2608         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2609           iti1 = itortyp(itype(i-1))
2610         else
2611           iti1=ntortyp+1
2612         endif
2613         do k=1,2
2614           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2615         enddo
2616 cd        write (iout,*) 'mu ',mu(:,i-2)
2617 cd        write (iout,*) 'mu1',mu1(:,i-2)
2618 cd        write (iout,*) 'mu2',mu2(:,i-2)
2619         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2620      &  then
2621         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2622         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2623         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2624         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2625         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2626 C Vectors and matrices dependent on a single virtual-bond dihedral.
2627         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2628         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2629         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2630         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2631         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2632         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2633         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2634         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2635         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2636         endif
2637       enddo
2638 C Matrices dependent on two consecutive virtual-bond dihedrals.
2639 C The order of matrices is from left to right.
2640       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2641      &then
2642 c      do i=max0(ivec_start,2),ivec_end
2643       do i=2,nres-1
2644         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2645         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2646         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2647         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2648         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2649         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2650         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2651         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2652       enddo
2653       endif
2654 #if defined(MPI) && defined(PARMAT)
2655 #ifdef DEBUG
2656 c      if (fg_rank.eq.0) then
2657         write (iout,*) "Arrays UG and UGDER before GATHER"
2658         do i=1,nres-1
2659           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2660      &     ((ug(l,k,i),l=1,2),k=1,2),
2661      &     ((ugder(l,k,i),l=1,2),k=1,2)
2662         enddo
2663         write (iout,*) "Arrays UG2 and UG2DER"
2664         do i=1,nres-1
2665           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2666      &     ((ug2(l,k,i),l=1,2),k=1,2),
2667      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2668         enddo
2669         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2670         do i=1,nres-1
2671           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2672      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2673      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2674         enddo
2675         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2676         do i=1,nres-1
2677           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2678      &     costab(i),sintab(i),costab2(i),sintab2(i)
2679         enddo
2680         write (iout,*) "Array MUDER"
2681         do i=1,nres-1
2682           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2683         enddo
2684 c      endif
2685 #endif
2686       if (nfgtasks.gt.1) then
2687         time00=MPI_Wtime()
2688 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2689 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2690 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2691 #ifdef MATGATHER
2692         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2693      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2694      &   FG_COMM1,IERR)
2695         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2696      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2697      &   FG_COMM1,IERR)
2698         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2699      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2700      &   FG_COMM1,IERR)
2701         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2702      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2703      &   FG_COMM1,IERR)
2704         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2705      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2706      &   FG_COMM1,IERR)
2707         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2708      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2709      &   FG_COMM1,IERR)
2710         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2711      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2712      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2713         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2714      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2715      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2716         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2717      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2718      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2719         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2720      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2721      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2722         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2723      &  then
2724         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2725      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2726      &   FG_COMM1,IERR)
2727         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2728      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2729      &   FG_COMM1,IERR)
2730         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2731      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2732      &   FG_COMM1,IERR)
2733        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2740      &   ivec_count(fg_rank1),
2741      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2742      &   FG_COMM1,IERR)
2743         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2744      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2745      &   FG_COMM1,IERR)
2746         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2747      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2748      &   FG_COMM1,IERR)
2749         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2750      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2751      &   FG_COMM1,IERR)
2752         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2753      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2754      &   FG_COMM1,IERR)
2755         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2756      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2757      &   FG_COMM1,IERR)
2758         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2765      &   ivec_count(fg_rank1),
2766      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2770      &   FG_COMM1,IERR)
2771        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2773      &   FG_COMM1,IERR)
2774         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2779      &   FG_COMM1,IERR)
2780         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2781      &   ivec_count(fg_rank1),
2782      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2785      &   ivec_count(fg_rank1),
2786      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2787      &   FG_COMM1,IERR)
2788         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2789      &   ivec_count(fg_rank1),
2790      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2791      &   MPI_MAT2,FG_COMM1,IERR)
2792         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2793      &   ivec_count(fg_rank1),
2794      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2795      &   MPI_MAT2,FG_COMM1,IERR)
2796         endif
2797 #else
2798 c Passes matrix info through the ring
2799       isend=fg_rank1
2800       irecv=fg_rank1-1
2801       if (irecv.lt.0) irecv=nfgtasks1-1
2802       iprev=irecv
2803       inext=fg_rank1+1
2804       if (inext.ge.nfgtasks1) inext=0
2805       do i=1,nfgtasks1-1
2806 c        write (iout,*) "isend",isend," irecv",irecv
2807 c        call flush(iout)
2808         lensend=lentyp(isend)
2809         lenrecv=lentyp(irecv)
2810 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2811 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2812 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2813 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2814 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2815 c        write (iout,*) "Gather ROTAT1"
2816 c        call flush(iout)
2817 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2818 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2819 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2820 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2821 c        write (iout,*) "Gather ROTAT2"
2822 c        call flush(iout)
2823         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2824      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2825      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2826      &   iprev,4400+irecv,FG_COMM,status,IERR)
2827 c        write (iout,*) "Gather ROTAT_OLD"
2828 c        call flush(iout)
2829         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2830      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2831      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2832      &   iprev,5500+irecv,FG_COMM,status,IERR)
2833 c        write (iout,*) "Gather PRECOMP11"
2834 c        call flush(iout)
2835         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2836      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2837      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2838      &   iprev,6600+irecv,FG_COMM,status,IERR)
2839 c        write (iout,*) "Gather PRECOMP12"
2840 c        call flush(iout)
2841         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2842      &  then
2843         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2844      &   MPI_ROTAT2(lensend),inext,7700+isend,
2845      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2846      &   iprev,7700+irecv,FG_COMM,status,IERR)
2847 c        write (iout,*) "Gather PRECOMP21"
2848 c        call flush(iout)
2849         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2850      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2851      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2852      &   iprev,8800+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather PRECOMP22"
2854 c        call flush(iout)
2855         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2856      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2857      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2858      &   MPI_PRECOMP23(lenrecv),
2859      &   iprev,9900+irecv,FG_COMM,status,IERR)
2860 c        write (iout,*) "Gather PRECOMP23"
2861 c        call flush(iout)
2862         endif
2863         isend=irecv
2864         irecv=irecv-1
2865         if (irecv.lt.0) irecv=nfgtasks1-1
2866       enddo
2867 #endif
2868         time_gather=time_gather+MPI_Wtime()-time00
2869       endif
2870 #ifdef DEBUG
2871 c      if (fg_rank.eq.0) then
2872         write (iout,*) "Arrays UG and UGDER"
2873         do i=1,nres-1
2874           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2875      &     ((ug(l,k,i),l=1,2),k=1,2),
2876      &     ((ugder(l,k,i),l=1,2),k=1,2)
2877         enddo
2878         write (iout,*) "Arrays UG2 and UG2DER"
2879         do i=1,nres-1
2880           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2881      &     ((ug2(l,k,i),l=1,2),k=1,2),
2882      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2883         enddo
2884         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2885         do i=1,nres-1
2886           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2887      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2888      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2889         enddo
2890         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2891         do i=1,nres-1
2892           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2893      &     costab(i),sintab(i),costab2(i),sintab2(i)
2894         enddo
2895         write (iout,*) "Array MUDER"
2896         do i=1,nres-1
2897           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2898         enddo
2899 c      endif
2900 #endif
2901 #endif
2902 cd      do i=1,nres
2903 cd        iti = itortyp(itype(i))
2904 cd        write (iout,*) i
2905 cd        do j=1,2
2906 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2907 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2908 cd        enddo
2909 cd      enddo
2910       return
2911       end
2912 C--------------------------------------------------------------------------
2913       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2914 C
2915 C This subroutine calculates the average interaction energy and its gradient
2916 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2917 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2918 C The potential depends both on the distance of peptide-group centers and on
2919 C the orientation of the CA-CA virtual bonds.
2920 C
2921       implicit real*8 (a-h,o-z)
2922 #ifdef MPI
2923       include 'mpif.h'
2924 #endif
2925       include 'DIMENSIONS'
2926       include 'COMMON.CONTROL'
2927       include 'COMMON.SETUP'
2928       include 'COMMON.IOUNITS'
2929       include 'COMMON.GEO'
2930       include 'COMMON.VAR'
2931       include 'COMMON.LOCAL'
2932       include 'COMMON.CHAIN'
2933       include 'COMMON.DERIV'
2934       include 'COMMON.INTERACT'
2935       include 'COMMON.CONTACTS'
2936       include 'COMMON.TORSION'
2937       include 'COMMON.VECTORS'
2938       include 'COMMON.FFIELD'
2939       include 'COMMON.TIME1'
2940       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2941      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2942       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2943      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2944       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2945      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2946      &    num_conti,j1,j2
2947 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2948 #ifdef MOMENT
2949       double precision scal_el /1.0d0/
2950 #else
2951       double precision scal_el /0.5d0/
2952 #endif
2953 C 12/13/98
2954 C 13-go grudnia roku pamietnego...
2955       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2956      &                   0.0d0,1.0d0,0.0d0,
2957      &                   0.0d0,0.0d0,1.0d0/
2958 cd      write(iout,*) 'In EELEC'
2959 cd      do i=1,nloctyp
2960 cd        write(iout,*) 'Type',i
2961 cd        write(iout,*) 'B1',B1(:,i)
2962 cd        write(iout,*) 'B2',B2(:,i)
2963 cd        write(iout,*) 'CC',CC(:,:,i)
2964 cd        write(iout,*) 'DD',DD(:,:,i)
2965 cd        write(iout,*) 'EE',EE(:,:,i)
2966 cd      enddo
2967 cd      call check_vecgrad
2968 cd      stop
2969       if (icheckgrad.eq.1) then
2970         do i=1,nres-1
2971           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2972           do k=1,3
2973             dc_norm(k,i)=dc(k,i)*fac
2974           enddo
2975 c          write (iout,*) 'i',i,' fac',fac
2976         enddo
2977       endif
2978       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2979      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2980      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2981 c        call vec_and_deriv
2982 #ifdef TIMING
2983         time01=MPI_Wtime()
2984 #endif
2985         call set_matrices
2986 #ifdef TIMING
2987         time_mat=time_mat+MPI_Wtime()-time01
2988 #endif
2989       endif
2990 cd      do i=1,nres-1
2991 cd        write (iout,*) 'i=',i
2992 cd        do k=1,3
2993 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2994 cd        enddo
2995 cd        do k=1,3
2996 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2997 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2998 cd        enddo
2999 cd      enddo
3000       t_eelecij=0.0d0
3001       ees=0.0D0
3002       evdw1=0.0D0
3003       eel_loc=0.0d0
3004       eello_turn3=0.0d0
3005       eello_turn4=0.0d0
3006       ind=0
3007       do i=1,nres
3008         num_cont_hb(i)=0
3009       enddo
3010 cd      print '(a)','Enter EELEC'
3011 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3012       do i=1,nres
3013         gel_loc_loc(i)=0.0d0
3014         gcorr_loc(i)=0.0d0
3015       enddo
3016 c
3017 c
3018 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3019 C
3020 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3021 C
3022       do i=iturn3_start,iturn3_end
3023         dxi=dc(1,i)
3024         dyi=dc(2,i)
3025         dzi=dc(3,i)
3026         dx_normi=dc_norm(1,i)
3027         dy_normi=dc_norm(2,i)
3028         dz_normi=dc_norm(3,i)
3029         xmedi=c(1,i)+0.5d0*dxi
3030         ymedi=c(2,i)+0.5d0*dyi
3031         zmedi=c(3,i)+0.5d0*dzi
3032         num_conti=0
3033         call eelecij(i,i+2,ees,evdw1,eel_loc)
3034         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3035         num_cont_hb(i)=num_conti
3036       enddo
3037       do i=iturn4_start,iturn4_end
3038         dxi=dc(1,i)
3039         dyi=dc(2,i)
3040         dzi=dc(3,i)
3041         dx_normi=dc_norm(1,i)
3042         dy_normi=dc_norm(2,i)
3043         dz_normi=dc_norm(3,i)
3044         xmedi=c(1,i)+0.5d0*dxi
3045         ymedi=c(2,i)+0.5d0*dyi
3046         zmedi=c(3,i)+0.5d0*dzi
3047         num_conti=num_cont_hb(i)
3048         call eelecij(i,i+3,ees,evdw1,eel_loc)
3049         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3050         num_cont_hb(i)=num_conti
3051       enddo   ! i
3052 c
3053 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3054 c
3055       do i=iatel_s,iatel_e
3056         dxi=dc(1,i)
3057         dyi=dc(2,i)
3058         dzi=dc(3,i)
3059         dx_normi=dc_norm(1,i)
3060         dy_normi=dc_norm(2,i)
3061         dz_normi=dc_norm(3,i)
3062         xmedi=c(1,i)+0.5d0*dxi
3063         ymedi=c(2,i)+0.5d0*dyi
3064         zmedi=c(3,i)+0.5d0*dzi
3065 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3066         num_conti=num_cont_hb(i)
3067         do j=ielstart(i),ielend(i)
3068           call eelecij(i,j,ees,evdw1,eel_loc)
3069         enddo ! j
3070         num_cont_hb(i)=num_conti
3071       enddo   ! i
3072 c      write (iout,*) "Number of loop steps in EELEC:",ind
3073 cd      do i=1,nres
3074 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3075 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3076 cd      enddo
3077 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3078 ccc      eel_loc=eel_loc+eello_turn3
3079 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3080       return
3081       end
3082 C-------------------------------------------------------------------------------
3083       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3084       implicit real*8 (a-h,o-z)
3085       include 'DIMENSIONS'
3086 #ifdef MPI
3087       include "mpif.h"
3088 #endif
3089       include 'COMMON.CONTROL'
3090       include 'COMMON.IOUNITS'
3091       include 'COMMON.GEO'
3092       include 'COMMON.VAR'
3093       include 'COMMON.LOCAL'
3094       include 'COMMON.CHAIN'
3095       include 'COMMON.DERIV'
3096       include 'COMMON.INTERACT'
3097       include 'COMMON.CONTACTS'
3098       include 'COMMON.TORSION'
3099       include 'COMMON.VECTORS'
3100       include 'COMMON.FFIELD'
3101       include 'COMMON.TIME1'
3102       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3103      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3104       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3105      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3106       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3107      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3108      &    num_conti,j1,j2
3109 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3110 #ifdef MOMENT
3111       double precision scal_el /1.0d0/
3112 #else
3113       double precision scal_el /0.5d0/
3114 #endif
3115 C 12/13/98
3116 C 13-go grudnia roku pamietnego...
3117       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3118      &                   0.0d0,1.0d0,0.0d0,
3119      &                   0.0d0,0.0d0,1.0d0/
3120 c          time00=MPI_Wtime()
3121 cd      write (iout,*) "eelecij",i,j
3122 c          ind=ind+1
3123           iteli=itel(i)
3124           itelj=itel(j)
3125           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3126           aaa=app(iteli,itelj)
3127           bbb=bpp(iteli,itelj)
3128           ael6i=ael6(iteli,itelj)
3129           ael3i=ael3(iteli,itelj)
3130           dxj=dc(1,j)
3131           dyj=dc(2,j)
3132           dzj=dc(3,j)
3133           dx_normj=dc_norm(1,j)
3134           dy_normj=dc_norm(2,j)
3135           dz_normj=dc_norm(3,j)
3136           xj=c(1,j)+0.5D0*dxj-xmedi
3137           yj=c(2,j)+0.5D0*dyj-ymedi
3138           zj=c(3,j)+0.5D0*dzj-zmedi
3139           rij=xj*xj+yj*yj+zj*zj
3140           rrmij=1.0D0/rij
3141           rij=dsqrt(rij)
3142           rmij=1.0D0/rij
3143           r3ij=rrmij*rmij
3144           r6ij=r3ij*r3ij
3145           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3146           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3147           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3148           fac=cosa-3.0D0*cosb*cosg
3149           ev1=aaa*r6ij*r6ij
3150 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3151           if (j.eq.i+2) ev1=scal_el*ev1
3152           ev2=bbb*r6ij
3153           fac3=ael6i*r6ij
3154           fac4=ael3i*r3ij
3155           evdwij=ev1+ev2
3156           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3157           el2=fac4*fac
3158           eesij=el1+el2
3159 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3160           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3161           ees=ees+eesij
3162           evdw1=evdw1+evdwij
3163 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3164 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3165 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3166 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3167
3168           if (energy_dec) then
3169               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3170               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3171           endif
3172
3173 C
3174 C Calculate contributions to the Cartesian gradient.
3175 C
3176 #ifdef SPLITELE
3177           facvdw=-6*rrmij*(ev1+evdwij)
3178           facel=-3*rrmij*(el1+eesij)
3179           fac1=fac
3180           erij(1)=xj*rmij
3181           erij(2)=yj*rmij
3182           erij(3)=zj*rmij
3183 *
3184 * Radial derivatives. First process both termini of the fragment (i,j)
3185 *
3186           ggg(1)=facel*xj
3187           ggg(2)=facel*yj
3188           ggg(3)=facel*zj
3189 c          do k=1,3
3190 c            ghalf=0.5D0*ggg(k)
3191 c            gelc(k,i)=gelc(k,i)+ghalf
3192 c            gelc(k,j)=gelc(k,j)+ghalf
3193 c          enddo
3194 c 9/28/08 AL Gradient compotents will be summed only at the end
3195           do k=1,3
3196             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3197             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3198           enddo
3199 *
3200 * Loop over residues i+1 thru j-1.
3201 *
3202 cgrad          do k=i+1,j-1
3203 cgrad            do l=1,3
3204 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3205 cgrad            enddo
3206 cgrad          enddo
3207           ggg(1)=facvdw*xj
3208           ggg(2)=facvdw*yj
3209           ggg(3)=facvdw*zj
3210 c          do k=1,3
3211 c            ghalf=0.5D0*ggg(k)
3212 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3213 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3214 c          enddo
3215 c 9/28/08 AL Gradient compotents will be summed only at the end
3216           do k=1,3
3217             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3218             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3219           enddo
3220 *
3221 * Loop over residues i+1 thru j-1.
3222 *
3223 cgrad          do k=i+1,j-1
3224 cgrad            do l=1,3
3225 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3226 cgrad            enddo
3227 cgrad          enddo
3228 #else
3229           facvdw=ev1+evdwij
3230           facel=el1+eesij
3231           fac1=fac
3232           fac=-3*rrmij*(facvdw+facvdw+facel)
3233           erij(1)=xj*rmij
3234           erij(2)=yj*rmij
3235           erij(3)=zj*rmij
3236 *
3237 * Radial derivatives. First process both termini of the fragment (i,j)
3238 *
3239           ggg(1)=fac*xj
3240           ggg(2)=fac*yj
3241           ggg(3)=fac*zj
3242 c          do k=1,3
3243 c            ghalf=0.5D0*ggg(k)
3244 c            gelc(k,i)=gelc(k,i)+ghalf
3245 c            gelc(k,j)=gelc(k,j)+ghalf
3246 c          enddo
3247 c 9/28/08 AL Gradient compotents will be summed only at the end
3248           do k=1,3
3249             gelc_long(k,j)=gelc(k,j)+ggg(k)
3250             gelc_long(k,i)=gelc(k,i)-ggg(k)
3251           enddo
3252 *
3253 * Loop over residues i+1 thru j-1.
3254 *
3255 cgrad          do k=i+1,j-1
3256 cgrad            do l=1,3
3257 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3258 cgrad            enddo
3259 cgrad          enddo
3260 c 9/28/08 AL Gradient compotents will be summed only at the end
3261           ggg(1)=facvdw*xj
3262           ggg(2)=facvdw*yj
3263           ggg(3)=facvdw*zj
3264           do k=1,3
3265             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3266             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3267           enddo
3268 #endif
3269 *
3270 * Angular part
3271 *
3272           ecosa=2.0D0*fac3*fac1+fac4
3273           fac4=-3.0D0*fac4
3274           fac3=-6.0D0*fac3
3275           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3276           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3277           do k=1,3
3278             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3279             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3280           enddo
3281 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3282 cd   &          (dcosg(k),k=1,3)
3283           do k=1,3
3284             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3285           enddo
3286 c          do k=1,3
3287 c            ghalf=0.5D0*ggg(k)
3288 c            gelc(k,i)=gelc(k,i)+ghalf
3289 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3290 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3291 c            gelc(k,j)=gelc(k,j)+ghalf
3292 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3293 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3294 c          enddo
3295 cgrad          do k=i+1,j-1
3296 cgrad            do l=1,3
3297 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3298 cgrad            enddo
3299 cgrad          enddo
3300           do k=1,3
3301             gelc(k,i)=gelc(k,i)
3302      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3303      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3304             gelc(k,j)=gelc(k,j)
3305      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3306      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3307             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3308             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3309           enddo
3310           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3311      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3312      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3313 C
3314 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3315 C   energy of a peptide unit is assumed in the form of a second-order
3316 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3317 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3318 C   are computed for EVERY pair of non-contiguous peptide groups.
3319 C
3320           if (j.lt.nres-1) then
3321             j1=j+1
3322             j2=j-1
3323           else
3324             j1=j-1
3325             j2=j-2
3326           endif
3327           kkk=0
3328           do k=1,2
3329             do l=1,2
3330               kkk=kkk+1
3331               muij(kkk)=mu(k,i)*mu(l,j)
3332             enddo
3333           enddo
3334 cd         write (iout,*) 'EELEC: i',i,' j',j
3335 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3336 cd          write(iout,*) 'muij',muij
3337           ury=scalar(uy(1,i),erij)
3338           urz=scalar(uz(1,i),erij)
3339           vry=scalar(uy(1,j),erij)
3340           vrz=scalar(uz(1,j),erij)
3341           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3342           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3343           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3344           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3345           fac=dsqrt(-ael6i)*r3ij
3346           a22=a22*fac
3347           a23=a23*fac
3348           a32=a32*fac
3349           a33=a33*fac
3350 cd          write (iout,'(4i5,4f10.5)')
3351 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3352 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3353 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3354 cd     &      uy(:,j),uz(:,j)
3355 cd          write (iout,'(4f10.5)')
3356 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3357 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3358 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3359 cd           write (iout,'(9f10.5/)')
3360 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3361 C Derivatives of the elements of A in virtual-bond vectors
3362           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3363           do k=1,3
3364             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3365             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3366             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3367             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3368             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3369             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3370             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3371             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3372             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3373             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3374             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3375             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3376           enddo
3377 C Compute radial contributions to the gradient
3378           facr=-3.0d0*rrmij
3379           a22der=a22*facr
3380           a23der=a23*facr
3381           a32der=a32*facr
3382           a33der=a33*facr
3383           agg(1,1)=a22der*xj
3384           agg(2,1)=a22der*yj
3385           agg(3,1)=a22der*zj
3386           agg(1,2)=a23der*xj
3387           agg(2,2)=a23der*yj
3388           agg(3,2)=a23der*zj
3389           agg(1,3)=a32der*xj
3390           agg(2,3)=a32der*yj
3391           agg(3,3)=a32der*zj
3392           agg(1,4)=a33der*xj
3393           agg(2,4)=a33der*yj
3394           agg(3,4)=a33der*zj
3395 C Add the contributions coming from er
3396           fac3=-3.0d0*fac
3397           do k=1,3
3398             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3399             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3400             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3401             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3402           enddo
3403           do k=1,3
3404 C Derivatives in DC(i)
3405 cgrad            ghalf1=0.5d0*agg(k,1)
3406 cgrad            ghalf2=0.5d0*agg(k,2)
3407 cgrad            ghalf3=0.5d0*agg(k,3)
3408 cgrad            ghalf4=0.5d0*agg(k,4)
3409             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3410      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3411             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3412      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3413             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3414      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3415             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3416      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3417 C Derivatives in DC(i+1)
3418             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3419      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3420             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3421      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3422             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3423      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3424             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3425      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3426 C Derivatives in DC(j)
3427             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3428      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3429             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3430      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3431             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3432      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3433             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3434      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3435 C Derivatives in DC(j+1) or DC(nres-1)
3436             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3437      &      -3.0d0*vryg(k,3)*ury)
3438             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3439      &      -3.0d0*vrzg(k,3)*ury)
3440             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3441      &      -3.0d0*vryg(k,3)*urz)
3442             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3443      &      -3.0d0*vrzg(k,3)*urz)
3444 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3445 cgrad              do l=1,4
3446 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3447 cgrad              enddo
3448 cgrad            endif
3449           enddo
3450           acipa(1,1)=a22
3451           acipa(1,2)=a23
3452           acipa(2,1)=a32
3453           acipa(2,2)=a33
3454           a22=-a22
3455           a23=-a23
3456           do l=1,2
3457             do k=1,3
3458               agg(k,l)=-agg(k,l)
3459               aggi(k,l)=-aggi(k,l)
3460               aggi1(k,l)=-aggi1(k,l)
3461               aggj(k,l)=-aggj(k,l)
3462               aggj1(k,l)=-aggj1(k,l)
3463             enddo
3464           enddo
3465           if (j.lt.nres-1) then
3466             a22=-a22
3467             a32=-a32
3468             do l=1,3,2
3469               do k=1,3
3470                 agg(k,l)=-agg(k,l)
3471                 aggi(k,l)=-aggi(k,l)
3472                 aggi1(k,l)=-aggi1(k,l)
3473                 aggj(k,l)=-aggj(k,l)
3474                 aggj1(k,l)=-aggj1(k,l)
3475               enddo
3476             enddo
3477           else
3478             a22=-a22
3479             a23=-a23
3480             a32=-a32
3481             a33=-a33
3482             do l=1,4
3483               do k=1,3
3484                 agg(k,l)=-agg(k,l)
3485                 aggi(k,l)=-aggi(k,l)
3486                 aggi1(k,l)=-aggi1(k,l)
3487                 aggj(k,l)=-aggj(k,l)
3488                 aggj1(k,l)=-aggj1(k,l)
3489               enddo
3490             enddo
3491           endif
3492           ENDIF ! WCORR
3493           IF (wel_loc.gt.0.0d0) THEN
3494 C Contribution to the local-electrostatic energy coming from the i-j pair
3495           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3496      &     +a33*muij(4)
3497 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3498
3499           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3500      &            'eelloc',i,j,eel_loc_ij
3501
3502           eel_loc=eel_loc+eel_loc_ij
3503 C Partial derivatives in virtual-bond dihedral angles gamma
3504           if (i.gt.1)
3505      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3506      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3507      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3508           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3509      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3510      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3511 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3512           do l=1,3
3513             ggg(l)=agg(l,1)*muij(1)+
3514      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3515             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3516             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3517 cgrad            ghalf=0.5d0*ggg(l)
3518 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3519 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3520           enddo
3521 cgrad          do k=i+1,j2
3522 cgrad            do l=1,3
3523 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3524 cgrad            enddo
3525 cgrad          enddo
3526 C Remaining derivatives of eello
3527           do l=1,3
3528             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3529      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3530             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3531      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3532             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3533      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3534             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3535      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3536           enddo
3537           ENDIF
3538 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3539 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3540           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3541      &       .and. num_conti.le.maxconts) then
3542 c            write (iout,*) i,j," entered corr"
3543 C
3544 C Calculate the contact function. The ith column of the array JCONT will
3545 C contain the numbers of atoms that make contacts with the atom I (of numbers
3546 C greater than I). The arrays FACONT and GACONT will contain the values of
3547 C the contact function and its derivative.
3548 c           r0ij=1.02D0*rpp(iteli,itelj)
3549 c           r0ij=1.11D0*rpp(iteli,itelj)
3550             r0ij=2.20D0*rpp(iteli,itelj)
3551 c           r0ij=1.55D0*rpp(iteli,itelj)
3552             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3553             if (fcont.gt.0.0D0) then
3554               num_conti=num_conti+1
3555               if (num_conti.gt.maxconts) then
3556                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3557      &                         ' will skip next contacts for this conf.'
3558               else
3559                 jcont_hb(num_conti,i)=j
3560 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3561 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3562                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3563      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3564 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3565 C  terms.
3566                 d_cont(num_conti,i)=rij
3567 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3568 C     --- Electrostatic-interaction matrix ---
3569                 a_chuj(1,1,num_conti,i)=a22
3570                 a_chuj(1,2,num_conti,i)=a23
3571                 a_chuj(2,1,num_conti,i)=a32
3572                 a_chuj(2,2,num_conti,i)=a33
3573 C     --- Gradient of rij
3574                 do kkk=1,3
3575                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3576                 enddo
3577                 kkll=0
3578                 do k=1,2
3579                   do l=1,2
3580                     kkll=kkll+1
3581                     do m=1,3
3582                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3583                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3584                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3585                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3586                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3587                     enddo
3588                   enddo
3589                 enddo
3590                 ENDIF
3591                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3592 C Calculate contact energies
3593                 cosa4=4.0D0*cosa
3594                 wij=cosa-3.0D0*cosb*cosg
3595                 cosbg1=cosb+cosg
3596                 cosbg2=cosb-cosg
3597 c               fac3=dsqrt(-ael6i)/r0ij**3
3598                 fac3=dsqrt(-ael6i)*r3ij
3599 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3600                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3601                 if (ees0tmp.gt.0) then
3602                   ees0pij=dsqrt(ees0tmp)
3603                 else
3604                   ees0pij=0
3605                 endif
3606 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3607                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3608                 if (ees0tmp.gt.0) then
3609                   ees0mij=dsqrt(ees0tmp)
3610                 else
3611                   ees0mij=0
3612                 endif
3613 c               ees0mij=0.0D0
3614                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3615                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3616 C Diagnostics. Comment out or remove after debugging!
3617 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3618 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3619 c               ees0m(num_conti,i)=0.0D0
3620 C End diagnostics.
3621 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3622 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3623 C Angular derivatives of the contact function
3624                 ees0pij1=fac3/ees0pij
3625                 ees0mij1=fac3/ees0mij
3626                 fac3p=-3.0D0*fac3*rrmij
3627                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3628                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3629 c               ees0mij1=0.0D0
3630                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3631                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3632                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3633                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3634                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3635                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3636                 ecosap=ecosa1+ecosa2
3637                 ecosbp=ecosb1+ecosb2
3638                 ecosgp=ecosg1+ecosg2
3639                 ecosam=ecosa1-ecosa2
3640                 ecosbm=ecosb1-ecosb2
3641                 ecosgm=ecosg1-ecosg2
3642 C Diagnostics
3643 c               ecosap=ecosa1
3644 c               ecosbp=ecosb1
3645 c               ecosgp=ecosg1
3646 c               ecosam=0.0D0
3647 c               ecosbm=0.0D0
3648 c               ecosgm=0.0D0
3649 C End diagnostics
3650                 facont_hb(num_conti,i)=fcont
3651                 fprimcont=fprimcont/rij
3652 cd              facont_hb(num_conti,i)=1.0D0
3653 C Following line is for diagnostics.
3654 cd              fprimcont=0.0D0
3655                 do k=1,3
3656                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3657                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3658                 enddo
3659                 do k=1,3
3660                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3661                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3662                 enddo
3663                 gggp(1)=gggp(1)+ees0pijp*xj
3664                 gggp(2)=gggp(2)+ees0pijp*yj
3665                 gggp(3)=gggp(3)+ees0pijp*zj
3666                 gggm(1)=gggm(1)+ees0mijp*xj
3667                 gggm(2)=gggm(2)+ees0mijp*yj
3668                 gggm(3)=gggm(3)+ees0mijp*zj
3669 C Derivatives due to the contact function
3670                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3671                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3672                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3673                 do k=1,3
3674 c
3675 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3676 c          following the change of gradient-summation algorithm.
3677 c
3678 cgrad                  ghalfp=0.5D0*gggp(k)
3679 cgrad                  ghalfm=0.5D0*gggm(k)
3680                   gacontp_hb1(k,num_conti,i)=!ghalfp
3681      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3682      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3683                   gacontp_hb2(k,num_conti,i)=!ghalfp
3684      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3685      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3686                   gacontp_hb3(k,num_conti,i)=gggp(k)
3687                   gacontm_hb1(k,num_conti,i)=!ghalfm
3688      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3689      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3690                   gacontm_hb2(k,num_conti,i)=!ghalfm
3691      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3692      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3693                   gacontm_hb3(k,num_conti,i)=gggm(k)
3694                 enddo
3695 C Diagnostics. Comment out or remove after debugging!
3696 cdiag           do k=1,3
3697 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3698 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3699 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3700 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3701 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3702 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3703 cdiag           enddo
3704               ENDIF ! wcorr
3705               endif  ! num_conti.le.maxconts
3706             endif  ! fcont.gt.0
3707           endif    ! j.gt.i+1
3708           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3709             do k=1,4
3710               do l=1,3
3711                 ghalf=0.5d0*agg(l,k)
3712                 aggi(l,k)=aggi(l,k)+ghalf
3713                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3714                 aggj(l,k)=aggj(l,k)+ghalf
3715               enddo
3716             enddo
3717             if (j.eq.nres-1 .and. i.lt.j-2) then
3718               do k=1,4
3719                 do l=1,3
3720                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3721                 enddo
3722               enddo
3723             endif
3724           endif
3725 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3726       return
3727       end
3728 C-----------------------------------------------------------------------------
3729       subroutine eturn3(i,eello_turn3)
3730 C Third- and fourth-order contributions from turns
3731       implicit real*8 (a-h,o-z)
3732       include 'DIMENSIONS'
3733       include 'COMMON.IOUNITS'
3734       include 'COMMON.GEO'
3735       include 'COMMON.VAR'
3736       include 'COMMON.LOCAL'
3737       include 'COMMON.CHAIN'
3738       include 'COMMON.DERIV'
3739       include 'COMMON.INTERACT'
3740       include 'COMMON.CONTACTS'
3741       include 'COMMON.TORSION'
3742       include 'COMMON.VECTORS'
3743       include 'COMMON.FFIELD'
3744       include 'COMMON.CONTROL'
3745       dimension ggg(3)
3746       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3747      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3748      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3749       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3750      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3751       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3752      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3753      &    num_conti,j1,j2
3754       j=i+2
3755 c      write (iout,*) "eturn3",i,j,j1,j2
3756       a_temp(1,1)=a22
3757       a_temp(1,2)=a23
3758       a_temp(2,1)=a32
3759       a_temp(2,2)=a33
3760 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3761 C
3762 C               Third-order contributions
3763 C
3764 C                 (i+2)o----(i+3)
3765 C                      | |
3766 C                      | |
3767 C                 (i+1)o----i
3768 C
3769 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3770 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3771         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3772         call transpose2(auxmat(1,1),auxmat1(1,1))
3773         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3774         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3775         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3776      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3777 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3778 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3779 cd     &    ' eello_turn3_num',4*eello_turn3_num
3780 C Derivatives in gamma(i)
3781         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3782         call transpose2(auxmat2(1,1),auxmat3(1,1))
3783         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3784         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3785 C Derivatives in gamma(i+1)
3786         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3787         call transpose2(auxmat2(1,1),auxmat3(1,1))
3788         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3789         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3790      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3791 C Cartesian derivatives
3792         do l=1,3
3793 c            ghalf1=0.5d0*agg(l,1)
3794 c            ghalf2=0.5d0*agg(l,2)
3795 c            ghalf3=0.5d0*agg(l,3)
3796 c            ghalf4=0.5d0*agg(l,4)
3797           a_temp(1,1)=aggi(l,1)!+ghalf1
3798           a_temp(1,2)=aggi(l,2)!+ghalf2
3799           a_temp(2,1)=aggi(l,3)!+ghalf3
3800           a_temp(2,2)=aggi(l,4)!+ghalf4
3801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3802           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3804           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3805           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3806           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3807           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3808           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3809           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3810      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3811           a_temp(1,1)=aggj(l,1)!+ghalf1
3812           a_temp(1,2)=aggj(l,2)!+ghalf2
3813           a_temp(2,1)=aggj(l,3)!+ghalf3
3814           a_temp(2,2)=aggj(l,4)!+ghalf4
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818           a_temp(1,1)=aggj1(l,1)
3819           a_temp(1,2)=aggj1(l,2)
3820           a_temp(2,1)=aggj1(l,3)
3821           a_temp(2,2)=aggj1(l,4)
3822           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3823           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3824      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3825         enddo
3826       return
3827       end
3828 C-------------------------------------------------------------------------------
3829       subroutine eturn4(i,eello_turn4)
3830 C Third- and fourth-order contributions from turns
3831       implicit real*8 (a-h,o-z)
3832       include 'DIMENSIONS'
3833       include 'COMMON.IOUNITS'
3834       include 'COMMON.GEO'
3835       include 'COMMON.VAR'
3836       include 'COMMON.LOCAL'
3837       include 'COMMON.CHAIN'
3838       include 'COMMON.DERIV'
3839       include 'COMMON.INTERACT'
3840       include 'COMMON.CONTACTS'
3841       include 'COMMON.TORSION'
3842       include 'COMMON.VECTORS'
3843       include 'COMMON.FFIELD'
3844       include 'COMMON.CONTROL'
3845       dimension ggg(3)
3846       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3847      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3848      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3849       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3850      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3851       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3852      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3853      &    num_conti,j1,j2
3854       j=i+3
3855 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3856 C
3857 C               Fourth-order contributions
3858 C
3859 C                 (i+3)o----(i+4)
3860 C                     /  |
3861 C               (i+2)o   |
3862 C                     \  |
3863 C                 (i+1)o----i
3864 C
3865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3866 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3867 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3868         a_temp(1,1)=a22
3869         a_temp(1,2)=a23
3870         a_temp(2,1)=a32
3871         a_temp(2,2)=a33
3872         iti1=itortyp(itype(i+1))
3873         iti2=itortyp(itype(i+2))
3874         iti3=itortyp(itype(i+3))
3875 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3876         call transpose2(EUg(1,1,i+1),e1t(1,1))
3877         call transpose2(Eug(1,1,i+2),e2t(1,1))
3878         call transpose2(Eug(1,1,i+3),e3t(1,1))
3879         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3880         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3881         s1=scalar2(b1(1,iti2),auxvec(1))
3882         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3883         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3884         s2=scalar2(b1(1,iti1),auxvec(1))
3885         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3886         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3887         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3888         eello_turn4=eello_turn4-(s1+s2+s3)
3889         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3890      &      'eturn4',i,j,-(s1+s2+s3)
3891 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3892 cd     &    ' eello_turn4_num',8*eello_turn4_num
3893 C Derivatives in gamma(i)
3894         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3895         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3896         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3897         s1=scalar2(b1(1,iti2),auxvec(1))
3898         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3899         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3900         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3901 C Derivatives in gamma(i+1)
3902         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3903         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3904         s2=scalar2(b1(1,iti1),auxvec(1))
3905         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3906         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3907         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3908         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3909 C Derivatives in gamma(i+2)
3910         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3911         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3912         s1=scalar2(b1(1,iti2),auxvec(1))
3913         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3914         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3915         s2=scalar2(b1(1,iti1),auxvec(1))
3916         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3917         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3918         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3919         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3920 C Cartesian derivatives
3921 C Derivatives of this turn contributions in DC(i+2)
3922         if (j.lt.nres-1) then
3923           do l=1,3
3924             a_temp(1,1)=agg(l,1)
3925             a_temp(1,2)=agg(l,2)
3926             a_temp(2,1)=agg(l,3)
3927             a_temp(2,2)=agg(l,4)
3928             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3929             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3930             s1=scalar2(b1(1,iti2),auxvec(1))
3931             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3932             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3933             s2=scalar2(b1(1,iti1),auxvec(1))
3934             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3935             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3936             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3937             ggg(l)=-(s1+s2+s3)
3938             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3939           enddo
3940         endif
3941 C Remaining derivatives of this turn contribution
3942         do l=1,3
3943           a_temp(1,1)=aggi(l,1)
3944           a_temp(1,2)=aggi(l,2)
3945           a_temp(2,1)=aggi(l,3)
3946           a_temp(2,2)=aggi(l,4)
3947           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3948           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3949           s1=scalar2(b1(1,iti2),auxvec(1))
3950           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3951           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3952           s2=scalar2(b1(1,iti1),auxvec(1))
3953           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3954           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3955           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3956           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3957           a_temp(1,1)=aggi1(l,1)
3958           a_temp(1,2)=aggi1(l,2)
3959           a_temp(2,1)=aggi1(l,3)
3960           a_temp(2,2)=aggi1(l,4)
3961           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3962           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3963           s1=scalar2(b1(1,iti2),auxvec(1))
3964           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3965           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3966           s2=scalar2(b1(1,iti1),auxvec(1))
3967           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3968           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3969           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3970           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3971           a_temp(1,1)=aggj(l,1)
3972           a_temp(1,2)=aggj(l,2)
3973           a_temp(2,1)=aggj(l,3)
3974           a_temp(2,2)=aggj(l,4)
3975           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3976           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3977           s1=scalar2(b1(1,iti2),auxvec(1))
3978           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3979           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3980           s2=scalar2(b1(1,iti1),auxvec(1))
3981           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3982           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3983           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3984           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3985           a_temp(1,1)=aggj1(l,1)
3986           a_temp(1,2)=aggj1(l,2)
3987           a_temp(2,1)=aggj1(l,3)
3988           a_temp(2,2)=aggj1(l,4)
3989           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3990           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3991           s1=scalar2(b1(1,iti2),auxvec(1))
3992           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3993           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3994           s2=scalar2(b1(1,iti1),auxvec(1))
3995           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3996           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3997           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3998 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3999           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4000         enddo
4001       return
4002       end
4003 C-----------------------------------------------------------------------------
4004       subroutine vecpr(u,v,w)
4005       implicit real*8(a-h,o-z)
4006       dimension u(3),v(3),w(3)
4007       w(1)=u(2)*v(3)-u(3)*v(2)
4008       w(2)=-u(1)*v(3)+u(3)*v(1)
4009       w(3)=u(1)*v(2)-u(2)*v(1)
4010       return
4011       end
4012 C-----------------------------------------------------------------------------
4013       subroutine unormderiv(u,ugrad,unorm,ungrad)
4014 C This subroutine computes the derivatives of a normalized vector u, given
4015 C the derivatives computed without normalization conditions, ugrad. Returns
4016 C ungrad.
4017       implicit none
4018       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4019       double precision vec(3)
4020       double precision scalar
4021       integer i,j
4022 c      write (2,*) 'ugrad',ugrad
4023 c      write (2,*) 'u',u
4024       do i=1,3
4025         vec(i)=scalar(ugrad(1,i),u(1))
4026       enddo
4027 c      write (2,*) 'vec',vec
4028       do i=1,3
4029         do j=1,3
4030           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4031         enddo
4032       enddo
4033 c      write (2,*) 'ungrad',ungrad
4034       return
4035       end
4036 C-----------------------------------------------------------------------------
4037       subroutine escp_soft_sphere(evdw2,evdw2_14)
4038 C
4039 C This subroutine calculates the excluded-volume interaction energy between
4040 C peptide-group centers and side chains and its gradient in virtual-bond and
4041 C side-chain vectors.
4042 C
4043       implicit real*8 (a-h,o-z)
4044       include 'DIMENSIONS'
4045       include 'COMMON.GEO'
4046       include 'COMMON.VAR'
4047       include 'COMMON.LOCAL'
4048       include 'COMMON.CHAIN'
4049       include 'COMMON.DERIV'
4050       include 'COMMON.INTERACT'
4051       include 'COMMON.FFIELD'
4052       include 'COMMON.IOUNITS'
4053       include 'COMMON.CONTROL'
4054       dimension ggg(3)
4055       evdw2=0.0D0
4056       evdw2_14=0.0d0
4057       r0_scp=4.5d0
4058 cd    print '(a)','Enter ESCP'
4059 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4060       do i=iatscp_s,iatscp_e
4061         iteli=itel(i)
4062         xi=0.5D0*(c(1,i)+c(1,i+1))
4063         yi=0.5D0*(c(2,i)+c(2,i+1))
4064         zi=0.5D0*(c(3,i)+c(3,i+1))
4065
4066         do iint=1,nscp_gr(i)
4067
4068         do j=iscpstart(i,iint),iscpend(i,iint)
4069           itypj=itype(j)
4070 C Uncomment following three lines for SC-p interactions
4071 c         xj=c(1,nres+j)-xi
4072 c         yj=c(2,nres+j)-yi
4073 c         zj=c(3,nres+j)-zi
4074 C Uncomment following three lines for Ca-p interactions
4075           xj=c(1,j)-xi
4076           yj=c(2,j)-yi
4077           zj=c(3,j)-zi
4078           rij=xj*xj+yj*yj+zj*zj
4079           r0ij=r0_scp
4080           r0ijsq=r0ij*r0ij
4081           if (rij.lt.r0ijsq) then
4082             evdwij=0.25d0*(rij-r0ijsq)**2
4083             fac=rij-r0ijsq
4084           else
4085             evdwij=0.0d0
4086             fac=0.0d0
4087           endif
4088           evdw2=evdw2+evdwij
4089 C
4090 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4091 C
4092           ggg(1)=xj*fac
4093           ggg(2)=yj*fac
4094           ggg(3)=zj*fac
4095 cgrad          if (j.lt.i) then
4096 cd          write (iout,*) 'j<i'
4097 C Uncomment following three lines for SC-p interactions
4098 c           do k=1,3
4099 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4100 c           enddo
4101 cgrad          else
4102 cd          write (iout,*) 'j>i'
4103 cgrad            do k=1,3
4104 cgrad              ggg(k)=-ggg(k)
4105 C Uncomment following line for SC-p interactions
4106 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4107 cgrad            enddo
4108 cgrad          endif
4109 cgrad          do k=1,3
4110 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4111 cgrad          enddo
4112 cgrad          kstart=min0(i+1,j)
4113 cgrad          kend=max0(i-1,j-1)
4114 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4115 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4116 cgrad          do k=kstart,kend
4117 cgrad            do l=1,3
4118 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4119 cgrad            enddo
4120 cgrad          enddo
4121           do k=1,3
4122             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4123             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4124           enddo
4125         enddo
4126
4127         enddo ! iint
4128       enddo ! i
4129       return
4130       end
4131 C-----------------------------------------------------------------------------
4132       subroutine escp(evdw2,evdw2_14)
4133 C
4134 C This subroutine calculates the excluded-volume interaction energy between
4135 C peptide-group centers and side chains and its gradient in virtual-bond and
4136 C side-chain vectors.
4137 C
4138       implicit real*8 (a-h,o-z)
4139       include 'DIMENSIONS'
4140       include 'COMMON.GEO'
4141       include 'COMMON.VAR'
4142       include 'COMMON.LOCAL'
4143       include 'COMMON.CHAIN'
4144       include 'COMMON.DERIV'
4145       include 'COMMON.INTERACT'
4146       include 'COMMON.FFIELD'
4147       include 'COMMON.IOUNITS'
4148       include 'COMMON.CONTROL'
4149       dimension ggg(3)
4150       evdw2=0.0D0
4151       evdw2_14=0.0d0
4152 cd    print '(a)','Enter ESCP'
4153 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4154       do i=iatscp_s,iatscp_e
4155         iteli=itel(i)
4156         xi=0.5D0*(c(1,i)+c(1,i+1))
4157         yi=0.5D0*(c(2,i)+c(2,i+1))
4158         zi=0.5D0*(c(3,i)+c(3,i+1))
4159
4160         do iint=1,nscp_gr(i)
4161
4162         do j=iscpstart(i,iint),iscpend(i,iint)
4163           itypj=itype(j)
4164 C Uncomment following three lines for SC-p interactions
4165 c         xj=c(1,nres+j)-xi
4166 c         yj=c(2,nres+j)-yi
4167 c         zj=c(3,nres+j)-zi
4168 C Uncomment following three lines for Ca-p interactions
4169           xj=c(1,j)-xi
4170           yj=c(2,j)-yi
4171           zj=c(3,j)-zi
4172           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4173           fac=rrij**expon2
4174           e1=fac*fac*aad(itypj,iteli)
4175           e2=fac*bad(itypj,iteli)
4176           if (iabs(j-i) .le. 2) then
4177             e1=scal14*e1
4178             e2=scal14*e2
4179             evdw2_14=evdw2_14+e1+e2
4180           endif
4181           evdwij=e1+e2
4182           evdw2=evdw2+evdwij
4183           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4184      &        'evdw2',i,j,evdwij
4185 C
4186 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4187 C
4188           fac=-(evdwij+e1)*rrij
4189           ggg(1)=xj*fac
4190           ggg(2)=yj*fac
4191           ggg(3)=zj*fac
4192 cgrad          if (j.lt.i) then
4193 cd          write (iout,*) 'j<i'
4194 C Uncomment following three lines for SC-p interactions
4195 c           do k=1,3
4196 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4197 c           enddo
4198 cgrad          else
4199 cd          write (iout,*) 'j>i'
4200 cgrad            do k=1,3
4201 cgrad              ggg(k)=-ggg(k)
4202 C Uncomment following line for SC-p interactions
4203 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4204 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4205 cgrad            enddo
4206 cgrad          endif
4207 cgrad          do k=1,3
4208 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4209 cgrad          enddo
4210 cgrad          kstart=min0(i+1,j)
4211 cgrad          kend=max0(i-1,j-1)
4212 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4213 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4214 cgrad          do k=kstart,kend
4215 cgrad            do l=1,3
4216 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4217 cgrad            enddo
4218 cgrad          enddo
4219           do k=1,3
4220             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4221             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4222           enddo
4223         enddo
4224
4225         enddo ! iint
4226       enddo ! i
4227       do i=1,nct
4228         do j=1,3
4229           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4230           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4231           gradx_scp(j,i)=expon*gradx_scp(j,i)
4232         enddo
4233       enddo
4234 C******************************************************************************
4235 C
4236 C                              N O T E !!!
4237 C
4238 C To save time the factor EXPON has been extracted from ALL components
4239 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4240 C use!
4241 C
4242 C******************************************************************************
4243       return
4244       end
4245 C--------------------------------------------------------------------------
4246       subroutine edis(ehpb)
4247 C
4248 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4249 C
4250       implicit real*8 (a-h,o-z)
4251       include 'DIMENSIONS'
4252       include 'COMMON.SBRIDGE'
4253       include 'COMMON.CHAIN'
4254       include 'COMMON.DERIV'
4255       include 'COMMON.VAR'
4256       include 'COMMON.INTERACT'
4257       include 'COMMON.IOUNITS'
4258       dimension ggg(3)
4259       ehpb=0.0D0
4260 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4261 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4262       if (link_end.eq.0) return
4263       do i=link_start,link_end
4264 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4265 C CA-CA distance used in regularization of structure.
4266         ii=ihpb(i)
4267         jj=jhpb(i)
4268 C iii and jjj point to the residues for which the distance is assigned.
4269         if (ii.gt.nres) then
4270           iii=ii-nres
4271           jjj=jj-nres
4272         else
4273           iii=ii
4274           jjj=jj
4275         endif
4276 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4277 c     &    dhpb(i),dhpb1(i),forcon(i)
4278 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4279 C    distance and angle dependent SS bond potential.
4280 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4281 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4282 c          if (.not.dyn_ss .and. i.le.nss) then
4283 C 15/02/13 CC dynamic SSbond
4284         if (.not.dyn_ss.and.
4285      &   ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4286           call ssbond_ene(iii,jjj,eij)
4287           ehpb=ehpb+2*eij
4288 cd          write (iout,*) "eij",eij
4289         else if (ii.gt.nres .and. jj.gt.nres) then
4290 c Restraints from contact prediction
4291           dd=dist(ii,jj)
4292           if (dhpb1(i).gt.0.0d0) then
4293             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4294             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4295 c            write (iout,*) "beta nmr",
4296 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4297           else
4298             dd=dist(ii,jj)
4299             rdis=dd-dhpb(i)
4300 C Get the force constant corresponding to this distance.
4301             waga=forcon(i)
4302 C Calculate the contribution to energy.
4303             ehpb=ehpb+waga*rdis*rdis
4304 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4305 C
4306 C Evaluate gradient.
4307 C
4308             fac=waga*rdis/dd
4309           endif
4310           do j=1,3
4311             ggg(j)=fac*(c(j,jj)-c(j,ii))
4312           enddo
4313           do j=1,3
4314             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4315             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4316           enddo
4317           do k=1,3
4318             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4319             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4320           enddo
4321         else
4322 C Calculate the distance between the two points and its difference from the
4323 C target distance.
4324           dd=dist(ii,jj)
4325           if (dhpb1(i).gt.0.0d0) then
4326             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4327             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4328 c            write (iout,*) "alph nmr",
4329 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4330           else
4331             rdis=dd-dhpb(i)
4332 C Get the force constant corresponding to this distance.
4333             waga=forcon(i)
4334 C Calculate the contribution to energy.
4335             ehpb=ehpb+waga*rdis*rdis
4336 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4337 C
4338 C Evaluate gradient.
4339 C
4340             fac=waga*rdis/dd
4341           endif
4342 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4343 cd   &   ' waga=',waga,' fac=',fac
4344             do j=1,3
4345               ggg(j)=fac*(c(j,jj)-c(j,ii))
4346             enddo
4347 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4348 C If this is a SC-SC distance, we need to calculate the contributions to the
4349 C Cartesian gradient in the SC vectors (ghpbx).
4350           if (iii.lt.ii) then
4351           do j=1,3
4352             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4353             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4354           enddo
4355           endif
4356 cgrad        do j=iii,jjj-1
4357 cgrad          do k=1,3
4358 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4359 cgrad          enddo
4360 cgrad        enddo
4361           do k=1,3
4362             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4363             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4364           enddo
4365         endif
4366       enddo
4367       ehpb=0.5D0*ehpb
4368       return
4369       end
4370 C--------------------------------------------------------------------------
4371       subroutine ssbond_ene(i,j,eij)
4372 C
4373 C Calculate the distance and angle dependent SS-bond potential energy
4374 C using a free-energy function derived based on RHF/6-31G** ab initio
4375 C calculations of diethyl disulfide.
4376 C
4377 C A. Liwo and U. Kozlowska, 11/24/03
4378 C
4379       implicit real*8 (a-h,o-z)
4380       include 'DIMENSIONS'
4381       include 'COMMON.SBRIDGE'
4382       include 'COMMON.CHAIN'
4383       include 'COMMON.DERIV'
4384       include 'COMMON.LOCAL'
4385       include 'COMMON.INTERACT'
4386       include 'COMMON.VAR'
4387       include 'COMMON.IOUNITS'
4388       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4389       itypi=itype(i)
4390       xi=c(1,nres+i)
4391       yi=c(2,nres+i)
4392       zi=c(3,nres+i)
4393       dxi=dc_norm(1,nres+i)
4394       dyi=dc_norm(2,nres+i)
4395       dzi=dc_norm(3,nres+i)
4396 c      dsci_inv=dsc_inv(itypi)
4397       dsci_inv=vbld_inv(nres+i)
4398       itypj=itype(j)
4399 c      dscj_inv=dsc_inv(itypj)
4400       dscj_inv=vbld_inv(nres+j)
4401       xj=c(1,nres+j)-xi
4402       yj=c(2,nres+j)-yi
4403       zj=c(3,nres+j)-zi
4404       dxj=dc_norm(1,nres+j)
4405       dyj=dc_norm(2,nres+j)
4406       dzj=dc_norm(3,nres+j)
4407       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4408       rij=dsqrt(rrij)
4409       erij(1)=xj*rij
4410       erij(2)=yj*rij
4411       erij(3)=zj*rij
4412       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4413       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4414       om12=dxi*dxj+dyi*dyj+dzi*dzj
4415       do k=1,3
4416         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4417         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4418       enddo
4419       rij=1.0d0/rij
4420       deltad=rij-d0cm
4421       deltat1=1.0d0-om1
4422       deltat2=1.0d0+om2
4423       deltat12=om2-om1+2.0d0
4424       cosphi=om12-om1*om2
4425       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4426      &  +akct*deltad*deltat12
4427      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4428 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4429 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4430 c     &  " deltat12",deltat12," eij",eij
4431       ed=2*akcm*deltad+akct*deltat12
4432       pom1=akct*deltad
4433       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4434       eom1=-2*akth*deltat1-pom1-om2*pom2
4435       eom2= 2*akth*deltat2+pom1-om1*pom2
4436       eom12=pom2
4437       do k=1,3
4438         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4439         ghpbx(k,i)=ghpbx(k,i)-ggk
4440      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4441      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4442         ghpbx(k,j)=ghpbx(k,j)+ggk
4443      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4444      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4445         ghpbc(k,i)=ghpbc(k,i)-ggk
4446         ghpbc(k,j)=ghpbc(k,j)+ggk
4447       enddo
4448 C
4449 C Calculate the components of the gradient in DC and X
4450 C
4451 cgrad      do k=i,j-1
4452 cgrad        do l=1,3
4453 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4454 cgrad        enddo
4455 cgrad      enddo
4456       return
4457       end
4458 C--------------------------------------------------------------------------
4459       subroutine ebond(estr)
4460 c
4461 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4462 c
4463       implicit real*8 (a-h,o-z)
4464       include 'DIMENSIONS'
4465       include 'COMMON.LOCAL'
4466       include 'COMMON.GEO'
4467       include 'COMMON.INTERACT'
4468       include 'COMMON.DERIV'
4469       include 'COMMON.VAR'
4470       include 'COMMON.CHAIN'
4471       include 'COMMON.IOUNITS'
4472       include 'COMMON.NAMES'
4473       include 'COMMON.FFIELD'
4474       include 'COMMON.CONTROL'
4475       include 'COMMON.SETUP'
4476       double precision u(3),ud(3)
4477       estr=0.0d0
4478       do i=ibondp_start,ibondp_end
4479         diff = vbld(i)-vbldp0
4480 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4481         estr=estr+diff*diff
4482         do j=1,3
4483           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4484         enddo
4485 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4486       enddo
4487       estr=0.5d0*AKP*estr
4488 c
4489 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4490 c
4491       do i=ibond_start,ibond_end
4492         iti=itype(i)
4493         if (iti.ne.10) then
4494           nbi=nbondterm(iti)
4495           if (nbi.eq.1) then
4496             diff=vbld(i+nres)-vbldsc0(1,iti)
4497 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4498 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4499             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4500             do j=1,3
4501               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4502             enddo
4503           else
4504             do j=1,nbi
4505               diff=vbld(i+nres)-vbldsc0(j,iti)
4506               ud(j)=aksc(j,iti)*diff
4507               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4508             enddo
4509             uprod=u(1)
4510             do j=2,nbi
4511               uprod=uprod*u(j)
4512             enddo
4513             usum=0.0d0
4514             usumsqder=0.0d0
4515             do j=1,nbi
4516               uprod1=1.0d0
4517               uprod2=1.0d0
4518               do k=1,nbi
4519                 if (k.ne.j) then
4520                   uprod1=uprod1*u(k)
4521                   uprod2=uprod2*u(k)*u(k)
4522                 endif
4523               enddo
4524               usum=usum+uprod1
4525               usumsqder=usumsqder+ud(j)*uprod2
4526             enddo
4527             estr=estr+uprod/usum
4528             do j=1,3
4529              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4530             enddo
4531           endif
4532         endif
4533       enddo
4534       return
4535       end
4536 #ifdef CRYST_THETA
4537 C--------------------------------------------------------------------------
4538       subroutine ebend(etheta)
4539 C
4540 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4541 C angles gamma and its derivatives in consecutive thetas and gammas.
4542 C
4543       implicit real*8 (a-h,o-z)
4544       include 'DIMENSIONS'
4545       include 'COMMON.LOCAL'
4546       include 'COMMON.GEO'
4547       include 'COMMON.INTERACT'
4548       include 'COMMON.DERIV'
4549       include 'COMMON.VAR'
4550       include 'COMMON.CHAIN'
4551       include 'COMMON.IOUNITS'
4552       include 'COMMON.NAMES'
4553       include 'COMMON.FFIELD'
4554       include 'COMMON.CONTROL'
4555       common /calcthet/ term1,term2,termm,diffak,ratak,
4556      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4557      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4558       double precision y(2),z(2)
4559       delta=0.02d0*pi
4560 c      time11=dexp(-2*time)
4561 c      time12=1.0d0
4562       etheta=0.0D0
4563 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4564       do i=ithet_start,ithet_end
4565 C Zero the energy function and its derivative at 0 or pi.
4566         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4567         it=itype(i-1)
4568         if (i.gt.3) then
4569 #ifdef OSF
4570           phii=phi(i)
4571           if (phii.ne.phii) phii=150.0
4572 #else
4573           phii=phi(i)
4574 #endif
4575           y(1)=dcos(phii)
4576           y(2)=dsin(phii)
4577         else
4578           y(1)=0.0D0
4579           y(2)=0.0D0
4580         endif
4581         if (i.lt.nres) then
4582 #ifdef OSF
4583           phii1=phi(i+1)
4584           if (phii1.ne.phii1) phii1=150.0
4585           phii1=pinorm(phii1)
4586           z(1)=cos(phii1)
4587 #else
4588           phii1=phi(i+1)
4589           z(1)=dcos(phii1)
4590 #endif
4591           z(2)=dsin(phii1)
4592         else
4593           z(1)=0.0D0
4594           z(2)=0.0D0
4595         endif
4596 C Calculate the "mean" value of theta from the part of the distribution
4597 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4598 C In following comments this theta will be referred to as t_c.
4599         thet_pred_mean=0.0d0
4600         do k=1,2
4601           athetk=athet(k,it)
4602           bthetk=bthet(k,it)
4603           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4604         enddo
4605         dthett=thet_pred_mean*ssd
4606         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4607 C Derivatives of the "mean" values in gamma1 and gamma2.
4608         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4609         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4610         if (theta(i).gt.pi-delta) then
4611           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4612      &         E_tc0)
4613           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4614           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4615           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4616      &        E_theta)
4617           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4618      &        E_tc)
4619         else if (theta(i).lt.delta) then
4620           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4621           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4622           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4623      &        E_theta)
4624           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4625           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4626      &        E_tc)
4627         else
4628           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4629      &        E_theta,E_tc)
4630         endif
4631         etheta=etheta+ethetai
4632         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4633      &      'ebend',i,ethetai
4634         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4635         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4636         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4637       enddo
4638 C Ufff.... We've done all this!!!
4639       return
4640       end
4641 C---------------------------------------------------------------------------
4642       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4643      &     E_tc)
4644       implicit real*8 (a-h,o-z)
4645       include 'DIMENSIONS'
4646       include 'COMMON.LOCAL'
4647       include 'COMMON.IOUNITS'
4648       common /calcthet/ term1,term2,termm,diffak,ratak,
4649      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4650      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4651 C Calculate the contributions to both Gaussian lobes.
4652 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4653 C The "polynomial part" of the "standard deviation" of this part of
4654 C the distribution.
4655         sig=polthet(3,it)
4656         do j=2,0,-1
4657           sig=sig*thet_pred_mean+polthet(j,it)
4658         enddo
4659 C Derivative of the "interior part" of the "standard deviation of the"
4660 C gamma-dependent Gaussian lobe in t_c.
4661         sigtc=3*polthet(3,it)
4662         do j=2,1,-1
4663           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4664         enddo
4665         sigtc=sig*sigtc
4666 C Set the parameters of both Gaussian lobes of the distribution.
4667 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4668         fac=sig*sig+sigc0(it)
4669         sigcsq=fac+fac
4670         sigc=1.0D0/sigcsq
4671 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4672         sigsqtc=-4.0D0*sigcsq*sigtc
4673 c       print *,i,sig,sigtc,sigsqtc
4674 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4675         sigtc=-sigtc/(fac*fac)
4676 C Following variable is sigma(t_c)**(-2)
4677         sigcsq=sigcsq*sigcsq
4678         sig0i=sig0(it)
4679         sig0inv=1.0D0/sig0i**2
4680         delthec=thetai-thet_pred_mean
4681         delthe0=thetai-theta0i
4682         term1=-0.5D0*sigcsq*delthec*delthec
4683         term2=-0.5D0*sig0inv*delthe0*delthe0
4684 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4685 C NaNs in taking the logarithm. We extract the largest exponent which is added
4686 C to the energy (this being the log of the distribution) at the end of energy
4687 C term evaluation for this virtual-bond angle.
4688         if (term1.gt.term2) then
4689           termm=term1
4690           term2=dexp(term2-termm)
4691           term1=1.0d0
4692         else
4693           termm=term2
4694           term1=dexp(term1-termm)
4695           term2=1.0d0
4696         endif
4697 C The ratio between the gamma-independent and gamma-dependent lobes of
4698 C the distribution is a Gaussian function of thet_pred_mean too.
4699         diffak=gthet(2,it)-thet_pred_mean
4700         ratak=diffak/gthet(3,it)**2
4701         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4702 C Let's differentiate it in thet_pred_mean NOW.
4703         aktc=ak*ratak
4704 C Now put together the distribution terms to make complete distribution.
4705         termexp=term1+ak*term2
4706         termpre=sigc+ak*sig0i
4707 C Contribution of the bending energy from this theta is just the -log of
4708 C the sum of the contributions from the two lobes and the pre-exponential
4709 C factor. Simple enough, isn't it?
4710         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4711 C NOW the derivatives!!!
4712 C 6/6/97 Take into account the deformation.
4713         E_theta=(delthec*sigcsq*term1
4714      &       +ak*delthe0*sig0inv*term2)/termexp
4715         E_tc=((sigtc+aktc*sig0i)/termpre
4716      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4717      &       aktc*term2)/termexp)
4718       return
4719       end
4720 c-----------------------------------------------------------------------------
4721       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4722       implicit real*8 (a-h,o-z)
4723       include 'DIMENSIONS'
4724       include 'COMMON.LOCAL'
4725       include 'COMMON.IOUNITS'
4726       common /calcthet/ term1,term2,termm,diffak,ratak,
4727      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4728      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4729       delthec=thetai-thet_pred_mean
4730       delthe0=thetai-theta0i
4731 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4732       t3 = thetai-thet_pred_mean
4733       t6 = t3**2
4734       t9 = term1
4735       t12 = t3*sigcsq
4736       t14 = t12+t6*sigsqtc
4737       t16 = 1.0d0
4738       t21 = thetai-theta0i
4739       t23 = t21**2
4740       t26 = term2
4741       t27 = t21*t26
4742       t32 = termexp
4743       t40 = t32**2
4744       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4745      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4746      & *(-t12*t9-ak*sig0inv*t27)
4747       return
4748       end
4749 #else
4750 C--------------------------------------------------------------------------
4751       subroutine ebend(etheta)
4752 C
4753 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4754 C angles gamma and its derivatives in consecutive thetas and gammas.
4755 C ab initio-derived potentials from
4756 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4757 C
4758       implicit real*8 (a-h,o-z)
4759       include 'DIMENSIONS'
4760       include 'COMMON.LOCAL'
4761       include 'COMMON.GEO'
4762       include 'COMMON.INTERACT'
4763       include 'COMMON.DERIV'
4764       include 'COMMON.VAR'
4765       include 'COMMON.CHAIN'
4766       include 'COMMON.IOUNITS'
4767       include 'COMMON.NAMES'
4768       include 'COMMON.FFIELD'
4769       include 'COMMON.CONTROL'
4770       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4771      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4772      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4773      & sinph1ph2(maxdouble,maxdouble)
4774       logical lprn /.false./, lprn1 /.false./
4775       etheta=0.0D0
4776       do i=ithet_start,ithet_end
4777         dethetai=0.0d0
4778         dephii=0.0d0
4779         dephii1=0.0d0
4780         theti2=0.5d0*theta(i)
4781         ityp2=ithetyp(itype(i-1))
4782         do k=1,nntheterm
4783           coskt(k)=dcos(k*theti2)
4784           sinkt(k)=dsin(k*theti2)
4785         enddo
4786         if (i.gt.3) then
4787 #ifdef OSF
4788           phii=phi(i)
4789           if (phii.ne.phii) phii=150.0
4790 #else
4791           phii=phi(i)
4792 #endif
4793           ityp1=ithetyp(itype(i-2))
4794           do k=1,nsingle
4795             cosph1(k)=dcos(k*phii)
4796             sinph1(k)=dsin(k*phii)
4797           enddo
4798         else
4799           phii=0.0d0
4800           ityp1=nthetyp+1
4801           do k=1,nsingle
4802             cosph1(k)=0.0d0
4803             sinph1(k)=0.0d0
4804           enddo
4805         endif
4806         if (i.lt.nres) then
4807 #ifdef OSF
4808           phii1=phi(i+1)
4809           if (phii1.ne.phii1) phii1=150.0
4810           phii1=pinorm(phii1)
4811 #else
4812           phii1=phi(i+1)
4813 #endif
4814           ityp3=ithetyp(itype(i))
4815           do k=1,nsingle
4816             cosph2(k)=dcos(k*phii1)
4817             sinph2(k)=dsin(k*phii1)
4818           enddo
4819         else
4820           phii1=0.0d0
4821           ityp3=nthetyp+1
4822           do k=1,nsingle
4823             cosph2(k)=0.0d0
4824             sinph2(k)=0.0d0
4825           enddo
4826         endif
4827         ethetai=aa0thet(ityp1,ityp2,ityp3)
4828         do k=1,ndouble
4829           do l=1,k-1
4830             ccl=cosph1(l)*cosph2(k-l)
4831             ssl=sinph1(l)*sinph2(k-l)
4832             scl=sinph1(l)*cosph2(k-l)
4833             csl=cosph1(l)*sinph2(k-l)
4834             cosph1ph2(l,k)=ccl-ssl
4835             cosph1ph2(k,l)=ccl+ssl
4836             sinph1ph2(l,k)=scl+csl
4837             sinph1ph2(k,l)=scl-csl
4838           enddo
4839         enddo
4840         if (lprn) then
4841         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4842      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4843         write (iout,*) "coskt and sinkt"
4844         do k=1,nntheterm
4845           write (iout,*) k,coskt(k),sinkt(k)
4846         enddo
4847         endif
4848         do k=1,ntheterm
4849           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4850           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4851      &      *coskt(k)
4852           if (lprn)
4853      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4854      &     " ethetai",ethetai
4855         enddo
4856         if (lprn) then
4857         write (iout,*) "cosph and sinph"
4858         do k=1,nsingle
4859           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4860         enddo
4861         write (iout,*) "cosph1ph2 and sinph2ph2"
4862         do k=2,ndouble
4863           do l=1,k-1
4864             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4865      &         sinph1ph2(l,k),sinph1ph2(k,l)
4866           enddo
4867         enddo
4868         write(iout,*) "ethetai",ethetai
4869         endif
4870         do m=1,ntheterm2
4871           do k=1,nsingle
4872             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4873      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4874      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4875      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4876             ethetai=ethetai+sinkt(m)*aux
4877             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4878             dephii=dephii+k*sinkt(m)*(
4879      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4880      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4881             dephii1=dephii1+k*sinkt(m)*(
4882      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4883      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4884             if (lprn)
4885      &      write (iout,*) "m",m," k",k," bbthet",
4886      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4887      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4888      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4889      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4890           enddo
4891         enddo
4892         if (lprn)
4893      &  write(iout,*) "ethetai",ethetai
4894         do m=1,ntheterm3
4895           do k=2,ndouble
4896             do l=1,k-1
4897               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4898      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4899      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4900      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4901               ethetai=ethetai+sinkt(m)*aux
4902               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4903               dephii=dephii+l*sinkt(m)*(
4904      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4905      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4906      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4907      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4908               dephii1=dephii1+(k-l)*sinkt(m)*(
4909      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4910      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4911      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4912      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4913               if (lprn) then
4914               write (iout,*) "m",m," k",k," l",l," ffthet",
4915      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4916      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4917      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4918      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4919               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4920      &            cosph1ph2(k,l)*sinkt(m),
4921      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4922               endif
4923             enddo
4924           enddo
4925         enddo
4926 10      continue
4927         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4928      &   i,theta(i)*rad2deg,phii*rad2deg,
4929      &   phii1*rad2deg,ethetai
4930         etheta=etheta+ethetai
4931         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4932         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4933         gloc(nphi+i-2,icg)=wang*dethetai
4934       enddo
4935       return
4936       end
4937 #endif
4938 #ifdef CRYST_SC
4939 c-----------------------------------------------------------------------------
4940       subroutine esc(escloc)
4941 C Calculate the local energy of a side chain and its derivatives in the
4942 C corresponding virtual-bond valence angles THETA and the spherical angles
4943 C ALPHA and OMEGA.
4944       implicit real*8 (a-h,o-z)
4945       include 'DIMENSIONS'
4946       include 'COMMON.GEO'
4947       include 'COMMON.LOCAL'
4948       include 'COMMON.VAR'
4949       include 'COMMON.INTERACT'
4950       include 'COMMON.DERIV'
4951       include 'COMMON.CHAIN'
4952       include 'COMMON.IOUNITS'
4953       include 'COMMON.NAMES'
4954       include 'COMMON.FFIELD'
4955       include 'COMMON.CONTROL'
4956       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4957      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4958       common /sccalc/ time11,time12,time112,theti,it,nlobit
4959       delta=0.02d0*pi
4960       escloc=0.0D0
4961 c     write (iout,'(a)') 'ESC'
4962       do i=loc_start,loc_end
4963         it=itype(i)
4964         if (it.eq.10) goto 1
4965         nlobit=nlob(it)
4966 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4967 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4968         theti=theta(i+1)-pipol
4969         x(1)=dtan(theti)
4970         x(2)=alph(i)
4971         x(3)=omeg(i)
4972
4973         if (x(2).gt.pi-delta) then
4974           xtemp(1)=x(1)
4975           xtemp(2)=pi-delta
4976           xtemp(3)=x(3)
4977           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4978           xtemp(2)=pi
4979           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4980           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4981      &        escloci,dersc(2))
4982           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4983      &        ddersc0(1),dersc(1))
4984           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4985      &        ddersc0(3),dersc(3))
4986           xtemp(2)=pi-delta
4987           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4988           xtemp(2)=pi
4989           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4990           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4991      &            dersc0(2),esclocbi,dersc02)
4992           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4993      &            dersc12,dersc01)
4994           call splinthet(x(2),0.5d0*delta,ss,ssd)
4995           dersc0(1)=dersc01
4996           dersc0(2)=dersc02
4997           dersc0(3)=0.0d0
4998           do k=1,3
4999             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5000           enddo
5001           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5002 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5003 c    &             esclocbi,ss,ssd
5004           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5005 c         escloci=esclocbi
5006 c         write (iout,*) escloci
5007         else if (x(2).lt.delta) then
5008           xtemp(1)=x(1)
5009           xtemp(2)=delta
5010           xtemp(3)=x(3)
5011           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5012           xtemp(2)=0.0d0
5013           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5014           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5015      &        escloci,dersc(2))
5016           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5017      &        ddersc0(1),dersc(1))
5018           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5019      &        ddersc0(3),dersc(3))
5020           xtemp(2)=delta
5021           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5022           xtemp(2)=0.0d0
5023           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5024           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5025      &            dersc0(2),esclocbi,dersc02)
5026           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5027      &            dersc12,dersc01)
5028           dersc0(1)=dersc01
5029           dersc0(2)=dersc02
5030           dersc0(3)=0.0d0
5031           call splinthet(x(2),0.5d0*delta,ss,ssd)
5032           do k=1,3
5033             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5034           enddo
5035           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5036 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5037 c    &             esclocbi,ss,ssd
5038           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5039 c         write (iout,*) escloci
5040         else
5041           call enesc(x,escloci,dersc,ddummy,.false.)
5042         endif
5043
5044         escloc=escloc+escloci
5045         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5046      &     'escloc',i,escloci
5047 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5048
5049         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5050      &   wscloc*dersc(1)
5051         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5052         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5053     1   continue
5054       enddo
5055       return
5056       end
5057 C---------------------------------------------------------------------------
5058       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5059       implicit real*8 (a-h,o-z)
5060       include 'DIMENSIONS'
5061       include 'COMMON.GEO'
5062       include 'COMMON.LOCAL'
5063       include 'COMMON.IOUNITS'
5064       common /sccalc/ time11,time12,time112,theti,it,nlobit
5065       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5066       double precision contr(maxlob,-1:1)
5067       logical mixed
5068 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5069         escloc_i=0.0D0
5070         do j=1,3
5071           dersc(j)=0.0D0
5072           if (mixed) ddersc(j)=0.0d0
5073         enddo
5074         x3=x(3)
5075
5076 C Because of periodicity of the dependence of the SC energy in omega we have
5077 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5078 C To avoid underflows, first compute & store the exponents.
5079
5080         do iii=-1,1
5081
5082           x(3)=x3+iii*dwapi
5083
5084           do j=1,nlobit
5085             do k=1,3
5086               z(k)=x(k)-censc(k,j,it)
5087             enddo
5088             do k=1,3
5089               Axk=0.0D0
5090               do l=1,3
5091                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5092               enddo
5093               Ax(k,j,iii)=Axk
5094             enddo
5095             expfac=0.0D0
5096             do k=1,3
5097               expfac=expfac+Ax(k,j,iii)*z(k)
5098             enddo
5099             contr(j,iii)=expfac
5100           enddo ! j
5101
5102         enddo ! iii
5103
5104         x(3)=x3
5105 C As in the case of ebend, we want to avoid underflows in exponentiation and
5106 C subsequent NaNs and INFs in energy calculation.
5107 C Find the largest exponent
5108         emin=contr(1,-1)
5109         do iii=-1,1
5110           do j=1,nlobit
5111             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5112           enddo
5113         enddo
5114         emin=0.5D0*emin
5115 cd      print *,'it=',it,' emin=',emin
5116
5117 C Compute the contribution to SC energy and derivatives
5118         do iii=-1,1
5119
5120           do j=1,nlobit
5121 #ifdef OSF
5122             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5123             if(adexp.ne.adexp) adexp=1.0
5124             expfac=dexp(adexp)
5125 #else
5126             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5127 #endif
5128 cd          print *,'j=',j,' expfac=',expfac
5129             escloc_i=escloc_i+expfac
5130             do k=1,3
5131               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5132             enddo
5133             if (mixed) then
5134               do k=1,3,2
5135                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5136      &            +gaussc(k,2,j,it))*expfac
5137               enddo
5138             endif
5139           enddo
5140
5141         enddo ! iii
5142
5143         dersc(1)=dersc(1)/cos(theti)**2
5144         ddersc(1)=ddersc(1)/cos(theti)**2
5145         ddersc(3)=ddersc(3)
5146
5147         escloci=-(dlog(escloc_i)-emin)
5148         do j=1,3
5149           dersc(j)=dersc(j)/escloc_i
5150         enddo
5151         if (mixed) then
5152           do j=1,3,2
5153             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5154           enddo
5155         endif
5156       return
5157       end
5158 C------------------------------------------------------------------------------
5159       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5160       implicit real*8 (a-h,o-z)
5161       include 'DIMENSIONS'
5162       include 'COMMON.GEO'
5163       include 'COMMON.LOCAL'
5164       include 'COMMON.IOUNITS'
5165       common /sccalc/ time11,time12,time112,theti,it,nlobit
5166       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5167       double precision contr(maxlob)
5168       logical mixed
5169
5170       escloc_i=0.0D0
5171
5172       do j=1,3
5173         dersc(j)=0.0D0
5174       enddo
5175
5176       do j=1,nlobit
5177         do k=1,2
5178           z(k)=x(k)-censc(k,j,it)
5179         enddo
5180         z(3)=dwapi
5181         do k=1,3
5182           Axk=0.0D0
5183           do l=1,3
5184             Axk=Axk+gaussc(l,k,j,it)*z(l)
5185           enddo
5186           Ax(k,j)=Axk
5187         enddo
5188         expfac=0.0D0
5189         do k=1,3
5190           expfac=expfac+Ax(k,j)*z(k)
5191         enddo
5192         contr(j)=expfac
5193       enddo ! j
5194
5195 C As in the case of ebend, we want to avoid underflows in exponentiation and
5196 C subsequent NaNs and INFs in energy calculation.
5197 C Find the largest exponent
5198       emin=contr(1)
5199       do j=1,nlobit
5200         if (emin.gt.contr(j)) emin=contr(j)
5201       enddo
5202       emin=0.5D0*emin
5203
5204 C Compute the contribution to SC energy and derivatives
5205
5206       dersc12=0.0d0
5207       do j=1,nlobit
5208         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5209         escloc_i=escloc_i+expfac
5210         do k=1,2
5211           dersc(k)=dersc(k)+Ax(k,j)*expfac
5212         enddo
5213         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5214      &            +gaussc(1,2,j,it))*expfac
5215         dersc(3)=0.0d0
5216       enddo
5217
5218       dersc(1)=dersc(1)/cos(theti)**2
5219       dersc12=dersc12/cos(theti)**2
5220       escloci=-(dlog(escloc_i)-emin)
5221       do j=1,2
5222         dersc(j)=dersc(j)/escloc_i
5223       enddo
5224       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5225       return
5226       end
5227 #else
5228 c----------------------------------------------------------------------------------
5229       subroutine esc(escloc)
5230 C Calculate the local energy of a side chain and its derivatives in the
5231 C corresponding virtual-bond valence angles THETA and the spherical angles
5232 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5233 C added by Urszula Kozlowska. 07/11/2007
5234 C
5235       implicit real*8 (a-h,o-z)
5236       include 'DIMENSIONS'
5237       include 'COMMON.GEO'
5238       include 'COMMON.LOCAL'
5239       include 'COMMON.VAR'
5240       include 'COMMON.SCROT'
5241       include 'COMMON.INTERACT'
5242       include 'COMMON.DERIV'
5243       include 'COMMON.CHAIN'
5244       include 'COMMON.IOUNITS'
5245       include 'COMMON.NAMES'
5246       include 'COMMON.FFIELD'
5247       include 'COMMON.CONTROL'
5248       include 'COMMON.VECTORS'
5249       double precision x_prime(3),y_prime(3),z_prime(3)
5250      &    , sumene,dsc_i,dp2_i,x(65),
5251      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5252      &    de_dxx,de_dyy,de_dzz,de_dt
5253       double precision s1_t,s1_6_t,s2_t,s2_6_t
5254       double precision
5255      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5256      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5257      & dt_dCi(3),dt_dCi1(3)
5258       common /sccalc/ time11,time12,time112,theti,it,nlobit
5259       delta=0.02d0*pi
5260       escloc=0.0D0
5261       do i=loc_start,loc_end
5262         costtab(i+1) =dcos(theta(i+1))
5263         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5264         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5265         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5266         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5267         cosfac=dsqrt(cosfac2)
5268         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5269         sinfac=dsqrt(sinfac2)
5270         it=itype(i)
5271         if (it.eq.10) goto 1
5272 c
5273 C  Compute the axes of tghe local cartesian coordinates system; store in
5274 c   x_prime, y_prime and z_prime
5275 c
5276         do j=1,3
5277           x_prime(j) = 0.00
5278           y_prime(j) = 0.00
5279           z_prime(j) = 0.00
5280         enddo
5281 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5282 C     &   dc_norm(3,i+nres)
5283         do j = 1,3
5284           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5285           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5286         enddo
5287         do j = 1,3
5288           z_prime(j) = -uz(j,i-1)
5289         enddo
5290 c       write (2,*) "i",i
5291 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5292 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5293 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5294 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5295 c      & " xy",scalar(x_prime(1),y_prime(1)),
5296 c      & " xz",scalar(x_prime(1),z_prime(1)),
5297 c      & " yy",scalar(y_prime(1),y_prime(1)),
5298 c      & " yz",scalar(y_prime(1),z_prime(1)),
5299 c      & " zz",scalar(z_prime(1),z_prime(1))
5300 c
5301 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5302 C to local coordinate system. Store in xx, yy, zz.
5303 c
5304         xx=0.0d0
5305         yy=0.0d0
5306         zz=0.0d0
5307         do j = 1,3
5308           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5309           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5310           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5311         enddo
5312
5313         xxtab(i)=xx
5314         yytab(i)=yy
5315         zztab(i)=zz
5316 C
5317 C Compute the energy of the ith side cbain
5318 C
5319 c        write (2,*) "xx",xx," yy",yy," zz",zz
5320         it=itype(i)
5321         do j = 1,65
5322           x(j) = sc_parmin(j,it)
5323         enddo
5324 #ifdef CHECK_COORD
5325 Cc diagnostics - remove later
5326         xx1 = dcos(alph(2))
5327         yy1 = dsin(alph(2))*dcos(omeg(2))
5328         zz1 = -dsin(alph(2))*dsin(omeg(2))
5329         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5330      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5331      &    xx1,yy1,zz1
5332 C,"  --- ", xx_w,yy_w,zz_w
5333 c end diagnostics
5334 #endif
5335         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5336      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5337      &   + x(10)*yy*zz
5338         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5339      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5340      & + x(20)*yy*zz
5341         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5342      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5343      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5344      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5345      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5346      &  +x(40)*xx*yy*zz
5347         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5348      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5349      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5350      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5351      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5352      &  +x(60)*xx*yy*zz
5353         dsc_i   = 0.743d0+x(61)
5354         dp2_i   = 1.9d0+x(62)
5355         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5356      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5357         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5358      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5359         s1=(1+x(63))/(0.1d0 + dscp1)
5360         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5361         s2=(1+x(65))/(0.1d0 + dscp2)
5362         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5363         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5364      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5365 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5366 c     &   sumene4,
5367 c     &   dscp1,dscp2,sumene
5368 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5369         escloc = escloc + sumene
5370 c        write (2,*) "i",i," escloc",sumene,escloc
5371 #ifdef DEBUG
5372 C
5373 C This section to check the numerical derivatives of the energy of ith side
5374 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5375 C #define DEBUG in the code to turn it on.
5376 C
5377         write (2,*) "sumene               =",sumene
5378         aincr=1.0d-7
5379         xxsave=xx
5380         xx=xx+aincr
5381         write (2,*) xx,yy,zz
5382         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5383         de_dxx_num=(sumenep-sumene)/aincr
5384         xx=xxsave
5385         write (2,*) "xx+ sumene from enesc=",sumenep
5386         yysave=yy
5387         yy=yy+aincr
5388         write (2,*) xx,yy,zz
5389         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5390         de_dyy_num=(sumenep-sumene)/aincr
5391         yy=yysave
5392         write (2,*) "yy+ sumene from enesc=",sumenep
5393         zzsave=zz
5394         zz=zz+aincr
5395         write (2,*) xx,yy,zz
5396         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5397         de_dzz_num=(sumenep-sumene)/aincr
5398         zz=zzsave
5399         write (2,*) "zz+ sumene from enesc=",sumenep
5400         costsave=cost2tab(i+1)
5401         sintsave=sint2tab(i+1)
5402         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5403         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5404         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5405         de_dt_num=(sumenep-sumene)/aincr
5406         write (2,*) " t+ sumene from enesc=",sumenep
5407         cost2tab(i+1)=costsave
5408         sint2tab(i+1)=sintsave
5409 C End of diagnostics section.
5410 #endif
5411 C
5412 C Compute the gradient of esc
5413 C
5414         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5415         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5416         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5417         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5418         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5419         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5420         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5421         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5422         pom1=(sumene3*sint2tab(i+1)+sumene1)
5423      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5424         pom2=(sumene4*cost2tab(i+1)+sumene2)
5425      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5426         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5427         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5428      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5429      &  +x(40)*yy*zz
5430         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5431         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5432      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5433      &  +x(60)*yy*zz
5434         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5435      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5436      &        +(pom1+pom2)*pom_dx
5437 #ifdef DEBUG
5438         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5439 #endif
5440 C
5441         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5442         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5443      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5444      &  +x(40)*xx*zz
5445         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5446         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5447      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5448      &  +x(59)*zz**2 +x(60)*xx*zz
5449         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5450      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5451      &        +(pom1-pom2)*pom_dy
5452 #ifdef DEBUG
5453         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5454 #endif
5455 C
5456         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5457      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5458      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5459      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5460      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5461      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5462      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5463      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5464 #ifdef DEBUG
5465         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5466 #endif
5467 C
5468         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5469      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5470      &  +pom1*pom_dt1+pom2*pom_dt2
5471 #ifdef DEBUG
5472         write(2,*), "de_dt = ", de_dt,de_dt_num
5473 #endif
5474 c
5475 C
5476        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5477        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5478        cosfac2xx=cosfac2*xx
5479        sinfac2yy=sinfac2*yy
5480        do k = 1,3
5481          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5482      &      vbld_inv(i+1)
5483          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5484      &      vbld_inv(i)
5485          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5486          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5487 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5488 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5489 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5490 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5491          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5492          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5493          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5494          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5495          dZZ_Ci1(k)=0.0d0
5496          dZZ_Ci(k)=0.0d0
5497          do j=1,3
5498            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5499            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5500          enddo
5501
5502          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5503          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5504          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5505 c
5506          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5507          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5508        enddo
5509
5510        do k=1,3
5511          dXX_Ctab(k,i)=dXX_Ci(k)
5512          dXX_C1tab(k,i)=dXX_Ci1(k)
5513          dYY_Ctab(k,i)=dYY_Ci(k)
5514          dYY_C1tab(k,i)=dYY_Ci1(k)
5515          dZZ_Ctab(k,i)=dZZ_Ci(k)
5516          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5517          dXX_XYZtab(k,i)=dXX_XYZ(k)
5518          dYY_XYZtab(k,i)=dYY_XYZ(k)
5519          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5520        enddo
5521
5522        do k = 1,3
5523 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5524 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5525 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5526 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5527 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5528 c     &    dt_dci(k)
5529 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5530 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5531          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5532      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5533          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5534      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5535          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5536      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5537        enddo
5538 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5539 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5540
5541 C to check gradient call subroutine check_grad
5542
5543     1 continue
5544       enddo
5545       return
5546       end
5547 c------------------------------------------------------------------------------
5548       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5549       implicit none
5550       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5551      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5552       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5553      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5554      &   + x(10)*yy*zz
5555       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5556      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5557      & + x(20)*yy*zz
5558       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5559      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5560      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5561      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5562      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5563      &  +x(40)*xx*yy*zz
5564       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5565      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5566      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5567      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5568      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5569      &  +x(60)*xx*yy*zz
5570       dsc_i   = 0.743d0+x(61)
5571       dp2_i   = 1.9d0+x(62)
5572       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5573      &          *(xx*cost2+yy*sint2))
5574       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5575      &          *(xx*cost2-yy*sint2))
5576       s1=(1+x(63))/(0.1d0 + dscp1)
5577       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5578       s2=(1+x(65))/(0.1d0 + dscp2)
5579       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5580       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5581      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5582       enesc=sumene
5583       return
5584       end
5585 #endif
5586 c------------------------------------------------------------------------------
5587       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5588 C
5589 C This procedure calculates two-body contact function g(rij) and its derivative:
5590 C
5591 C           eps0ij                                     !       x < -1
5592 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5593 C            0                                         !       x > 1
5594 C
5595 C where x=(rij-r0ij)/delta
5596 C
5597 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5598 C
5599       implicit none
5600       double precision rij,r0ij,eps0ij,fcont,fprimcont
5601       double precision x,x2,x4,delta
5602 c     delta=0.02D0*r0ij
5603 c      delta=0.2D0*r0ij
5604       x=(rij-r0ij)/delta
5605       if (x.lt.-1.0D0) then
5606         fcont=eps0ij
5607         fprimcont=0.0D0
5608       else if (x.le.1.0D0) then
5609         x2=x*x
5610         x4=x2*x2
5611         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5612         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5613       else
5614         fcont=0.0D0
5615         fprimcont=0.0D0
5616       endif
5617       return
5618       end
5619 c------------------------------------------------------------------------------
5620       subroutine splinthet(theti,delta,ss,ssder)
5621       implicit real*8 (a-h,o-z)
5622       include 'DIMENSIONS'
5623       include 'COMMON.VAR'
5624       include 'COMMON.GEO'
5625       thetup=pi-delta
5626       thetlow=delta
5627       if (theti.gt.pipol) then
5628         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5629       else
5630         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5631         ssder=-ssder
5632       endif
5633       return
5634       end
5635 c------------------------------------------------------------------------------
5636       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5637       implicit none
5638       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5639       double precision ksi,ksi2,ksi3,a1,a2,a3
5640       a1=fprim0*delta/(f1-f0)
5641       a2=3.0d0-2.0d0*a1
5642       a3=a1-2.0d0
5643       ksi=(x-x0)/delta
5644       ksi2=ksi*ksi
5645       ksi3=ksi2*ksi
5646       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5647       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5648       return
5649       end
5650 c------------------------------------------------------------------------------
5651       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5652       implicit none
5653       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5654       double precision ksi,ksi2,ksi3,a1,a2,a3
5655       ksi=(x-x0)/delta
5656       ksi2=ksi*ksi
5657       ksi3=ksi2*ksi
5658       a1=fprim0x*delta
5659       a2=3*(f1x-f0x)-2*fprim0x*delta
5660       a3=fprim0x*delta-2*(f1x-f0x)
5661       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5662       return
5663       end
5664 C-----------------------------------------------------------------------------
5665 #ifdef CRYST_TOR
5666 C-----------------------------------------------------------------------------
5667       subroutine etor(etors,edihcnstr)
5668       implicit real*8 (a-h,o-z)
5669       include 'DIMENSIONS'
5670       include 'COMMON.VAR'
5671       include 'COMMON.GEO'
5672       include 'COMMON.LOCAL'
5673       include 'COMMON.TORSION'
5674       include 'COMMON.INTERACT'
5675       include 'COMMON.DERIV'
5676       include 'COMMON.CHAIN'
5677       include 'COMMON.NAMES'
5678       include 'COMMON.IOUNITS'
5679       include 'COMMON.FFIELD'
5680       include 'COMMON.TORCNSTR'
5681       include 'COMMON.CONTROL'
5682       logical lprn
5683 C Set lprn=.true. for debugging
5684       lprn=.false.
5685 c      lprn=.true.
5686       etors=0.0D0
5687       do i=iphi_start,iphi_end
5688       etors_ii=0.0D0
5689         itori=itortyp(itype(i-2))
5690         itori1=itortyp(itype(i-1))
5691         phii=phi(i)
5692         gloci=0.0D0
5693 C Proline-Proline pair is a special case...
5694         if (itori.eq.3 .and. itori1.eq.3) then
5695           if (phii.gt.-dwapi3) then
5696             cosphi=dcos(3*phii)
5697             fac=1.0D0/(1.0D0-cosphi)
5698             etorsi=v1(1,3,3)*fac
5699             etorsi=etorsi+etorsi
5700             etors=etors+etorsi-v1(1,3,3)
5701             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5702             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5703           endif
5704           do j=1,3
5705             v1ij=v1(j+1,itori,itori1)
5706             v2ij=v2(j+1,itori,itori1)
5707             cosphi=dcos(j*phii)
5708             sinphi=dsin(j*phii)
5709             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5710             if (energy_dec) etors_ii=etors_ii+
5711      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5712             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5713           enddo
5714         else
5715           do j=1,nterm_old
5716             v1ij=v1(j,itori,itori1)
5717             v2ij=v2(j,itori,itori1)
5718             cosphi=dcos(j*phii)
5719             sinphi=dsin(j*phii)
5720             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5721             if (energy_dec) etors_ii=etors_ii+
5722      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5723             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5724           enddo
5725         endif
5726         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5727      &        'etor',i,etors_ii
5728         if (lprn)
5729      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5730      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5731      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5732         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5733         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5734       enddo
5735 ! 6/20/98 - dihedral angle constraints
5736       edihcnstr=0.0d0
5737       do i=1,ndih_constr
5738         itori=idih_constr(i)
5739         phii=phi(itori)
5740         difi=phii-phi0(i)
5741         if (difi.gt.drange(i)) then
5742           difi=difi-drange(i)
5743           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5744           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5745         else if (difi.lt.-drange(i)) then
5746           difi=difi+drange(i)
5747           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5748           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5749         endif
5750 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5751 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5752       enddo
5753 !      write (iout,*) 'edihcnstr',edihcnstr
5754       return
5755       end
5756 c------------------------------------------------------------------------------
5757       subroutine etor_d(etors_d)
5758       etors_d=0.0d0
5759       return
5760       end
5761 c----------------------------------------------------------------------------
5762 #else
5763       subroutine etor(etors,edihcnstr)
5764       implicit real*8 (a-h,o-z)
5765       include 'DIMENSIONS'
5766       include 'COMMON.VAR'
5767       include 'COMMON.GEO'
5768       include 'COMMON.LOCAL'
5769       include 'COMMON.TORSION'
5770       include 'COMMON.INTERACT'
5771       include 'COMMON.DERIV'
5772       include 'COMMON.CHAIN'
5773       include 'COMMON.NAMES'
5774       include 'COMMON.IOUNITS'
5775       include 'COMMON.FFIELD'
5776       include 'COMMON.TORCNSTR'
5777       include 'COMMON.CONTROL'
5778       logical lprn
5779 C Set lprn=.true. for debugging
5780       lprn=.false.
5781 c     lprn=.true.
5782       etors=0.0D0
5783       do i=iphi_start,iphi_end
5784       etors_ii=0.0D0
5785         itori=itortyp(itype(i-2))
5786         itori1=itortyp(itype(i-1))
5787         phii=phi(i)
5788         gloci=0.0D0
5789 C Regular cosine and sine terms
5790         do j=1,nterm(itori,itori1)
5791           v1ij=v1(j,itori,itori1)
5792           v2ij=v2(j,itori,itori1)
5793           cosphi=dcos(j*phii)
5794           sinphi=dsin(j*phii)
5795           etors=etors+v1ij*cosphi+v2ij*sinphi
5796           if (energy_dec) etors_ii=etors_ii+
5797      &                v1ij*cosphi+v2ij*sinphi
5798           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5799         enddo
5800 C Lorentz terms
5801 C                         v1
5802 C  E = SUM ----------------------------------- - v1
5803 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5804 C
5805         cosphi=dcos(0.5d0*phii)
5806         sinphi=dsin(0.5d0*phii)
5807         do j=1,nlor(itori,itori1)
5808           vl1ij=vlor1(j,itori,itori1)
5809           vl2ij=vlor2(j,itori,itori1)
5810           vl3ij=vlor3(j,itori,itori1)
5811           pom=vl2ij*cosphi+vl3ij*sinphi
5812           pom1=1.0d0/(pom*pom+1.0d0)
5813           etors=etors+vl1ij*pom1
5814           if (energy_dec) etors_ii=etors_ii+
5815      &                vl1ij*pom1
5816           pom=-pom*pom1*pom1
5817           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5818         enddo
5819 C Subtract the constant term
5820         etors=etors-v0(itori,itori1)
5821           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5822      &         'etor',i,etors_ii-v0(itori,itori1)
5823         if (lprn)
5824      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5825      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5826      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5827         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5828 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5829       enddo
5830 ! 6/20/98 - dihedral angle constraints
5831       edihcnstr=0.0d0
5832 c      do i=1,ndih_constr
5833       do i=idihconstr_start,idihconstr_end
5834         itori=idih_constr(i)
5835         phii=phi(itori)
5836         difi=pinorm(phii-phi0(i))
5837         if (difi.gt.drange(i)) then
5838           difi=difi-drange(i)
5839           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5840           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5841         else if (difi.lt.-drange(i)) then
5842           difi=difi+drange(i)
5843           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5844           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5845         else
5846           difi=0.0
5847         endif
5848 c        write (iout,*) "gloci", gloc(i-3,icg)
5849 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5850 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5851 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5852       enddo
5853 cd       write (iout,*) 'edihcnstr',edihcnstr
5854       return
5855       end
5856 c----------------------------------------------------------------------------
5857       subroutine etor_d(etors_d)
5858 C 6/23/01 Compute double torsional energy
5859       implicit real*8 (a-h,o-z)
5860       include 'DIMENSIONS'
5861       include 'COMMON.VAR'
5862       include 'COMMON.GEO'
5863       include 'COMMON.LOCAL'
5864       include 'COMMON.TORSION'
5865       include 'COMMON.INTERACT'
5866       include 'COMMON.DERIV'
5867       include 'COMMON.CHAIN'
5868       include 'COMMON.NAMES'
5869       include 'COMMON.IOUNITS'
5870       include 'COMMON.FFIELD'
5871       include 'COMMON.TORCNSTR'
5872       logical lprn
5873 C Set lprn=.true. for debugging
5874       lprn=.false.
5875 c     lprn=.true.
5876       etors_d=0.0D0
5877       do i=iphid_start,iphid_end
5878         itori=itortyp(itype(i-2))
5879         itori1=itortyp(itype(i-1))
5880         itori2=itortyp(itype(i))
5881         phii=phi(i)
5882         phii1=phi(i+1)
5883         gloci1=0.0D0
5884         gloci2=0.0D0
5885         do j=1,ntermd_1(itori,itori1,itori2)
5886           v1cij=v1c(1,j,itori,itori1,itori2)
5887           v1sij=v1s(1,j,itori,itori1,itori2)
5888           v2cij=v1c(2,j,itori,itori1,itori2)
5889           v2sij=v1s(2,j,itori,itori1,itori2)
5890           cosphi1=dcos(j*phii)
5891           sinphi1=dsin(j*phii)
5892           cosphi2=dcos(j*phii1)
5893           sinphi2=dsin(j*phii1)
5894           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5895      &     v2cij*cosphi2+v2sij*sinphi2
5896           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5897           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5898         enddo
5899         do k=2,ntermd_2(itori,itori1,itori2)
5900           do l=1,k-1
5901             v1cdij = v2c(k,l,itori,itori1,itori2)
5902             v2cdij = v2c(l,k,itori,itori1,itori2)
5903             v1sdij = v2s(k,l,itori,itori1,itori2)
5904             v2sdij = v2s(l,k,itori,itori1,itori2)
5905             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5906             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5907             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5908             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5909             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5910      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5911             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5912      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5913             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5914      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5915           enddo
5916         enddo
5917         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5918         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5919 c        write (iout,*) "gloci", gloc(i-3,icg)
5920       enddo
5921       return
5922       end
5923 #endif
5924 c------------------------------------------------------------------------------
5925       subroutine eback_sc_corr(esccor)
5926 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5927 c        conformational states; temporarily implemented as differences
5928 c        between UNRES torsional potentials (dependent on three types of
5929 c        residues) and the torsional potentials dependent on all 20 types
5930 c        of residues computed from AM1  energy surfaces of terminally-blocked
5931 c        amino-acid residues.
5932       implicit real*8 (a-h,o-z)
5933       include 'DIMENSIONS'
5934       include 'COMMON.VAR'
5935       include 'COMMON.GEO'
5936       include 'COMMON.LOCAL'
5937       include 'COMMON.TORSION'
5938       include 'COMMON.SCCOR'
5939       include 'COMMON.INTERACT'
5940       include 'COMMON.DERIV'
5941       include 'COMMON.CHAIN'
5942       include 'COMMON.NAMES'
5943       include 'COMMON.IOUNITS'
5944       include 'COMMON.FFIELD'
5945       include 'COMMON.CONTROL'
5946       logical lprn
5947 C Set lprn=.true. for debugging
5948       lprn=.false.
5949 c      lprn=.true.
5950 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5951       esccor=0.0D0
5952       do i=itau_start,itau_end
5953         esccor_ii=0.0D0
5954         isccori=isccortyp(itype(i-2))
5955         isccori1=isccortyp(itype(i-1))
5956         phii=phi(i)
5957 cccc  Added 9 May 2012
5958 cc Tauangle is torsional engle depending on the value of first digit
5959 c(see comment below)
5960 cc Omicron is flat angle depending on the value of first digit
5961 c(see comment below)
5962
5963
5964         do intertyp=1,3 !intertyp
5965 cc Added 09 May 2012 (Adasko)
5966 cc  Intertyp means interaction type of backbone mainchain correlation:
5967 c   1 = SC...Ca...Ca...Ca
5968 c   2 = Ca...Ca...Ca...SC
5969 c   3 = SC...Ca...Ca...SCi
5970         gloci=0.0D0
5971         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5972      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5973      &      (itype(i-1).eq.21)))
5974      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5975      &     .or.(itype(i-2).eq.21)))
5976      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5977      &      (itype(i-1).eq.21)))) cycle
5978         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5979         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5980      & cycle
5981         do j=1,nterm_sccor(isccori,isccori1)
5982           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5983           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5984           cosphi=dcos(j*tauangle(intertyp,i))
5985           sinphi=dsin(j*tauangle(intertyp,i))
5986           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5987           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5988         enddo
5989         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5990 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5991 c     &gloc_sc(intertyp,i-3,icg)
5992         if (lprn)
5993      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5994      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5995      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5996      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5997         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5998        enddo !intertyp
5999       enddo
6000 c        do i=1,nres
6001 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6002 c        enddo
6003       return
6004       end
6005 c----------------------------------------------------------------------------
6006       subroutine multibody(ecorr)
6007 C This subroutine calculates multi-body contributions to energy following
6008 C the idea of Skolnick et al. If side chains I and J make a contact and
6009 C at the same time side chains I+1 and J+1 make a contact, an extra
6010 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6011       implicit real*8 (a-h,o-z)
6012       include 'DIMENSIONS'
6013       include 'COMMON.IOUNITS'
6014       include 'COMMON.DERIV'
6015       include 'COMMON.INTERACT'
6016       include 'COMMON.CONTACTS'
6017       double precision gx(3),gx1(3)
6018       logical lprn
6019
6020 C Set lprn=.true. for debugging
6021       lprn=.false.
6022
6023       if (lprn) then
6024         write (iout,'(a)') 'Contact function values:'
6025         do i=nnt,nct-2
6026           write (iout,'(i2,20(1x,i2,f10.5))')
6027      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6028         enddo
6029       endif
6030       ecorr=0.0D0
6031       do i=nnt,nct
6032         do j=1,3
6033           gradcorr(j,i)=0.0D0
6034           gradxorr(j,i)=0.0D0
6035         enddo
6036       enddo
6037       do i=nnt,nct-2
6038
6039         DO ISHIFT = 3,4
6040
6041         i1=i+ishift
6042         num_conti=num_cont(i)
6043         num_conti1=num_cont(i1)
6044         do jj=1,num_conti
6045           j=jcont(jj,i)
6046           do kk=1,num_conti1
6047             j1=jcont(kk,i1)
6048             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6049 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6050 cd   &                   ' ishift=',ishift
6051 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6052 C The system gains extra energy.
6053               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6054             endif   ! j1==j+-ishift
6055           enddo     ! kk
6056         enddo       ! jj
6057
6058         ENDDO ! ISHIFT
6059
6060       enddo         ! i
6061       return
6062       end
6063 c------------------------------------------------------------------------------
6064       double precision function esccorr(i,j,k,l,jj,kk)
6065       implicit real*8 (a-h,o-z)
6066       include 'DIMENSIONS'
6067       include 'COMMON.IOUNITS'
6068       include 'COMMON.DERIV'
6069       include 'COMMON.INTERACT'
6070       include 'COMMON.CONTACTS'
6071       double precision gx(3),gx1(3)
6072       logical lprn
6073       lprn=.false.
6074       eij=facont(jj,i)
6075       ekl=facont(kk,k)
6076 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6077 C Calculate the multi-body contribution to energy.
6078 C Calculate multi-body contributions to the gradient.
6079 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6080 cd   & k,l,(gacont(m,kk,k),m=1,3)
6081       do m=1,3
6082         gx(m) =ekl*gacont(m,jj,i)
6083         gx1(m)=eij*gacont(m,kk,k)
6084         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6085         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6086         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6087         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6088       enddo
6089       do m=i,j-1
6090         do ll=1,3
6091           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6092         enddo
6093       enddo
6094       do m=k,l-1
6095         do ll=1,3
6096           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6097         enddo
6098       enddo
6099       esccorr=-eij*ekl
6100       return
6101       end
6102 c------------------------------------------------------------------------------
6103       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6104 C This subroutine calculates multi-body contributions to hydrogen-bonding
6105       implicit real*8 (a-h,o-z)
6106       include 'DIMENSIONS'
6107       include 'COMMON.IOUNITS'
6108 #ifdef MPI
6109       include "mpif.h"
6110       parameter (max_cont=maxconts)
6111       parameter (max_dim=26)
6112       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6113       double precision zapas(max_dim,maxconts,max_fg_procs),
6114      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6115       common /przechowalnia/ zapas
6116       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6117      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6118 #endif
6119       include 'COMMON.SETUP'
6120       include 'COMMON.FFIELD'
6121       include 'COMMON.DERIV'
6122       include 'COMMON.INTERACT'
6123       include 'COMMON.CONTACTS'
6124       include 'COMMON.CONTROL'
6125       include 'COMMON.LOCAL'
6126       double precision gx(3),gx1(3),time00
6127       logical lprn,ldone
6128
6129 C Set lprn=.true. for debugging
6130       lprn=.false.
6131 #ifdef MPI
6132       n_corr=0
6133       n_corr1=0
6134       if (nfgtasks.le.1) goto 30
6135       if (lprn) then
6136         write (iout,'(a)') 'Contact function values before RECEIVE:'
6137         do i=nnt,nct-2
6138           write (iout,'(2i3,50(1x,i2,f5.2))')
6139      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6140      &    j=1,num_cont_hb(i))
6141         enddo
6142       endif
6143       call flush(iout)
6144       do i=1,ntask_cont_from
6145         ncont_recv(i)=0
6146       enddo
6147       do i=1,ntask_cont_to
6148         ncont_sent(i)=0
6149       enddo
6150 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6151 c     & ntask_cont_to
6152 C Make the list of contacts to send to send to other procesors
6153 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6154 c      call flush(iout)
6155       do i=iturn3_start,iturn3_end
6156 c        write (iout,*) "make contact list turn3",i," num_cont",
6157 c     &    num_cont_hb(i)
6158         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6159       enddo
6160       do i=iturn4_start,iturn4_end
6161 c        write (iout,*) "make contact list turn4",i," num_cont",
6162 c     &   num_cont_hb(i)
6163         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6164       enddo
6165       do ii=1,nat_sent
6166         i=iat_sent(ii)
6167 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6168 c     &    num_cont_hb(i)
6169         do j=1,num_cont_hb(i)
6170         do k=1,4
6171           jjc=jcont_hb(j,i)
6172           iproc=iint_sent_local(k,jjc,ii)
6173 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6174           if (iproc.gt.0) then
6175             ncont_sent(iproc)=ncont_sent(iproc)+1
6176             nn=ncont_sent(iproc)
6177             zapas(1,nn,iproc)=i
6178             zapas(2,nn,iproc)=jjc
6179             zapas(3,nn,iproc)=facont_hb(j,i)
6180             zapas(4,nn,iproc)=ees0p(j,i)
6181             zapas(5,nn,iproc)=ees0m(j,i)
6182             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6183             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6184             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6185             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6186             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6187             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6188             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6189             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6190             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6191             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6192             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6193             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6194             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6195             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6196             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6197             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6198             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6199             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6200             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6201             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6202             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6203           endif
6204         enddo
6205         enddo
6206       enddo
6207       if (lprn) then
6208       write (iout,*)
6209      &  "Numbers of contacts to be sent to other processors",
6210      &  (ncont_sent(i),i=1,ntask_cont_to)
6211       write (iout,*) "Contacts sent"
6212       do ii=1,ntask_cont_to
6213         nn=ncont_sent(ii)
6214         iproc=itask_cont_to(ii)
6215         write (iout,*) nn," contacts to processor",iproc,
6216      &   " of CONT_TO_COMM group"
6217         do i=1,nn
6218           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6219         enddo
6220       enddo
6221       call flush(iout)
6222       endif
6223       CorrelType=477
6224       CorrelID=fg_rank+1
6225       CorrelType1=478
6226       CorrelID1=nfgtasks+fg_rank+1
6227       ireq=0
6228 C Receive the numbers of needed contacts from other processors
6229       do ii=1,ntask_cont_from
6230         iproc=itask_cont_from(ii)
6231         ireq=ireq+1
6232         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6233      &    FG_COMM,req(ireq),IERR)
6234       enddo
6235 c      write (iout,*) "IRECV ended"
6236 c      call flush(iout)
6237 C Send the number of contacts needed by other processors
6238       do ii=1,ntask_cont_to
6239         iproc=itask_cont_to(ii)
6240         ireq=ireq+1
6241         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6242      &    FG_COMM,req(ireq),IERR)
6243       enddo
6244 c      write (iout,*) "ISEND ended"
6245 c      write (iout,*) "number of requests (nn)",ireq
6246       call flush(iout)
6247       if (ireq.gt.0)
6248      &  call MPI_Waitall(ireq,req,status_array,ierr)
6249 c      write (iout,*)
6250 c     &  "Numbers of contacts to be received from other processors",
6251 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6252 c      call flush(iout)
6253 C Receive contacts
6254       ireq=0
6255       do ii=1,ntask_cont_from
6256         iproc=itask_cont_from(ii)
6257         nn=ncont_recv(ii)
6258 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6259 c     &   " of CONT_TO_COMM group"
6260         call flush(iout)
6261         if (nn.gt.0) then
6262           ireq=ireq+1
6263           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6264      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6265 c          write (iout,*) "ireq,req",ireq,req(ireq)
6266         endif
6267       enddo
6268 C Send the contacts to processors that need them
6269       do ii=1,ntask_cont_to
6270         iproc=itask_cont_to(ii)
6271         nn=ncont_sent(ii)
6272 c        write (iout,*) nn," contacts to processor",iproc,
6273 c     &   " of CONT_TO_COMM group"
6274         if (nn.gt.0) then
6275           ireq=ireq+1
6276           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6277      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6278 c          write (iout,*) "ireq,req",ireq,req(ireq)
6279 c          do i=1,nn
6280 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6281 c          enddo
6282         endif
6283       enddo
6284 c      write (iout,*) "number of requests (contacts)",ireq
6285 c      write (iout,*) "req",(req(i),i=1,4)
6286 c      call flush(iout)
6287       if (ireq.gt.0)
6288      & call MPI_Waitall(ireq,req,status_array,ierr)
6289       do iii=1,ntask_cont_from
6290         iproc=itask_cont_from(iii)
6291         nn=ncont_recv(iii)
6292         if (lprn) then
6293         write (iout,*) "Received",nn," contacts from processor",iproc,
6294      &   " of CONT_FROM_COMM group"
6295         call flush(iout)
6296         do i=1,nn
6297           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6298         enddo
6299         call flush(iout)
6300         endif
6301         do i=1,nn
6302           ii=zapas_recv(1,i,iii)
6303 c Flag the received contacts to prevent double-counting
6304           jj=-zapas_recv(2,i,iii)
6305 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6306 c          call flush(iout)
6307           nnn=num_cont_hb(ii)+1
6308           num_cont_hb(ii)=nnn
6309           jcont_hb(nnn,ii)=jj
6310           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6311           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6312           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6313           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6314           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6315           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6316           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6317           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6318           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6319           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6320           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6321           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6322           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6323           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6324           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6325           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6326           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6327           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6328           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6329           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6330           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6331           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6332           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6333           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6334         enddo
6335       enddo
6336       call flush(iout)
6337       if (lprn) then
6338         write (iout,'(a)') 'Contact function values after receive:'
6339         do i=nnt,nct-2
6340           write (iout,'(2i3,50(1x,i3,f5.2))')
6341      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6342      &    j=1,num_cont_hb(i))
6343         enddo
6344         call flush(iout)
6345       endif
6346    30 continue
6347 #endif
6348       if (lprn) then
6349         write (iout,'(a)') 'Contact function values:'
6350         do i=nnt,nct-2
6351           write (iout,'(2i3,50(1x,i3,f5.2))')
6352      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6353      &    j=1,num_cont_hb(i))
6354         enddo
6355       endif
6356       ecorr=0.0D0
6357 C Remove the loop below after debugging !!!
6358       do i=nnt,nct
6359         do j=1,3
6360           gradcorr(j,i)=0.0D0
6361           gradxorr(j,i)=0.0D0
6362         enddo
6363       enddo
6364 C Calculate the local-electrostatic correlation terms
6365       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6366         i1=i+1
6367         num_conti=num_cont_hb(i)
6368         num_conti1=num_cont_hb(i+1)
6369         do jj=1,num_conti
6370           j=jcont_hb(jj,i)
6371           jp=iabs(j)
6372           do kk=1,num_conti1
6373             j1=jcont_hb(kk,i1)
6374             jp1=iabs(j1)
6375 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6376 c     &         ' jj=',jj,' kk=',kk
6377             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6378      &          .or. j.lt.0 .and. j1.gt.0) .and.
6379      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6380 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6381 C The system gains extra energy.
6382               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6383               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6384      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6385               n_corr=n_corr+1
6386             else if (j1.eq.j) then
6387 C Contacts I-J and I-(J+1) occur simultaneously.
6388 C The system loses extra energy.
6389 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6390             endif
6391           enddo ! kk
6392           do kk=1,num_conti
6393             j1=jcont_hb(kk,i)
6394 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6395 c    &         ' jj=',jj,' kk=',kk
6396             if (j1.eq.j+1) then
6397 C Contacts I-J and (I+1)-J occur simultaneously.
6398 C The system loses extra energy.
6399 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6400             endif ! j1==j+1
6401           enddo ! kk
6402         enddo ! jj
6403       enddo ! i
6404       return
6405       end
6406 c------------------------------------------------------------------------------
6407       subroutine add_hb_contact(ii,jj,itask)
6408       implicit real*8 (a-h,o-z)
6409       include "DIMENSIONS"
6410       include "COMMON.IOUNITS"
6411       integer max_cont
6412       integer max_dim
6413       parameter (max_cont=maxconts)
6414       parameter (max_dim=26)
6415       include "COMMON.CONTACTS"
6416       double precision zapas(max_dim,maxconts,max_fg_procs),
6417      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6418       common /przechowalnia/ zapas
6419       integer i,j,ii,jj,iproc,itask(4),nn
6420 c      write (iout,*) "itask",itask
6421       do i=1,2
6422         iproc=itask(i)
6423         if (iproc.gt.0) then
6424           do j=1,num_cont_hb(ii)
6425             jjc=jcont_hb(j,ii)
6426 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6427             if (jjc.eq.jj) then
6428               ncont_sent(iproc)=ncont_sent(iproc)+1
6429               nn=ncont_sent(iproc)
6430               zapas(1,nn,iproc)=ii
6431               zapas(2,nn,iproc)=jjc
6432               zapas(3,nn,iproc)=facont_hb(j,ii)
6433               zapas(4,nn,iproc)=ees0p(j,ii)
6434               zapas(5,nn,iproc)=ees0m(j,ii)
6435               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6436               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6437               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6438               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6439               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6440               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6441               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6442               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6443               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6444               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6445               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6446               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6447               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6448               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6449               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6450               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6451               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6452               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6453               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6454               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6455               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6456               exit
6457             endif
6458           enddo
6459         endif
6460       enddo
6461       return
6462       end
6463 c------------------------------------------------------------------------------
6464       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6465      &  n_corr1)
6466 C This subroutine calculates multi-body contributions to hydrogen-bonding
6467       implicit real*8 (a-h,o-z)
6468       include 'DIMENSIONS'
6469       include 'COMMON.IOUNITS'
6470 #ifdef MPI
6471       include "mpif.h"
6472       parameter (max_cont=maxconts)
6473       parameter (max_dim=70)
6474       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6475       double precision zapas(max_dim,maxconts,max_fg_procs),
6476      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6477       common /przechowalnia/ zapas
6478       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6479      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6480 #endif
6481       include 'COMMON.SETUP'
6482       include 'COMMON.FFIELD'
6483       include 'COMMON.DERIV'
6484       include 'COMMON.LOCAL'
6485       include 'COMMON.INTERACT'
6486       include 'COMMON.CONTACTS'
6487       include 'COMMON.CHAIN'
6488       include 'COMMON.CONTROL'
6489       double precision gx(3),gx1(3)
6490       integer num_cont_hb_old(maxres)
6491       logical lprn,ldone
6492       double precision eello4,eello5,eelo6,eello_turn6
6493       external eello4,eello5,eello6,eello_turn6
6494 C Set lprn=.true. for debugging
6495       lprn=.false.
6496       eturn6=0.0d0
6497 #ifdef MPI
6498       do i=1,nres
6499         num_cont_hb_old(i)=num_cont_hb(i)
6500       enddo
6501       n_corr=0
6502       n_corr1=0
6503       if (nfgtasks.le.1) goto 30
6504       if (lprn) then
6505         write (iout,'(a)') 'Contact function values before RECEIVE:'
6506         do i=nnt,nct-2
6507           write (iout,'(2i3,50(1x,i2,f5.2))')
6508      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6509      &    j=1,num_cont_hb(i))
6510         enddo
6511       endif
6512       call flush(iout)
6513       do i=1,ntask_cont_from
6514         ncont_recv(i)=0
6515       enddo
6516       do i=1,ntask_cont_to
6517         ncont_sent(i)=0
6518       enddo
6519 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6520 c     & ntask_cont_to
6521 C Make the list of contacts to send to send to other procesors
6522       do i=iturn3_start,iturn3_end
6523 c        write (iout,*) "make contact list turn3",i," num_cont",
6524 c     &    num_cont_hb(i)
6525         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6526       enddo
6527       do i=iturn4_start,iturn4_end
6528 c        write (iout,*) "make contact list turn4",i," num_cont",
6529 c     &   num_cont_hb(i)
6530         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6531       enddo
6532       do ii=1,nat_sent
6533         i=iat_sent(ii)
6534 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6535 c     &    num_cont_hb(i)
6536         do j=1,num_cont_hb(i)
6537         do k=1,4
6538           jjc=jcont_hb(j,i)
6539           iproc=iint_sent_local(k,jjc,ii)
6540 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6541           if (iproc.ne.0) then
6542             ncont_sent(iproc)=ncont_sent(iproc)+1
6543             nn=ncont_sent(iproc)
6544             zapas(1,nn,iproc)=i
6545             zapas(2,nn,iproc)=jjc
6546             zapas(3,nn,iproc)=d_cont(j,i)
6547             ind=3
6548             do kk=1,3
6549               ind=ind+1
6550               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6551             enddo
6552             do kk=1,2
6553               do ll=1,2
6554                 ind=ind+1
6555                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6556               enddo
6557             enddo
6558             do jj=1,5
6559               do kk=1,3
6560                 do ll=1,2
6561                   do mm=1,2
6562                     ind=ind+1
6563                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6564                   enddo
6565                 enddo
6566               enddo
6567             enddo
6568           endif
6569         enddo
6570         enddo
6571       enddo
6572       if (lprn) then
6573       write (iout,*)
6574      &  "Numbers of contacts to be sent to other processors",
6575      &  (ncont_sent(i),i=1,ntask_cont_to)
6576       write (iout,*) "Contacts sent"
6577       do ii=1,ntask_cont_to
6578         nn=ncont_sent(ii)
6579         iproc=itask_cont_to(ii)
6580         write (iout,*) nn," contacts to processor",iproc,
6581      &   " of CONT_TO_COMM group"
6582         do i=1,nn
6583           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6584         enddo
6585       enddo
6586       call flush(iout)
6587       endif
6588       CorrelType=477
6589       CorrelID=fg_rank+1
6590       CorrelType1=478
6591       CorrelID1=nfgtasks+fg_rank+1
6592       ireq=0
6593 C Receive the numbers of needed contacts from other processors
6594       do ii=1,ntask_cont_from
6595         iproc=itask_cont_from(ii)
6596         ireq=ireq+1
6597         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6598      &    FG_COMM,req(ireq),IERR)
6599       enddo
6600 c      write (iout,*) "IRECV ended"
6601 c      call flush(iout)
6602 C Send the number of contacts needed by other processors
6603       do ii=1,ntask_cont_to
6604         iproc=itask_cont_to(ii)
6605         ireq=ireq+1
6606         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6607      &    FG_COMM,req(ireq),IERR)
6608       enddo
6609 c      write (iout,*) "ISEND ended"
6610 c      write (iout,*) "number of requests (nn)",ireq
6611       call flush(iout)
6612       if (ireq.gt.0)
6613      &  call MPI_Waitall(ireq,req,status_array,ierr)
6614 c      write (iout,*)
6615 c     &  "Numbers of contacts to be received from other processors",
6616 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6617 c      call flush(iout)
6618 C Receive contacts
6619       ireq=0
6620       do ii=1,ntask_cont_from
6621         iproc=itask_cont_from(ii)
6622         nn=ncont_recv(ii)
6623 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6624 c     &   " of CONT_TO_COMM group"
6625         call flush(iout)
6626         if (nn.gt.0) then
6627           ireq=ireq+1
6628           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6629      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6630 c          write (iout,*) "ireq,req",ireq,req(ireq)
6631         endif
6632       enddo
6633 C Send the contacts to processors that need them
6634       do ii=1,ntask_cont_to
6635         iproc=itask_cont_to(ii)
6636         nn=ncont_sent(ii)
6637 c        write (iout,*) nn," contacts to processor",iproc,
6638 c     &   " of CONT_TO_COMM group"
6639         if (nn.gt.0) then
6640           ireq=ireq+1
6641           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6642      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6643 c          write (iout,*) "ireq,req",ireq,req(ireq)
6644 c          do i=1,nn
6645 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6646 c          enddo
6647         endif
6648       enddo
6649 c      write (iout,*) "number of requests (contacts)",ireq
6650 c      write (iout,*) "req",(req(i),i=1,4)
6651 c      call flush(iout)
6652       if (ireq.gt.0)
6653      & call MPI_Waitall(ireq,req,status_array,ierr)
6654       do iii=1,ntask_cont_from
6655         iproc=itask_cont_from(iii)
6656         nn=ncont_recv(iii)
6657         if (lprn) then
6658         write (iout,*) "Received",nn," contacts from processor",iproc,
6659      &   " of CONT_FROM_COMM group"
6660         call flush(iout)
6661         do i=1,nn
6662           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6663         enddo
6664         call flush(iout)
6665         endif
6666         do i=1,nn
6667           ii=zapas_recv(1,i,iii)
6668 c Flag the received contacts to prevent double-counting
6669           jj=-zapas_recv(2,i,iii)
6670 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6671 c          call flush(iout)
6672           nnn=num_cont_hb(ii)+1
6673           num_cont_hb(ii)=nnn
6674           jcont_hb(nnn,ii)=jj
6675           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6676           ind=3
6677           do kk=1,3
6678             ind=ind+1
6679             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6680           enddo
6681           do kk=1,2
6682             do ll=1,2
6683               ind=ind+1
6684               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6685             enddo
6686           enddo
6687           do jj=1,5
6688             do kk=1,3
6689               do ll=1,2
6690                 do mm=1,2
6691                   ind=ind+1
6692                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6693                 enddo
6694               enddo
6695             enddo
6696           enddo
6697         enddo
6698       enddo
6699       call flush(iout)
6700       if (lprn) then
6701         write (iout,'(a)') 'Contact function values after receive:'
6702         do i=nnt,nct-2
6703           write (iout,'(2i3,50(1x,i3,5f6.3))')
6704      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6705      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6706         enddo
6707         call flush(iout)
6708       endif
6709    30 continue
6710 #endif
6711       if (lprn) then
6712         write (iout,'(a)') 'Contact function values:'
6713         do i=nnt,nct-2
6714           write (iout,'(2i3,50(1x,i2,5f6.3))')
6715      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6716      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6717         enddo
6718       endif
6719       ecorr=0.0D0
6720       ecorr5=0.0d0
6721       ecorr6=0.0d0
6722 C Remove the loop below after debugging !!!
6723       do i=nnt,nct
6724         do j=1,3
6725           gradcorr(j,i)=0.0D0
6726           gradxorr(j,i)=0.0D0
6727         enddo
6728       enddo
6729 C Calculate the dipole-dipole interaction energies
6730       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6731       do i=iatel_s,iatel_e+1
6732         num_conti=num_cont_hb(i)
6733         do jj=1,num_conti
6734           j=jcont_hb(jj,i)
6735 #ifdef MOMENT
6736           call dipole(i,j,jj)
6737 #endif
6738         enddo
6739       enddo
6740       endif
6741 C Calculate the local-electrostatic correlation terms
6742 c                write (iout,*) "gradcorr5 in eello5 before loop"
6743 c                do iii=1,nres
6744 c                  write (iout,'(i5,3f10.5)')
6745 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6746 c                enddo
6747       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6748 c        write (iout,*) "corr loop i",i
6749         i1=i+1
6750         num_conti=num_cont_hb(i)
6751         num_conti1=num_cont_hb(i+1)
6752         do jj=1,num_conti
6753           j=jcont_hb(jj,i)
6754           jp=iabs(j)
6755           do kk=1,num_conti1
6756             j1=jcont_hb(kk,i1)
6757             jp1=iabs(j1)
6758 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6759 c     &         ' jj=',jj,' kk=',kk
6760 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6761             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6762      &          .or. j.lt.0 .and. j1.gt.0) .and.
6763      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6764 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6765 C The system gains extra energy.
6766               n_corr=n_corr+1
6767               sqd1=dsqrt(d_cont(jj,i))
6768               sqd2=dsqrt(d_cont(kk,i1))
6769               sred_geom = sqd1*sqd2
6770               IF (sred_geom.lt.cutoff_corr) THEN
6771                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6772      &            ekont,fprimcont)
6773 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6774 cd     &         ' jj=',jj,' kk=',kk
6775                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6776                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6777                 do l=1,3
6778                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6779                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6780                 enddo
6781                 n_corr1=n_corr1+1
6782 cd               write (iout,*) 'sred_geom=',sred_geom,
6783 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6784 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6785 cd               write (iout,*) "g_contij",g_contij
6786 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6787 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6788                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6789                 if (wcorr4.gt.0.0d0)
6790      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6791                   if (energy_dec.and.wcorr4.gt.0.0d0)
6792      1                 write (iout,'(a6,4i5,0pf7.3)')
6793      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6794 c                write (iout,*) "gradcorr5 before eello5"
6795 c                do iii=1,nres
6796 c                  write (iout,'(i5,3f10.5)')
6797 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6798 c                enddo
6799                 if (wcorr5.gt.0.0d0)
6800      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6801 c                write (iout,*) "gradcorr5 after eello5"
6802 c                do iii=1,nres
6803 c                  write (iout,'(i5,3f10.5)')
6804 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6805 c                enddo
6806                   if (energy_dec.and.wcorr5.gt.0.0d0)
6807      1                 write (iout,'(a6,4i5,0pf7.3)')
6808      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6809 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6810 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6811                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6812      &               .or. wturn6.eq.0.0d0))then
6813 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6814                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6815                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6816      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6817 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6818 cd     &            'ecorr6=',ecorr6
6819 cd                write (iout,'(4e15.5)') sred_geom,
6820 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6821 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6822 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6823                 else if (wturn6.gt.0.0d0
6824      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6825 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6826                   eturn6=eturn6+eello_turn6(i,jj,kk)
6827                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6828      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6829 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6830                 endif
6831               ENDIF
6832 1111          continue
6833             endif
6834           enddo ! kk
6835         enddo ! jj
6836       enddo ! i
6837       do i=1,nres
6838         num_cont_hb(i)=num_cont_hb_old(i)
6839       enddo
6840 c                write (iout,*) "gradcorr5 in eello5"
6841 c                do iii=1,nres
6842 c                  write (iout,'(i5,3f10.5)')
6843 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6844 c                enddo
6845       return
6846       end
6847 c------------------------------------------------------------------------------
6848       subroutine add_hb_contact_eello(ii,jj,itask)
6849       implicit real*8 (a-h,o-z)
6850       include "DIMENSIONS"
6851       include "COMMON.IOUNITS"
6852       integer max_cont
6853       integer max_dim
6854       parameter (max_cont=maxconts)
6855       parameter (max_dim=70)
6856       include "COMMON.CONTACTS"
6857       double precision zapas(max_dim,maxconts,max_fg_procs),
6858      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6859       common /przechowalnia/ zapas
6860       integer i,j,ii,jj,iproc,itask(4),nn
6861 c      write (iout,*) "itask",itask
6862       do i=1,2
6863         iproc=itask(i)
6864         if (iproc.gt.0) then
6865           do j=1,num_cont_hb(ii)
6866             jjc=jcont_hb(j,ii)
6867 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6868             if (jjc.eq.jj) then
6869               ncont_sent(iproc)=ncont_sent(iproc)+1
6870               nn=ncont_sent(iproc)
6871               zapas(1,nn,iproc)=ii
6872               zapas(2,nn,iproc)=jjc
6873               zapas(3,nn,iproc)=d_cont(j,ii)
6874               ind=3
6875               do kk=1,3
6876                 ind=ind+1
6877                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6878               enddo
6879               do kk=1,2
6880                 do ll=1,2
6881                   ind=ind+1
6882                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6883                 enddo
6884               enddo
6885               do jj=1,5
6886                 do kk=1,3
6887                   do ll=1,2
6888                     do mm=1,2
6889                       ind=ind+1
6890                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6891                     enddo
6892                   enddo
6893                 enddo
6894               enddo
6895               exit
6896             endif
6897           enddo
6898         endif
6899       enddo
6900       return
6901       end
6902 c------------------------------------------------------------------------------
6903       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6904       implicit real*8 (a-h,o-z)
6905       include 'DIMENSIONS'
6906       include 'COMMON.IOUNITS'
6907       include 'COMMON.DERIV'
6908       include 'COMMON.INTERACT'
6909       include 'COMMON.CONTACTS'
6910       double precision gx(3),gx1(3)
6911       logical lprn
6912       lprn=.false.
6913       eij=facont_hb(jj,i)
6914       ekl=facont_hb(kk,k)
6915       ees0pij=ees0p(jj,i)
6916       ees0pkl=ees0p(kk,k)
6917       ees0mij=ees0m(jj,i)
6918       ees0mkl=ees0m(kk,k)
6919       ekont=eij*ekl
6920       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6921 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6922 C Following 4 lines for diagnostics.
6923 cd    ees0pkl=0.0D0
6924 cd    ees0pij=1.0D0
6925 cd    ees0mkl=0.0D0
6926 cd    ees0mij=1.0D0
6927 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6928 c     & 'Contacts ',i,j,
6929 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6930 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6931 c     & 'gradcorr_long'
6932 C Calculate the multi-body contribution to energy.
6933 c      ecorr=ecorr+ekont*ees
6934 C Calculate multi-body contributions to the gradient.
6935       coeffpees0pij=coeffp*ees0pij
6936       coeffmees0mij=coeffm*ees0mij
6937       coeffpees0pkl=coeffp*ees0pkl
6938       coeffmees0mkl=coeffm*ees0mkl
6939       do ll=1,3
6940 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6941         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6942      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6943      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6944         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6945      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6946      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6947 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6948         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6949      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6950      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6951         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6952      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6953      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6954         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6955      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6956      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6957         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6958         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6959         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6960      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6961      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6962         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6963         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6964 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6965       enddo
6966 c      write (iout,*)
6967 cgrad      do m=i+1,j-1
6968 cgrad        do ll=1,3
6969 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6970 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6971 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6972 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6973 cgrad        enddo
6974 cgrad      enddo
6975 cgrad      do m=k+1,l-1
6976 cgrad        do ll=1,3
6977 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6978 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6979 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6980 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6981 cgrad        enddo
6982 cgrad      enddo
6983 c      write (iout,*) "ehbcorr",ekont*ees
6984       ehbcorr=ekont*ees
6985       return
6986       end
6987 #ifdef MOMENT
6988 C---------------------------------------------------------------------------
6989       subroutine dipole(i,j,jj)
6990       implicit real*8 (a-h,o-z)
6991       include 'DIMENSIONS'
6992       include 'COMMON.IOUNITS'
6993       include 'COMMON.CHAIN'
6994       include 'COMMON.FFIELD'
6995       include 'COMMON.DERIV'
6996       include 'COMMON.INTERACT'
6997       include 'COMMON.CONTACTS'
6998       include 'COMMON.TORSION'
6999       include 'COMMON.VAR'
7000       include 'COMMON.GEO'
7001       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7002      &  auxmat(2,2)
7003       iti1 = itortyp(itype(i+1))
7004       if (j.lt.nres-1) then
7005         itj1 = itortyp(itype(j+1))
7006       else
7007         itj1=ntortyp+1
7008       endif
7009       do iii=1,2
7010         dipi(iii,1)=Ub2(iii,i)
7011         dipderi(iii)=Ub2der(iii,i)
7012         dipi(iii,2)=b1(iii,iti1)
7013         dipj(iii,1)=Ub2(iii,j)
7014         dipderj(iii)=Ub2der(iii,j)
7015         dipj(iii,2)=b1(iii,itj1)
7016       enddo
7017       kkk=0
7018       do iii=1,2
7019         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7020         do jjj=1,2
7021           kkk=kkk+1
7022           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7023         enddo
7024       enddo
7025       do kkk=1,5
7026         do lll=1,3
7027           mmm=0
7028           do iii=1,2
7029             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7030      &        auxvec(1))
7031             do jjj=1,2
7032               mmm=mmm+1
7033               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7034             enddo
7035           enddo
7036         enddo
7037       enddo
7038       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7039       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7040       do iii=1,2
7041         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7042       enddo
7043       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7044       do iii=1,2
7045         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7046       enddo
7047       return
7048       end
7049 #endif
7050 C---------------------------------------------------------------------------
7051       subroutine calc_eello(i,j,k,l,jj,kk)
7052 C
7053 C This subroutine computes matrices and vectors needed to calculate
7054 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7055 C
7056       implicit real*8 (a-h,o-z)
7057       include 'DIMENSIONS'
7058       include 'COMMON.IOUNITS'
7059       include 'COMMON.CHAIN'
7060       include 'COMMON.DERIV'
7061       include 'COMMON.INTERACT'
7062       include 'COMMON.CONTACTS'
7063       include 'COMMON.TORSION'
7064       include 'COMMON.VAR'
7065       include 'COMMON.GEO'
7066       include 'COMMON.FFIELD'
7067       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7068      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7069       logical lprn
7070       common /kutas/ lprn
7071 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7072 cd     & ' jj=',jj,' kk=',kk
7073 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7074 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7075 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7076       do iii=1,2
7077         do jjj=1,2
7078           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7079           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7080         enddo
7081       enddo
7082       call transpose2(aa1(1,1),aa1t(1,1))
7083       call transpose2(aa2(1,1),aa2t(1,1))
7084       do kkk=1,5
7085         do lll=1,3
7086           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7087      &      aa1tder(1,1,lll,kkk))
7088           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7089      &      aa2tder(1,1,lll,kkk))
7090         enddo
7091       enddo
7092       if (l.eq.j+1) then
7093 C parallel orientation of the two CA-CA-CA frames.
7094         if (i.gt.1) then
7095           iti=itortyp(itype(i))
7096         else
7097           iti=ntortyp+1
7098         endif
7099         itk1=itortyp(itype(k+1))
7100         itj=itortyp(itype(j))
7101         if (l.lt.nres-1) then
7102           itl1=itortyp(itype(l+1))
7103         else
7104           itl1=ntortyp+1
7105         endif
7106 C A1 kernel(j+1) A2T
7107 cd        do iii=1,2
7108 cd          write (iout,'(3f10.5,5x,3f10.5)')
7109 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7110 cd        enddo
7111         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7112      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7113      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7114 C Following matrices are needed only for 6-th order cumulants
7115         IF (wcorr6.gt.0.0d0) THEN
7116         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7117      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7118      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7119         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7120      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7121      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7122      &   ADtEAderx(1,1,1,1,1,1))
7123         lprn=.false.
7124         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7125      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7126      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7127      &   ADtEA1derx(1,1,1,1,1,1))
7128         ENDIF
7129 C End 6-th order cumulants
7130 cd        lprn=.false.
7131 cd        if (lprn) then
7132 cd        write (2,*) 'In calc_eello6'
7133 cd        do iii=1,2
7134 cd          write (2,*) 'iii=',iii
7135 cd          do kkk=1,5
7136 cd            write (2,*) 'kkk=',kkk
7137 cd            do jjj=1,2
7138 cd              write (2,'(3(2f10.5),5x)')
7139 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7140 cd            enddo
7141 cd          enddo
7142 cd        enddo
7143 cd        endif
7144         call transpose2(EUgder(1,1,k),auxmat(1,1))
7145         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7146         call transpose2(EUg(1,1,k),auxmat(1,1))
7147         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7148         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7149         do iii=1,2
7150           do kkk=1,5
7151             do lll=1,3
7152               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7153      &          EAEAderx(1,1,lll,kkk,iii,1))
7154             enddo
7155           enddo
7156         enddo
7157 C A1T kernel(i+1) A2
7158         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7159      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7160      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7161 C Following matrices are needed only for 6-th order cumulants
7162         IF (wcorr6.gt.0.0d0) THEN
7163         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7164      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7165      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7166         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7167      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7168      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7169      &   ADtEAderx(1,1,1,1,1,2))
7170         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7171      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7172      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7173      &   ADtEA1derx(1,1,1,1,1,2))
7174         ENDIF
7175 C End 6-th order cumulants
7176         call transpose2(EUgder(1,1,l),auxmat(1,1))
7177         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7178         call transpose2(EUg(1,1,l),auxmat(1,1))
7179         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7180         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7181         do iii=1,2
7182           do kkk=1,5
7183             do lll=1,3
7184               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7185      &          EAEAderx(1,1,lll,kkk,iii,2))
7186             enddo
7187           enddo
7188         enddo
7189 C AEAb1 and AEAb2
7190 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7191 C They are needed only when the fifth- or the sixth-order cumulants are
7192 C indluded.
7193         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7194         call transpose2(AEA(1,1,1),auxmat(1,1))
7195         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7196         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7197         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7198         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7199         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7200         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7201         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7202         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7203         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7204         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7205         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7206         call transpose2(AEA(1,1,2),auxmat(1,1))
7207         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7208         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7209         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7210         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7211         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7212         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7213         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7214         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7215         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7216         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7217         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7218 C Calculate the Cartesian derivatives of the vectors.
7219         do iii=1,2
7220           do kkk=1,5
7221             do lll=1,3
7222               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7223               call matvec2(auxmat(1,1),b1(1,iti),
7224      &          AEAb1derx(1,lll,kkk,iii,1,1))
7225               call matvec2(auxmat(1,1),Ub2(1,i),
7226      &          AEAb2derx(1,lll,kkk,iii,1,1))
7227               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7228      &          AEAb1derx(1,lll,kkk,iii,2,1))
7229               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7230      &          AEAb2derx(1,lll,kkk,iii,2,1))
7231               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7232               call matvec2(auxmat(1,1),b1(1,itj),
7233      &          AEAb1derx(1,lll,kkk,iii,1,2))
7234               call matvec2(auxmat(1,1),Ub2(1,j),
7235      &          AEAb2derx(1,lll,kkk,iii,1,2))
7236               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7237      &          AEAb1derx(1,lll,kkk,iii,2,2))
7238               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7239      &          AEAb2derx(1,lll,kkk,iii,2,2))
7240             enddo
7241           enddo
7242         enddo
7243         ENDIF
7244 C End vectors
7245       else
7246 C Antiparallel orientation of the two CA-CA-CA frames.
7247         if (i.gt.1) then
7248           iti=itortyp(itype(i))
7249         else
7250           iti=ntortyp+1
7251         endif
7252         itk1=itortyp(itype(k+1))
7253         itl=itortyp(itype(l))
7254         itj=itortyp(itype(j))
7255         if (j.lt.nres-1) then
7256           itj1=itortyp(itype(j+1))
7257         else
7258           itj1=ntortyp+1
7259         endif
7260 C A2 kernel(j-1)T A1T
7261         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7262      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7263      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7264 C Following matrices are needed only for 6-th order cumulants
7265         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7266      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7267         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7268      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7269      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7270         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7271      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7272      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7273      &   ADtEAderx(1,1,1,1,1,1))
7274         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7275      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7276      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7277      &   ADtEA1derx(1,1,1,1,1,1))
7278         ENDIF
7279 C End 6-th order cumulants
7280         call transpose2(EUgder(1,1,k),auxmat(1,1))
7281         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7282         call transpose2(EUg(1,1,k),auxmat(1,1))
7283         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7284         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7285         do iii=1,2
7286           do kkk=1,5
7287             do lll=1,3
7288               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7289      &          EAEAderx(1,1,lll,kkk,iii,1))
7290             enddo
7291           enddo
7292         enddo
7293 C A2T kernel(i+1)T A1
7294         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7295      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7296      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7297 C Following matrices are needed only for 6-th order cumulants
7298         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7299      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7300         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7301      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7302      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7303         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7304      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7305      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7306      &   ADtEAderx(1,1,1,1,1,2))
7307         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7308      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7309      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7310      &   ADtEA1derx(1,1,1,1,1,2))
7311         ENDIF
7312 C End 6-th order cumulants
7313         call transpose2(EUgder(1,1,j),auxmat(1,1))
7314         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7315         call transpose2(EUg(1,1,j),auxmat(1,1))
7316         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7317         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7318         do iii=1,2
7319           do kkk=1,5
7320             do lll=1,3
7321               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7322      &          EAEAderx(1,1,lll,kkk,iii,2))
7323             enddo
7324           enddo
7325         enddo
7326 C AEAb1 and AEAb2
7327 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7328 C They are needed only when the fifth- or the sixth-order cumulants are
7329 C indluded.
7330         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7331      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7332         call transpose2(AEA(1,1,1),auxmat(1,1))
7333         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7334         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7335         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7336         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7337         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7338         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7339         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7340         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7341         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7342         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7343         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7344         call transpose2(AEA(1,1,2),auxmat(1,1))
7345         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7346         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7347         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7348         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7349         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7350         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7351         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7352         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7353         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7354         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7355         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7356 C Calculate the Cartesian derivatives of the vectors.
7357         do iii=1,2
7358           do kkk=1,5
7359             do lll=1,3
7360               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7361               call matvec2(auxmat(1,1),b1(1,iti),
7362      &          AEAb1derx(1,lll,kkk,iii,1,1))
7363               call matvec2(auxmat(1,1),Ub2(1,i),
7364      &          AEAb2derx(1,lll,kkk,iii,1,1))
7365               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7366      &          AEAb1derx(1,lll,kkk,iii,2,1))
7367               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7368      &          AEAb2derx(1,lll,kkk,iii,2,1))
7369               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7370               call matvec2(auxmat(1,1),b1(1,itl),
7371      &          AEAb1derx(1,lll,kkk,iii,1,2))
7372               call matvec2(auxmat(1,1),Ub2(1,l),
7373      &          AEAb2derx(1,lll,kkk,iii,1,2))
7374               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7375      &          AEAb1derx(1,lll,kkk,iii,2,2))
7376               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7377      &          AEAb2derx(1,lll,kkk,iii,2,2))
7378             enddo
7379           enddo
7380         enddo
7381         ENDIF
7382 C End vectors
7383       endif
7384       return
7385       end
7386 C---------------------------------------------------------------------------
7387       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7388      &  KK,KKderg,AKA,AKAderg,AKAderx)
7389       implicit none
7390       integer nderg
7391       logical transp
7392       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7393      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7394      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7395       integer iii,kkk,lll
7396       integer jjj,mmm
7397       logical lprn
7398       common /kutas/ lprn
7399       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7400       do iii=1,nderg
7401         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7402      &    AKAderg(1,1,iii))
7403       enddo
7404 cd      if (lprn) write (2,*) 'In kernel'
7405       do kkk=1,5
7406 cd        if (lprn) write (2,*) 'kkk=',kkk
7407         do lll=1,3
7408           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7409      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7410 cd          if (lprn) then
7411 cd            write (2,*) 'lll=',lll
7412 cd            write (2,*) 'iii=1'
7413 cd            do jjj=1,2
7414 cd              write (2,'(3(2f10.5),5x)')
7415 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7416 cd            enddo
7417 cd          endif
7418           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7419      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7420 cd          if (lprn) then
7421 cd            write (2,*) 'lll=',lll
7422 cd            write (2,*) 'iii=2'
7423 cd            do jjj=1,2
7424 cd              write (2,'(3(2f10.5),5x)')
7425 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7426 cd            enddo
7427 cd          endif
7428         enddo
7429       enddo
7430       return
7431       end
7432 C---------------------------------------------------------------------------
7433       double precision function eello4(i,j,k,l,jj,kk)
7434       implicit real*8 (a-h,o-z)
7435       include 'DIMENSIONS'
7436       include 'COMMON.IOUNITS'
7437       include 'COMMON.CHAIN'
7438       include 'COMMON.DERIV'
7439       include 'COMMON.INTERACT'
7440       include 'COMMON.CONTACTS'
7441       include 'COMMON.TORSION'
7442       include 'COMMON.VAR'
7443       include 'COMMON.GEO'
7444       double precision pizda(2,2),ggg1(3),ggg2(3)
7445 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7446 cd        eello4=0.0d0
7447 cd        return
7448 cd      endif
7449 cd      print *,'eello4:',i,j,k,l,jj,kk
7450 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7451 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7452 cold      eij=facont_hb(jj,i)
7453 cold      ekl=facont_hb(kk,k)
7454 cold      ekont=eij*ekl
7455       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7456 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7457       gcorr_loc(k-1)=gcorr_loc(k-1)
7458      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7459       if (l.eq.j+1) then
7460         gcorr_loc(l-1)=gcorr_loc(l-1)
7461      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7462       else
7463         gcorr_loc(j-1)=gcorr_loc(j-1)
7464      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7465       endif
7466       do iii=1,2
7467         do kkk=1,5
7468           do lll=1,3
7469             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7470      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7471 cd            derx(lll,kkk,iii)=0.0d0
7472           enddo
7473         enddo
7474       enddo
7475 cd      gcorr_loc(l-1)=0.0d0
7476 cd      gcorr_loc(j-1)=0.0d0
7477 cd      gcorr_loc(k-1)=0.0d0
7478 cd      eel4=1.0d0
7479 cd      write (iout,*)'Contacts have occurred for peptide groups',
7480 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7481 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7482       if (j.lt.nres-1) then
7483         j1=j+1
7484         j2=j-1
7485       else
7486         j1=j-1
7487         j2=j-2
7488       endif
7489       if (l.lt.nres-1) then
7490         l1=l+1
7491         l2=l-1
7492       else
7493         l1=l-1
7494         l2=l-2
7495       endif
7496       do ll=1,3
7497 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7498 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7499         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7500         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7501 cgrad        ghalf=0.5d0*ggg1(ll)
7502         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7503         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7504         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7505         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7506         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7507         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7508 cgrad        ghalf=0.5d0*ggg2(ll)
7509         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7510         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7511         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7512         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7513         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7514         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7515       enddo
7516 cgrad      do m=i+1,j-1
7517 cgrad        do ll=1,3
7518 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7519 cgrad        enddo
7520 cgrad      enddo
7521 cgrad      do m=k+1,l-1
7522 cgrad        do ll=1,3
7523 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7524 cgrad        enddo
7525 cgrad      enddo
7526 cgrad      do m=i+2,j2
7527 cgrad        do ll=1,3
7528 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7529 cgrad        enddo
7530 cgrad      enddo
7531 cgrad      do m=k+2,l2
7532 cgrad        do ll=1,3
7533 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7534 cgrad        enddo
7535 cgrad      enddo
7536 cd      do iii=1,nres-3
7537 cd        write (2,*) iii,gcorr_loc(iii)
7538 cd      enddo
7539       eello4=ekont*eel4
7540 cd      write (2,*) 'ekont',ekont
7541 cd      write (iout,*) 'eello4',ekont*eel4
7542       return
7543       end
7544 C---------------------------------------------------------------------------
7545       double precision function eello5(i,j,k,l,jj,kk)
7546       implicit real*8 (a-h,o-z)
7547       include 'DIMENSIONS'
7548       include 'COMMON.IOUNITS'
7549       include 'COMMON.CHAIN'
7550       include 'COMMON.DERIV'
7551       include 'COMMON.INTERACT'
7552       include 'COMMON.CONTACTS'
7553       include 'COMMON.TORSION'
7554       include 'COMMON.VAR'
7555       include 'COMMON.GEO'
7556       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7557       double precision ggg1(3),ggg2(3)
7558 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7559 C                                                                              C
7560 C                            Parallel chains                                   C
7561 C                                                                              C
7562 C          o             o                   o             o                   C
7563 C         /l\           / \             \   / \           / \   /              C
7564 C        /   \         /   \             \ /   \         /   \ /               C
7565 C       j| o |l1       | o |              o| o |         | o |o                C
7566 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7567 C      \i/   \         /   \ /             /   \         /   \                 C
7568 C       o    k1             o                                                  C
7569 C         (I)          (II)                (III)          (IV)                 C
7570 C                                                                              C
7571 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7572 C                                                                              C
7573 C                            Antiparallel chains                               C
7574 C                                                                              C
7575 C          o             o                   o             o                   C
7576 C         /j\           / \             \   / \           / \   /              C
7577 C        /   \         /   \             \ /   \         /   \ /               C
7578 C      j1| o |l        | o |              o| o |         | o |o                C
7579 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7580 C      \i/   \         /   \ /             /   \         /   \                 C
7581 C       o     k1            o                                                  C
7582 C         (I)          (II)                (III)          (IV)                 C
7583 C                                                                              C
7584 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7585 C                                                                              C
7586 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7587 C                                                                              C
7588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7589 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7590 cd        eello5=0.0d0
7591 cd        return
7592 cd      endif
7593 cd      write (iout,*)
7594 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7595 cd     &   ' and',k,l
7596       itk=itortyp(itype(k))
7597       itl=itortyp(itype(l))
7598       itj=itortyp(itype(j))
7599       eello5_1=0.0d0
7600       eello5_2=0.0d0
7601       eello5_3=0.0d0
7602       eello5_4=0.0d0
7603 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7604 cd     &   eel5_3_num,eel5_4_num)
7605       do iii=1,2
7606         do kkk=1,5
7607           do lll=1,3
7608             derx(lll,kkk,iii)=0.0d0
7609           enddo
7610         enddo
7611       enddo
7612 cd      eij=facont_hb(jj,i)
7613 cd      ekl=facont_hb(kk,k)
7614 cd      ekont=eij*ekl
7615 cd      write (iout,*)'Contacts have occurred for peptide groups',
7616 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7617 cd      goto 1111
7618 C Contribution from the graph I.
7619 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7620 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7621       call transpose2(EUg(1,1,k),auxmat(1,1))
7622       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7623       vv(1)=pizda(1,1)-pizda(2,2)
7624       vv(2)=pizda(1,2)+pizda(2,1)
7625       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7626      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7627 C Explicit gradient in virtual-dihedral angles.
7628       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7629      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7630      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7631       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7632       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7633       vv(1)=pizda(1,1)-pizda(2,2)
7634       vv(2)=pizda(1,2)+pizda(2,1)
7635       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7636      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7637      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7638       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7639       vv(1)=pizda(1,1)-pizda(2,2)
7640       vv(2)=pizda(1,2)+pizda(2,1)
7641       if (l.eq.j+1) then
7642         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7643      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7644      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7645       else
7646         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7647      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7648      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7649       endif
7650 C Cartesian gradient
7651       do iii=1,2
7652         do kkk=1,5
7653           do lll=1,3
7654             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7655      &        pizda(1,1))
7656             vv(1)=pizda(1,1)-pizda(2,2)
7657             vv(2)=pizda(1,2)+pizda(2,1)
7658             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7659      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7660      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7661           enddo
7662         enddo
7663       enddo
7664 c      goto 1112
7665 c1111  continue
7666 C Contribution from graph II
7667       call transpose2(EE(1,1,itk),auxmat(1,1))
7668       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7669       vv(1)=pizda(1,1)+pizda(2,2)
7670       vv(2)=pizda(2,1)-pizda(1,2)
7671       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7672      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7673 C Explicit gradient in virtual-dihedral angles.
7674       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7675      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7676       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7677       vv(1)=pizda(1,1)+pizda(2,2)
7678       vv(2)=pizda(2,1)-pizda(1,2)
7679       if (l.eq.j+1) then
7680         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7681      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7682      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7683       else
7684         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7685      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7686      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7687       endif
7688 C Cartesian gradient
7689       do iii=1,2
7690         do kkk=1,5
7691           do lll=1,3
7692             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7693      &        pizda(1,1))
7694             vv(1)=pizda(1,1)+pizda(2,2)
7695             vv(2)=pizda(2,1)-pizda(1,2)
7696             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7697      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7698      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7699           enddo
7700         enddo
7701       enddo
7702 cd      goto 1112
7703 cd1111  continue
7704       if (l.eq.j+1) then
7705 cd        goto 1110
7706 C Parallel orientation
7707 C Contribution from graph III
7708         call transpose2(EUg(1,1,l),auxmat(1,1))
7709         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7710         vv(1)=pizda(1,1)-pizda(2,2)
7711         vv(2)=pizda(1,2)+pizda(2,1)
7712         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7713      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7714 C Explicit gradient in virtual-dihedral angles.
7715         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7716      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7717      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7718         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7719         vv(1)=pizda(1,1)-pizda(2,2)
7720         vv(2)=pizda(1,2)+pizda(2,1)
7721         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7722      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7723      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7724         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7725         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7726         vv(1)=pizda(1,1)-pizda(2,2)
7727         vv(2)=pizda(1,2)+pizda(2,1)
7728         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7729      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7730      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7731 C Cartesian gradient
7732         do iii=1,2
7733           do kkk=1,5
7734             do lll=1,3
7735               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7736      &          pizda(1,1))
7737               vv(1)=pizda(1,1)-pizda(2,2)
7738               vv(2)=pizda(1,2)+pizda(2,1)
7739               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7740      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7741      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7742             enddo
7743           enddo
7744         enddo
7745 cd        goto 1112
7746 C Contribution from graph IV
7747 cd1110    continue
7748         call transpose2(EE(1,1,itl),auxmat(1,1))
7749         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7750         vv(1)=pizda(1,1)+pizda(2,2)
7751         vv(2)=pizda(2,1)-pizda(1,2)
7752         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7753      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7754 C Explicit gradient in virtual-dihedral angles.
7755         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7756      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7757         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7758         vv(1)=pizda(1,1)+pizda(2,2)
7759         vv(2)=pizda(2,1)-pizda(1,2)
7760         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7761      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7762      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7763 C Cartesian gradient
7764         do iii=1,2
7765           do kkk=1,5
7766             do lll=1,3
7767               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7768      &          pizda(1,1))
7769               vv(1)=pizda(1,1)+pizda(2,2)
7770               vv(2)=pizda(2,1)-pizda(1,2)
7771               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7772      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7773      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7774             enddo
7775           enddo
7776         enddo
7777       else
7778 C Antiparallel orientation
7779 C Contribution from graph III
7780 c        goto 1110
7781         call transpose2(EUg(1,1,j),auxmat(1,1))
7782         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7783         vv(1)=pizda(1,1)-pizda(2,2)
7784         vv(2)=pizda(1,2)+pizda(2,1)
7785         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7786      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7787 C Explicit gradient in virtual-dihedral angles.
7788         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7789      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7790      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7791         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7792         vv(1)=pizda(1,1)-pizda(2,2)
7793         vv(2)=pizda(1,2)+pizda(2,1)
7794         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7795      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7796      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7797         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7798         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7799         vv(1)=pizda(1,1)-pizda(2,2)
7800         vv(2)=pizda(1,2)+pizda(2,1)
7801         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7802      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7803      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7804 C Cartesian gradient
7805         do iii=1,2
7806           do kkk=1,5
7807             do lll=1,3
7808               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7809      &          pizda(1,1))
7810               vv(1)=pizda(1,1)-pizda(2,2)
7811               vv(2)=pizda(1,2)+pizda(2,1)
7812               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7813      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7814      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7815             enddo
7816           enddo
7817         enddo
7818 cd        goto 1112
7819 C Contribution from graph IV
7820 1110    continue
7821         call transpose2(EE(1,1,itj),auxmat(1,1))
7822         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7823         vv(1)=pizda(1,1)+pizda(2,2)
7824         vv(2)=pizda(2,1)-pizda(1,2)
7825         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7826      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7827 C Explicit gradient in virtual-dihedral angles.
7828         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7829      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7830         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7831         vv(1)=pizda(1,1)+pizda(2,2)
7832         vv(2)=pizda(2,1)-pizda(1,2)
7833         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7834      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7835      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7836 C Cartesian gradient
7837         do iii=1,2
7838           do kkk=1,5
7839             do lll=1,3
7840               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7841      &          pizda(1,1))
7842               vv(1)=pizda(1,1)+pizda(2,2)
7843               vv(2)=pizda(2,1)-pizda(1,2)
7844               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7845      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7846      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7847             enddo
7848           enddo
7849         enddo
7850       endif
7851 1112  continue
7852       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7853 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7854 cd        write (2,*) 'ijkl',i,j,k,l
7855 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7856 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7857 cd      endif
7858 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7859 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7860 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7861 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7862       if (j.lt.nres-1) then
7863         j1=j+1
7864         j2=j-1
7865       else
7866         j1=j-1
7867         j2=j-2
7868       endif
7869       if (l.lt.nres-1) then
7870         l1=l+1
7871         l2=l-1
7872       else
7873         l1=l-1
7874         l2=l-2
7875       endif
7876 cd      eij=1.0d0
7877 cd      ekl=1.0d0
7878 cd      ekont=1.0d0
7879 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7880 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7881 C        summed up outside the subrouine as for the other subroutines
7882 C        handling long-range interactions. The old code is commented out
7883 C        with "cgrad" to keep track of changes.
7884       do ll=1,3
7885 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7886 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7887         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7888         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7889 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7890 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7891 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7892 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7893 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7894 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7895 c     &   gradcorr5ij,
7896 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7897 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7898 cgrad        ghalf=0.5d0*ggg1(ll)
7899 cd        ghalf=0.0d0
7900         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7901         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7902         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7903         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7904         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7905         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7906 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7907 cgrad        ghalf=0.5d0*ggg2(ll)
7908 cd        ghalf=0.0d0
7909         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7910         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7911         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7912         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7913         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7914         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7915       enddo
7916 cd      goto 1112
7917 cgrad      do m=i+1,j-1
7918 cgrad        do ll=1,3
7919 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7920 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7921 cgrad        enddo
7922 cgrad      enddo
7923 cgrad      do m=k+1,l-1
7924 cgrad        do ll=1,3
7925 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7926 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7927 cgrad        enddo
7928 cgrad      enddo
7929 c1112  continue
7930 cgrad      do m=i+2,j2
7931 cgrad        do ll=1,3
7932 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7933 cgrad        enddo
7934 cgrad      enddo
7935 cgrad      do m=k+2,l2
7936 cgrad        do ll=1,3
7937 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7938 cgrad        enddo
7939 cgrad      enddo
7940 cd      do iii=1,nres-3
7941 cd        write (2,*) iii,g_corr5_loc(iii)
7942 cd      enddo
7943       eello5=ekont*eel5
7944 cd      write (2,*) 'ekont',ekont
7945 cd      write (iout,*) 'eello5',ekont*eel5
7946       return
7947       end
7948 c--------------------------------------------------------------------------
7949       double precision function eello6(i,j,k,l,jj,kk)
7950       implicit real*8 (a-h,o-z)
7951       include 'DIMENSIONS'
7952       include 'COMMON.IOUNITS'
7953       include 'COMMON.CHAIN'
7954       include 'COMMON.DERIV'
7955       include 'COMMON.INTERACT'
7956       include 'COMMON.CONTACTS'
7957       include 'COMMON.TORSION'
7958       include 'COMMON.VAR'
7959       include 'COMMON.GEO'
7960       include 'COMMON.FFIELD'
7961       double precision ggg1(3),ggg2(3)
7962 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7963 cd        eello6=0.0d0
7964 cd        return
7965 cd      endif
7966 cd      write (iout,*)
7967 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7968 cd     &   ' and',k,l
7969       eello6_1=0.0d0
7970       eello6_2=0.0d0
7971       eello6_3=0.0d0
7972       eello6_4=0.0d0
7973       eello6_5=0.0d0
7974       eello6_6=0.0d0
7975 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7976 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7977       do iii=1,2
7978         do kkk=1,5
7979           do lll=1,3
7980             derx(lll,kkk,iii)=0.0d0
7981           enddo
7982         enddo
7983       enddo
7984 cd      eij=facont_hb(jj,i)
7985 cd      ekl=facont_hb(kk,k)
7986 cd      ekont=eij*ekl
7987 cd      eij=1.0d0
7988 cd      ekl=1.0d0
7989 cd      ekont=1.0d0
7990       if (l.eq.j+1) then
7991         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7992         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7993         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7994         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7995         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7996         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7997       else
7998         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7999         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8000         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8001         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8002         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8003           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8004         else
8005           eello6_5=0.0d0
8006         endif
8007         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8008       endif
8009 C If turn contributions are considered, they will be handled separately.
8010       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8011 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8012 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8013 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8014 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8015 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8016 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8017 cd      goto 1112
8018       if (j.lt.nres-1) then
8019         j1=j+1
8020         j2=j-1
8021       else
8022         j1=j-1
8023         j2=j-2
8024       endif
8025       if (l.lt.nres-1) then
8026         l1=l+1
8027         l2=l-1
8028       else
8029         l1=l-1
8030         l2=l-2
8031       endif
8032       do ll=1,3
8033 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8034 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8035 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8036 cgrad        ghalf=0.5d0*ggg1(ll)
8037 cd        ghalf=0.0d0
8038         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8039         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8040         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8041         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8042         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8043         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8044         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8045         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8046 cgrad        ghalf=0.5d0*ggg2(ll)
8047 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8048 cd        ghalf=0.0d0
8049         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8050         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8051         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8052         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8053         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8054         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8055       enddo
8056 cd      goto 1112
8057 cgrad      do m=i+1,j-1
8058 cgrad        do ll=1,3
8059 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8060 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8061 cgrad        enddo
8062 cgrad      enddo
8063 cgrad      do m=k+1,l-1
8064 cgrad        do ll=1,3
8065 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8066 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8067 cgrad        enddo
8068 cgrad      enddo
8069 cgrad1112  continue
8070 cgrad      do m=i+2,j2
8071 cgrad        do ll=1,3
8072 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8073 cgrad        enddo
8074 cgrad      enddo
8075 cgrad      do m=k+2,l2
8076 cgrad        do ll=1,3
8077 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8078 cgrad        enddo
8079 cgrad      enddo
8080 cd      do iii=1,nres-3
8081 cd        write (2,*) iii,g_corr6_loc(iii)
8082 cd      enddo
8083       eello6=ekont*eel6
8084 cd      write (2,*) 'ekont',ekont
8085 cd      write (iout,*) 'eello6',ekont*eel6
8086       return
8087       end
8088 c--------------------------------------------------------------------------
8089       double precision function eello6_graph1(i,j,k,l,imat,swap)
8090       implicit real*8 (a-h,o-z)
8091       include 'DIMENSIONS'
8092       include 'COMMON.IOUNITS'
8093       include 'COMMON.CHAIN'
8094       include 'COMMON.DERIV'
8095       include 'COMMON.INTERACT'
8096       include 'COMMON.CONTACTS'
8097       include 'COMMON.TORSION'
8098       include 'COMMON.VAR'
8099       include 'COMMON.GEO'
8100       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8101       logical swap
8102       logical lprn
8103       common /kutas/ lprn
8104 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8105 C
8106 C      Parallel       Antiparallel
8107 C
8108 C          o             o
8109 C         /l\           /j\
8110 C        /   \         /   \
8111 C       /| o |         | o |\
8112 C     \ j|/k\|  /   \  |/k\|l /
8113 C      \ /   \ /     \ /   \ /
8114 C       o     o       o     o
8115 C       i             i
8116 C
8117 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8118       itk=itortyp(itype(k))
8119       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8120       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8121       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8122       call transpose2(EUgC(1,1,k),auxmat(1,1))
8123       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8124       vv1(1)=pizda1(1,1)-pizda1(2,2)
8125       vv1(2)=pizda1(1,2)+pizda1(2,1)
8126       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8127       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8128       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8129       s5=scalar2(vv(1),Dtobr2(1,i))
8130 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8131       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8132       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8133      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8134      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8135      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8136      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8137      & +scalar2(vv(1),Dtobr2der(1,i)))
8138       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8139       vv1(1)=pizda1(1,1)-pizda1(2,2)
8140       vv1(2)=pizda1(1,2)+pizda1(2,1)
8141       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8142       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8143       if (l.eq.j+1) then
8144         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8145      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8146      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8147      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8148      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8149       else
8150         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8151      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8152      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8153      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8154      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8155       endif
8156       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8157       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8158       vv1(1)=pizda1(1,1)-pizda1(2,2)
8159       vv1(2)=pizda1(1,2)+pizda1(2,1)
8160       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8161      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8162      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8163      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8164       do iii=1,2
8165         if (swap) then
8166           ind=3-iii
8167         else
8168           ind=iii
8169         endif
8170         do kkk=1,5
8171           do lll=1,3
8172             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8173             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8174             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8175             call transpose2(EUgC(1,1,k),auxmat(1,1))
8176             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8177      &        pizda1(1,1))
8178             vv1(1)=pizda1(1,1)-pizda1(2,2)
8179             vv1(2)=pizda1(1,2)+pizda1(2,1)
8180             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8181             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8182      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8183             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8184      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8185             s5=scalar2(vv(1),Dtobr2(1,i))
8186             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8187           enddo
8188         enddo
8189       enddo
8190       return
8191       end
8192 c----------------------------------------------------------------------------
8193       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8194       implicit real*8 (a-h,o-z)
8195       include 'DIMENSIONS'
8196       include 'COMMON.IOUNITS'
8197       include 'COMMON.CHAIN'
8198       include 'COMMON.DERIV'
8199       include 'COMMON.INTERACT'
8200       include 'COMMON.CONTACTS'
8201       include 'COMMON.TORSION'
8202       include 'COMMON.VAR'
8203       include 'COMMON.GEO'
8204       logical swap
8205       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8206      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8207       logical lprn
8208       common /kutas/ lprn
8209 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8210 C                                                                              C
8211 C      Parallel       Antiparallel                                             C
8212 C                                                                              C
8213 C          o             o                                                     C
8214 C     \   /l\           /j\   /                                                C
8215 C      \ /   \         /   \ /                                                 C
8216 C       o| o |         | o |o                                                  C
8217 C     \ j|/k\|      \  |/k\|l                                                  C
8218 C      \ /   \       \ /   \                                                   C
8219 C       o             o                                                        C
8220 C       i             i                                                        C
8221 C                                                                              C
8222 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8223 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8224 C AL 7/4/01 s1 would occur in the sixth-order moment,
8225 C           but not in a cluster cumulant
8226 #ifdef MOMENT
8227       s1=dip(1,jj,i)*dip(1,kk,k)
8228 #endif
8229       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8230       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8231       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8232       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8233       call transpose2(EUg(1,1,k),auxmat(1,1))
8234       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8235       vv(1)=pizda(1,1)-pizda(2,2)
8236       vv(2)=pizda(1,2)+pizda(2,1)
8237       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8238 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8239 #ifdef MOMENT
8240       eello6_graph2=-(s1+s2+s3+s4)
8241 #else
8242       eello6_graph2=-(s2+s3+s4)
8243 #endif
8244 c      eello6_graph2=-s3
8245 C Derivatives in gamma(i-1)
8246       if (i.gt.1) then
8247 #ifdef MOMENT
8248         s1=dipderg(1,jj,i)*dip(1,kk,k)
8249 #endif
8250         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8251         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8252         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8253         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8254 #ifdef MOMENT
8255         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8256 #else
8257         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8258 #endif
8259 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8260       endif
8261 C Derivatives in gamma(k-1)
8262 #ifdef MOMENT
8263       s1=dip(1,jj,i)*dipderg(1,kk,k)
8264 #endif
8265       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8266       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8267       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8268       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8269       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8270       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8271       vv(1)=pizda(1,1)-pizda(2,2)
8272       vv(2)=pizda(1,2)+pizda(2,1)
8273       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8274 #ifdef MOMENT
8275       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8276 #else
8277       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8278 #endif
8279 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8280 C Derivatives in gamma(j-1) or gamma(l-1)
8281       if (j.gt.1) then
8282 #ifdef MOMENT
8283         s1=dipderg(3,jj,i)*dip(1,kk,k)
8284 #endif
8285         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8286         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8287         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8288         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8289         vv(1)=pizda(1,1)-pizda(2,2)
8290         vv(2)=pizda(1,2)+pizda(2,1)
8291         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8292 #ifdef MOMENT
8293         if (swap) then
8294           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8295         else
8296           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8297         endif
8298 #endif
8299         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8300 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8301       endif
8302 C Derivatives in gamma(l-1) or gamma(j-1)
8303       if (l.gt.1) then
8304 #ifdef MOMENT
8305         s1=dip(1,jj,i)*dipderg(3,kk,k)
8306 #endif
8307         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8308         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8309         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8310         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8311         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8312         vv(1)=pizda(1,1)-pizda(2,2)
8313         vv(2)=pizda(1,2)+pizda(2,1)
8314         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8315 #ifdef MOMENT
8316         if (swap) then
8317           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8318         else
8319           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8320         endif
8321 #endif
8322         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8323 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8324       endif
8325 C Cartesian derivatives.
8326       if (lprn) then
8327         write (2,*) 'In eello6_graph2'
8328         do iii=1,2
8329           write (2,*) 'iii=',iii
8330           do kkk=1,5
8331             write (2,*) 'kkk=',kkk
8332             do jjj=1,2
8333               write (2,'(3(2f10.5),5x)')
8334      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8335             enddo
8336           enddo
8337         enddo
8338       endif
8339       do iii=1,2
8340         do kkk=1,5
8341           do lll=1,3
8342 #ifdef MOMENT
8343             if (iii.eq.1) then
8344               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8345             else
8346               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8347             endif
8348 #endif
8349             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8350      &        auxvec(1))
8351             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8352             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8353      &        auxvec(1))
8354             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8355             call transpose2(EUg(1,1,k),auxmat(1,1))
8356             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8357      &        pizda(1,1))
8358             vv(1)=pizda(1,1)-pizda(2,2)
8359             vv(2)=pizda(1,2)+pizda(2,1)
8360             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8361 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8362 #ifdef MOMENT
8363             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8364 #else
8365             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8366 #endif
8367             if (swap) then
8368               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8369             else
8370               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8371             endif
8372           enddo
8373         enddo
8374       enddo
8375       return
8376       end
8377 c----------------------------------------------------------------------------
8378       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8379       implicit real*8 (a-h,o-z)
8380       include 'DIMENSIONS'
8381       include 'COMMON.IOUNITS'
8382       include 'COMMON.CHAIN'
8383       include 'COMMON.DERIV'
8384       include 'COMMON.INTERACT'
8385       include 'COMMON.CONTACTS'
8386       include 'COMMON.TORSION'
8387       include 'COMMON.VAR'
8388       include 'COMMON.GEO'
8389       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8390       logical swap
8391 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8392 C                                                                              C
8393 C      Parallel       Antiparallel                                             C
8394 C                                                                              C
8395 C          o             o                                                     C
8396 C         /l\   /   \   /j\                                                    C
8397 C        /   \ /     \ /   \                                                   C
8398 C       /| o |o       o| o |\                                                  C
8399 C       j|/k\|  /      |/k\|l /                                                C
8400 C        /   \ /       /   \ /                                                 C
8401 C       /     o       /     o                                                  C
8402 C       i             i                                                        C
8403 C                                                                              C
8404 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8405 C
8406 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8407 C           energy moment and not to the cluster cumulant.
8408       iti=itortyp(itype(i))
8409       if (j.lt.nres-1) then
8410         itj1=itortyp(itype(j+1))
8411       else
8412         itj1=ntortyp+1
8413       endif
8414       itk=itortyp(itype(k))
8415       itk1=itortyp(itype(k+1))
8416       if (l.lt.nres-1) then
8417         itl1=itortyp(itype(l+1))
8418       else
8419         itl1=ntortyp+1
8420       endif
8421 #ifdef MOMENT
8422       s1=dip(4,jj,i)*dip(4,kk,k)
8423 #endif
8424       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8425       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8426       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8427       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8428       call transpose2(EE(1,1,itk),auxmat(1,1))
8429       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8430       vv(1)=pizda(1,1)+pizda(2,2)
8431       vv(2)=pizda(2,1)-pizda(1,2)
8432       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8433 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8434 cd     & "sum",-(s2+s3+s4)
8435 #ifdef MOMENT
8436       eello6_graph3=-(s1+s2+s3+s4)
8437 #else
8438       eello6_graph3=-(s2+s3+s4)
8439 #endif
8440 c      eello6_graph3=-s4
8441 C Derivatives in gamma(k-1)
8442       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8443       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8444       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8445       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8446 C Derivatives in gamma(l-1)
8447       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8448       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8449       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8450       vv(1)=pizda(1,1)+pizda(2,2)
8451       vv(2)=pizda(2,1)-pizda(1,2)
8452       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8453       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8454 C Cartesian derivatives.
8455       do iii=1,2
8456         do kkk=1,5
8457           do lll=1,3
8458 #ifdef MOMENT
8459             if (iii.eq.1) then
8460               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8461             else
8462               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8463             endif
8464 #endif
8465             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8466      &        auxvec(1))
8467             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8468             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8469      &        auxvec(1))
8470             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8471             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8472      &        pizda(1,1))
8473             vv(1)=pizda(1,1)+pizda(2,2)
8474             vv(2)=pizda(2,1)-pizda(1,2)
8475             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8476 #ifdef MOMENT
8477             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8478 #else
8479             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8480 #endif
8481             if (swap) then
8482               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8483             else
8484               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8485             endif
8486 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8487           enddo
8488         enddo
8489       enddo
8490       return
8491       end
8492 c----------------------------------------------------------------------------
8493       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8494       implicit real*8 (a-h,o-z)
8495       include 'DIMENSIONS'
8496       include 'COMMON.IOUNITS'
8497       include 'COMMON.CHAIN'
8498       include 'COMMON.DERIV'
8499       include 'COMMON.INTERACT'
8500       include 'COMMON.CONTACTS'
8501       include 'COMMON.TORSION'
8502       include 'COMMON.VAR'
8503       include 'COMMON.GEO'
8504       include 'COMMON.FFIELD'
8505       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8506      & auxvec1(2),auxmat1(2,2)
8507       logical swap
8508 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8509 C                                                                              C
8510 C      Parallel       Antiparallel                                             C
8511 C                                                                              C
8512 C          o             o                                                     C
8513 C         /l\   /   \   /j\                                                    C
8514 C        /   \ /     \ /   \                                                   C
8515 C       /| o |o       o| o |\                                                  C
8516 C     \ j|/k\|      \  |/k\|l                                                  C
8517 C      \ /   \       \ /   \                                                   C
8518 C       o     \       o     \                                                  C
8519 C       i             i                                                        C
8520 C                                                                              C
8521 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8522 C
8523 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8524 C           energy moment and not to the cluster cumulant.
8525 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8526       iti=itortyp(itype(i))
8527       itj=itortyp(itype(j))
8528       if (j.lt.nres-1) then
8529         itj1=itortyp(itype(j+1))
8530       else
8531         itj1=ntortyp+1
8532       endif
8533       itk=itortyp(itype(k))
8534       if (k.lt.nres-1) then
8535         itk1=itortyp(itype(k+1))
8536       else
8537         itk1=ntortyp+1
8538       endif
8539       itl=itortyp(itype(l))
8540       if (l.lt.nres-1) then
8541         itl1=itortyp(itype(l+1))
8542       else
8543         itl1=ntortyp+1
8544       endif
8545 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8546 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8547 cd     & ' itl',itl,' itl1',itl1
8548 #ifdef MOMENT
8549       if (imat.eq.1) then
8550         s1=dip(3,jj,i)*dip(3,kk,k)
8551       else
8552         s1=dip(2,jj,j)*dip(2,kk,l)
8553       endif
8554 #endif
8555       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8556       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8557       if (j.eq.l+1) then
8558         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8559         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8560       else
8561         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8562         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8563       endif
8564       call transpose2(EUg(1,1,k),auxmat(1,1))
8565       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8566       vv(1)=pizda(1,1)-pizda(2,2)
8567       vv(2)=pizda(2,1)+pizda(1,2)
8568       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8569 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8570 #ifdef MOMENT
8571       eello6_graph4=-(s1+s2+s3+s4)
8572 #else
8573       eello6_graph4=-(s2+s3+s4)
8574 #endif
8575 C Derivatives in gamma(i-1)
8576       if (i.gt.1) then
8577 #ifdef MOMENT
8578         if (imat.eq.1) then
8579           s1=dipderg(2,jj,i)*dip(3,kk,k)
8580         else
8581           s1=dipderg(4,jj,j)*dip(2,kk,l)
8582         endif
8583 #endif
8584         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8585         if (j.eq.l+1) then
8586           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8587           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8588         else
8589           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8590           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8591         endif
8592         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8593         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8594 cd          write (2,*) 'turn6 derivatives'
8595 #ifdef MOMENT
8596           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8597 #else
8598           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8599 #endif
8600         else
8601 #ifdef MOMENT
8602           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8603 #else
8604           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8605 #endif
8606         endif
8607       endif
8608 C Derivatives in gamma(k-1)
8609 #ifdef MOMENT
8610       if (imat.eq.1) then
8611         s1=dip(3,jj,i)*dipderg(2,kk,k)
8612       else
8613         s1=dip(2,jj,j)*dipderg(4,kk,l)
8614       endif
8615 #endif
8616       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8617       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8618       if (j.eq.l+1) then
8619         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8620         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8621       else
8622         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8623         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8624       endif
8625       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8626       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8627       vv(1)=pizda(1,1)-pizda(2,2)
8628       vv(2)=pizda(2,1)+pizda(1,2)
8629       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8630       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8631 #ifdef MOMENT
8632         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8633 #else
8634         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8635 #endif
8636       else
8637 #ifdef MOMENT
8638         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8639 #else
8640         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8641 #endif
8642       endif
8643 C Derivatives in gamma(j-1) or gamma(l-1)
8644       if (l.eq.j+1 .and. l.gt.1) then
8645         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8646         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8647         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8648         vv(1)=pizda(1,1)-pizda(2,2)
8649         vv(2)=pizda(2,1)+pizda(1,2)
8650         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8651         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8652       else if (j.gt.1) then
8653         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8654         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8655         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8656         vv(1)=pizda(1,1)-pizda(2,2)
8657         vv(2)=pizda(2,1)+pizda(1,2)
8658         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8659         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8660           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8661         else
8662           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8663         endif
8664       endif
8665 C Cartesian derivatives.
8666       do iii=1,2
8667         do kkk=1,5
8668           do lll=1,3
8669 #ifdef MOMENT
8670             if (iii.eq.1) then
8671               if (imat.eq.1) then
8672                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8673               else
8674                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8675               endif
8676             else
8677               if (imat.eq.1) then
8678                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8679               else
8680                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8681               endif
8682             endif
8683 #endif
8684             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8685      &        auxvec(1))
8686             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8687             if (j.eq.l+1) then
8688               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8689      &          b1(1,itj1),auxvec(1))
8690               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8691             else
8692               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8693      &          b1(1,itl1),auxvec(1))
8694               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8695             endif
8696             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8697      &        pizda(1,1))
8698             vv(1)=pizda(1,1)-pizda(2,2)
8699             vv(2)=pizda(2,1)+pizda(1,2)
8700             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8701             if (swap) then
8702               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8703 #ifdef MOMENT
8704                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8705      &             -(s1+s2+s4)
8706 #else
8707                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8708      &             -(s2+s4)
8709 #endif
8710                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8711               else
8712 #ifdef MOMENT
8713                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8714 #else
8715                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8716 #endif
8717                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8718               endif
8719             else
8720 #ifdef MOMENT
8721               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8722 #else
8723               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8724 #endif
8725               if (l.eq.j+1) then
8726                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8727               else
8728                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8729               endif
8730             endif
8731           enddo
8732         enddo
8733       enddo
8734       return
8735       end
8736 c----------------------------------------------------------------------------
8737       double precision function eello_turn6(i,jj,kk)
8738       implicit real*8 (a-h,o-z)
8739       include 'DIMENSIONS'
8740       include 'COMMON.IOUNITS'
8741       include 'COMMON.CHAIN'
8742       include 'COMMON.DERIV'
8743       include 'COMMON.INTERACT'
8744       include 'COMMON.CONTACTS'
8745       include 'COMMON.TORSION'
8746       include 'COMMON.VAR'
8747       include 'COMMON.GEO'
8748       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8749      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8750      &  ggg1(3),ggg2(3)
8751       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8752      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8753 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8754 C           the respective energy moment and not to the cluster cumulant.
8755       s1=0.0d0
8756       s8=0.0d0
8757       s13=0.0d0
8758 c
8759       eello_turn6=0.0d0
8760       j=i+4
8761       k=i+1
8762       l=i+3
8763       iti=itortyp(itype(i))
8764       itk=itortyp(itype(k))
8765       itk1=itortyp(itype(k+1))
8766       itl=itortyp(itype(l))
8767       itj=itortyp(itype(j))
8768 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8769 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8770 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8771 cd        eello6=0.0d0
8772 cd        return
8773 cd      endif
8774 cd      write (iout,*)
8775 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8776 cd     &   ' and',k,l
8777 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8778       do iii=1,2
8779         do kkk=1,5
8780           do lll=1,3
8781             derx_turn(lll,kkk,iii)=0.0d0
8782           enddo
8783         enddo
8784       enddo
8785 cd      eij=1.0d0
8786 cd      ekl=1.0d0
8787 cd      ekont=1.0d0
8788       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8789 cd      eello6_5=0.0d0
8790 cd      write (2,*) 'eello6_5',eello6_5
8791 #ifdef MOMENT
8792       call transpose2(AEA(1,1,1),auxmat(1,1))
8793       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8794       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8795       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8796 #endif
8797       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8798       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8799       s2 = scalar2(b1(1,itk),vtemp1(1))
8800 #ifdef MOMENT
8801       call transpose2(AEA(1,1,2),atemp(1,1))
8802       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8803       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8804       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8805 #endif
8806       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8807       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8808       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8809 #ifdef MOMENT
8810       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8811       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8812       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8813       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8814       ss13 = scalar2(b1(1,itk),vtemp4(1))
8815       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8816 #endif
8817 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8818 c      s1=0.0d0
8819 c      s2=0.0d0
8820 c      s8=0.0d0
8821 c      s12=0.0d0
8822 c      s13=0.0d0
8823       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8824 C Derivatives in gamma(i+2)
8825       s1d =0.0d0
8826       s8d =0.0d0
8827 #ifdef MOMENT
8828       call transpose2(AEA(1,1,1),auxmatd(1,1))
8829       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8830       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8831       call transpose2(AEAderg(1,1,2),atempd(1,1))
8832       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8833       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8834 #endif
8835       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8836       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8837       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8838 c      s1d=0.0d0
8839 c      s2d=0.0d0
8840 c      s8d=0.0d0
8841 c      s12d=0.0d0
8842 c      s13d=0.0d0
8843       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8844 C Derivatives in gamma(i+3)
8845 #ifdef MOMENT
8846       call transpose2(AEA(1,1,1),auxmatd(1,1))
8847       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8848       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8849       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8850 #endif
8851       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8852       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8853       s2d = scalar2(b1(1,itk),vtemp1d(1))
8854 #ifdef MOMENT
8855       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8856       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8857 #endif
8858       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8859 #ifdef MOMENT
8860       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8861       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8862       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8863 #endif
8864 c      s1d=0.0d0
8865 c      s2d=0.0d0
8866 c      s8d=0.0d0
8867 c      s12d=0.0d0
8868 c      s13d=0.0d0
8869 #ifdef MOMENT
8870       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8871      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8872 #else
8873       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8874      &               -0.5d0*ekont*(s2d+s12d)
8875 #endif
8876 C Derivatives in gamma(i+4)
8877       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8878       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8879       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8880 #ifdef MOMENT
8881       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8882       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8883       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8884 #endif
8885 c      s1d=0.0d0
8886 c      s2d=0.0d0
8887 c      s8d=0.0d0
8888 C      s12d=0.0d0
8889 c      s13d=0.0d0
8890 #ifdef MOMENT
8891       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8892 #else
8893       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8894 #endif
8895 C Derivatives in gamma(i+5)
8896 #ifdef MOMENT
8897       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8898       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8899       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8900 #endif
8901       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8902       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8903       s2d = scalar2(b1(1,itk),vtemp1d(1))
8904 #ifdef MOMENT
8905       call transpose2(AEA(1,1,2),atempd(1,1))
8906       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8907       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8908 #endif
8909       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8910       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8911 #ifdef MOMENT
8912       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8913       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8914       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8915 #endif
8916 c      s1d=0.0d0
8917 c      s2d=0.0d0
8918 c      s8d=0.0d0
8919 c      s12d=0.0d0
8920 c      s13d=0.0d0
8921 #ifdef MOMENT
8922       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8923      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8924 #else
8925       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8926      &               -0.5d0*ekont*(s2d+s12d)
8927 #endif
8928 C Cartesian derivatives
8929       do iii=1,2
8930         do kkk=1,5
8931           do lll=1,3
8932 #ifdef MOMENT
8933             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8934             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8935             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8936 #endif
8937             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8938             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8939      &          vtemp1d(1))
8940             s2d = scalar2(b1(1,itk),vtemp1d(1))
8941 #ifdef MOMENT
8942             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8943             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8944             s8d = -(atempd(1,1)+atempd(2,2))*
8945      &           scalar2(cc(1,1,itl),vtemp2(1))
8946 #endif
8947             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8948      &           auxmatd(1,1))
8949             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8950             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8951 c      s1d=0.0d0
8952 c      s2d=0.0d0
8953 c      s8d=0.0d0
8954 c      s12d=0.0d0
8955 c      s13d=0.0d0
8956 #ifdef MOMENT
8957             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8958      &        - 0.5d0*(s1d+s2d)
8959 #else
8960             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8961      &        - 0.5d0*s2d
8962 #endif
8963 #ifdef MOMENT
8964             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8965      &        - 0.5d0*(s8d+s12d)
8966 #else
8967             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8968      &        - 0.5d0*s12d
8969 #endif
8970           enddo
8971         enddo
8972       enddo
8973 #ifdef MOMENT
8974       do kkk=1,5
8975         do lll=1,3
8976           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8977      &      achuj_tempd(1,1))
8978           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8979           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8980           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8981           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8982           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8983      &      vtemp4d(1))
8984           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8985           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8986           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8987         enddo
8988       enddo
8989 #endif
8990 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8991 cd     &  16*eel_turn6_num
8992 cd      goto 1112
8993       if (j.lt.nres-1) then
8994         j1=j+1
8995         j2=j-1
8996       else
8997         j1=j-1
8998         j2=j-2
8999       endif
9000       if (l.lt.nres-1) then
9001         l1=l+1
9002         l2=l-1
9003       else
9004         l1=l-1
9005         l2=l-2
9006       endif
9007       do ll=1,3
9008 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9009 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9010 cgrad        ghalf=0.5d0*ggg1(ll)
9011 cd        ghalf=0.0d0
9012         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9013         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9014         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9015      &    +ekont*derx_turn(ll,2,1)
9016         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9017         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9018      &    +ekont*derx_turn(ll,4,1)
9019         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9020         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9021         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9022 cgrad        ghalf=0.5d0*ggg2(ll)
9023 cd        ghalf=0.0d0
9024         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9025      &    +ekont*derx_turn(ll,2,2)
9026         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9027         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9028      &    +ekont*derx_turn(ll,4,2)
9029         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9030         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9031         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9032       enddo
9033 cd      goto 1112
9034 cgrad      do m=i+1,j-1
9035 cgrad        do ll=1,3
9036 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9037 cgrad        enddo
9038 cgrad      enddo
9039 cgrad      do m=k+1,l-1
9040 cgrad        do ll=1,3
9041 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9042 cgrad        enddo
9043 cgrad      enddo
9044 cgrad1112  continue
9045 cgrad      do m=i+2,j2
9046 cgrad        do ll=1,3
9047 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9048 cgrad        enddo
9049 cgrad      enddo
9050 cgrad      do m=k+2,l2
9051 cgrad        do ll=1,3
9052 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9053 cgrad        enddo
9054 cgrad      enddo
9055 cd      do iii=1,nres-3
9056 cd        write (2,*) iii,g_corr6_loc(iii)
9057 cd      enddo
9058       eello_turn6=ekont*eel_turn6
9059 cd      write (2,*) 'ekont',ekont
9060 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9061       return
9062       end
9063
9064 C-----------------------------------------------------------------------------
9065       double precision function scalar(u,v)
9066 !DIR$ INLINEALWAYS scalar
9067 #ifndef OSF
9068 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9069 #endif
9070       implicit none
9071       double precision u(3),v(3)
9072 cd      double precision sc
9073 cd      integer i
9074 cd      sc=0.0d0
9075 cd      do i=1,3
9076 cd        sc=sc+u(i)*v(i)
9077 cd      enddo
9078 cd      scalar=sc
9079
9080       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9081       return
9082       end
9083 crc-------------------------------------------------
9084       SUBROUTINE MATVEC2(A1,V1,V2)
9085 !DIR$ INLINEALWAYS MATVEC2
9086 #ifndef OSF
9087 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9088 #endif
9089       implicit real*8 (a-h,o-z)
9090       include 'DIMENSIONS'
9091       DIMENSION A1(2,2),V1(2),V2(2)
9092 c      DO 1 I=1,2
9093 c        VI=0.0
9094 c        DO 3 K=1,2
9095 c    3     VI=VI+A1(I,K)*V1(K)
9096 c        Vaux(I)=VI
9097 c    1 CONTINUE
9098
9099       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9100       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9101
9102       v2(1)=vaux1
9103       v2(2)=vaux2
9104       END
9105 C---------------------------------------
9106       SUBROUTINE MATMAT2(A1,A2,A3)
9107 #ifndef OSF
9108 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9109 #endif
9110       implicit real*8 (a-h,o-z)
9111       include 'DIMENSIONS'
9112       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9113 c      DIMENSION AI3(2,2)
9114 c        DO  J=1,2
9115 c          A3IJ=0.0
9116 c          DO K=1,2
9117 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9118 c          enddo
9119 c          A3(I,J)=A3IJ
9120 c       enddo
9121 c      enddo
9122
9123       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9124       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9125       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9126       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9127
9128       A3(1,1)=AI3_11
9129       A3(2,1)=AI3_21
9130       A3(1,2)=AI3_12
9131       A3(2,2)=AI3_22
9132       END
9133
9134 c-------------------------------------------------------------------------
9135       double precision function scalar2(u,v)
9136 !DIR$ INLINEALWAYS scalar2
9137       implicit none
9138       double precision u(2),v(2)
9139       double precision sc
9140       integer i
9141       scalar2=u(1)*v(1)+u(2)*v(2)
9142       return
9143       end
9144
9145 C-----------------------------------------------------------------------------
9146
9147       subroutine transpose2(a,at)
9148 !DIR$ INLINEALWAYS transpose2
9149 #ifndef OSF
9150 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9151 #endif
9152       implicit none
9153       double precision a(2,2),at(2,2)
9154       at(1,1)=a(1,1)
9155       at(1,2)=a(2,1)
9156       at(2,1)=a(1,2)
9157       at(2,2)=a(2,2)
9158       return
9159       end
9160 c--------------------------------------------------------------------------
9161       subroutine transpose(n,a,at)
9162       implicit none
9163       integer n,i,j
9164       double precision a(n,n),at(n,n)
9165       do i=1,n
9166         do j=1,n
9167           at(j,i)=a(i,j)
9168         enddo
9169       enddo
9170       return
9171       end
9172 C---------------------------------------------------------------------------
9173       subroutine prodmat3(a1,a2,kk,transp,prod)
9174 !DIR$ INLINEALWAYS prodmat3
9175 #ifndef OSF
9176 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9177 #endif
9178       implicit none
9179       integer i,j
9180       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9181       logical transp
9182 crc      double precision auxmat(2,2),prod_(2,2)
9183
9184       if (transp) then
9185 crc        call transpose2(kk(1,1),auxmat(1,1))
9186 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9187 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9188
9189            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9190      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9191            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9192      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9193            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9194      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9195            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9196      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9197
9198       else
9199 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9200 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9201
9202            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9203      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9204            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9205      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9206            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9207      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9208            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9209      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9210
9211       endif
9212 c      call transpose2(a2(1,1),a2t(1,1))
9213
9214 crc      print *,transp
9215 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9216 crc      print *,((prod(i,j),i=1,2),j=1,2)
9217
9218       return
9219       end
9220