source/unres/src_MD/energy_p_new_barrier.F

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