source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 c      print *,"Processor",myrank," computed USCSC"
 135 #ifdef TIMING
 136 #ifdef MPI
 137       time01=MPI_Wtime()
 138 #else
 139       time00=tcpu()
 140 #endif
 141 #endif
 142       call vec_and_deriv
 143 #ifdef TIMING
 144 #ifdef MPI
 145       time_vec=time_vec+MPI_Wtime()-time01
 146 #else
 147       time_vec=time_vec+tcpu()-time01
 148 #endif
 149 #endif
 150 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 151       if (ipot.lt.6) then
 152 #ifdef SPLITELE
 153          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 154      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 155      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 156      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 157 #else
 158          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #endif
 163             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 164          else
 165             ees=0.0d0
 166             evdw1=0.0d0
 167             eel_loc=0.0d0
 168             eello_turn3=0.0d0
 169             eello_turn4=0.0d0
 170          endif
 171       else
 172 c        write (iout,*) "Soft-spheer ELEC potential"
 173         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 174      &   eello_turn4)
 175       endif
 176 c      print *,"Processor",myrank," computed UELEC"
 177 C
 178 C Calculate excluded-volume interaction energy between peptide groups
 179 C and side chains.
 180 C
 181       if (ipot.lt.6) then
 182        if(wscp.gt.0d0) then
 183         call escp(evdw2,evdw2_14)
 184        else
 185         evdw2=0
 186         evdw2_14=0
 187        endif
 188       else
 189 c        write (iout,*) "Soft-sphere SCP potential"
 190         call escp_soft_sphere(evdw2,evdw2_14)
 191       endif
 192 c
 193 c Calculate the bond-stretching energy
 194 c
 195       call ebond(estr)
 196 C
 197 C Calculate the disulfide-bridge and other energy and the contributions
 198 C from other distance constraints.
 199 cd    print *,'Calling EHPB'
 200       call edis(ehpb)
 201 cd    print *,'EHPB exitted succesfully.'
 202 C
 203 C Calculate the virtual-bond-angle energy.
 204 C
 205       if (wang.gt.0d0) then
 206         call ebend(ebe)
 207       else
 208         ebe=0
 209       endif
 210 c      print *,"Processor",myrank," computed UB"
 211 C
 212 C Calculate the SC local energy.
 213 C
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 c      print *,"Processor",myrank," computed Usccorr"
 245 C
 246 C 12/1/95 Multi-body terms
 247 C
 248       n_corr=0
 249       n_corr1=0
 250       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 251      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 252          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 253 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 254 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 255       else
 256          ecorr=0.0d0
 257          ecorr5=0.0d0
 258          ecorr6=0.0d0
 259          eturn6=0.0d0
 260       endif
 261       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 262          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 263 cd         write (iout,*) "multibody_hb ecorr",ecorr
 264       endif
 265 c      print *,"Processor",myrank," computed Ucorr"
 266 C
 267 C If performing constraint dynamics, call the constraint energy
 268 C  after the equilibration time
 269       if(usampl.and.totT.gt.eq_time) then
 270          call EconstrQ
 271          call Econstr_back
 272       else
 273          Uconst=0.0d0
 274          Uconst_back=0.0d0
 275       endif
 276 #ifdef TIMING
 277 #ifdef MPI
 278       time_enecalc=time_enecalc+MPI_Wtime()-time00
 279 #else
 280       time_enecalc=time_enecalc+tcpu()-time00
 281 #endif
 282 #endif
 283 c      print *,"Processor",myrank," computed Uconstr"
 284 #ifdef TIMING
 285 #ifdef MPI
 286       time00=MPI_Wtime()
 287 #else
 288       time00=tcpu()
 289 #endif
 290 #endif
 291 c
 292 C Sum the energies
 293 C
 294       energia(1)=evdw
 295 #ifdef SCP14
 296       energia(2)=evdw2-evdw2_14
 297       energia(18)=evdw2_14
 298 #else
 299       energia(2)=evdw2
 300       energia(18)=0.0d0
 301 #endif
 302 #ifdef SPLITELE
 303       energia(3)=ees
 304       energia(16)=evdw1
 305 #else
 306       energia(3)=ees+evdw1
 307       energia(16)=0.0d0
 308 #endif
 309       energia(4)=ecorr
 310       energia(5)=ecorr5
 311       energia(6)=ecorr6
 312       energia(7)=eel_loc
 313       energia(8)=eello_turn3
 314       energia(9)=eello_turn4
 315       energia(10)=eturn6
 316       energia(11)=ebe
 317       energia(12)=escloc
 318       energia(13)=etors
 319       energia(14)=etors_d
 320       energia(15)=ehpb
 321       energia(19)=edihcnstr
 322       energia(17)=estr
 323       energia(20)=Uconst+Uconst_back
 324       energia(21)=esccor
 325       energia(22)=evdw_p
 326       energia(23)=evdw_m
 327 c      print *," Processor",myrank," calls SUM_ENERGY"
 328       call sum_energy(energia,.true.)
 329 c      print *," Processor",myrank," left SUM_ENERGY"
 330 #ifdef TIMING
 331 #ifdef MPI
 332       time_sumene=time_sumene+MPI_Wtime()-time00
 333 #else
 334       time_sumene=time_sumene+tcpu()-time00
 335 #endif
 336 #endif
 337       return
 338       end
 339 c-------------------------------------------------------------------------------
 340       subroutine sum_energy(energia,reduce)
 341       implicit real*8 (a-h,o-z)
 342       include 'DIMENSIONS'
 343 #ifndef ISNAN
 344       external proc_proc
 345 #ifdef WINPGI
 346 cMS$ATTRIBUTES C ::  proc_proc
 347 #endif
 348 #endif
 349 #ifdef MPI
 350       include "mpif.h"
 351 #endif
 352       include 'COMMON.SETUP'
 353       include 'COMMON.IOUNITS'
 354       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 355       include 'COMMON.FFIELD'
 356       include 'COMMON.DERIV'
 357       include 'COMMON.INTERACT'
 358       include 'COMMON.SBRIDGE'
 359       include 'COMMON.CHAIN'
 360       include 'COMMON.VAR'
 361       include 'COMMON.CONTROL'
 362       include 'COMMON.TIME1'
 363       logical reduce
 364 #ifdef MPI
 365       if (nfgtasks.gt.1 .and. reduce) then
 366 #ifdef DEBUG
 367         write (iout,*) "energies before REDUCE"
 368         call enerprint(energia)
 369         call flush(iout)
 370 #endif
 371         do i=0,n_ene
 372           enebuff(i)=energia(i)
 373         enddo
 374         time00=MPI_Wtime()
 375         call MPI_Barrier(FG_COMM,IERR)
 376         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 377         time00=MPI_Wtime()
 378         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 379      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 380 #ifdef DEBUG
 381         write (iout,*) "energies after REDUCE"
 382         call enerprint(energia)
 383         call flush(iout)
 384 #endif
 385         time_Reduce=time_Reduce+MPI_Wtime()-time00
 386       endif
 387       if (fg_rank.eq.0) then
 388 #endif
 389 #ifdef TSCSC
 390       evdw=energia(22)+wsct*energia(23)
 391 #else
 392       evdw=energia(1)
 393 #endif
 394 #ifdef SCP14
 395       evdw2=energia(2)+energia(18)
 396       evdw2_14=energia(18)
 397 #else
 398       evdw2=energia(2)
 399 #endif
 400 #ifdef SPLITELE
 401       ees=energia(3)
 402       evdw1=energia(16)
 403 #else
 404       ees=energia(3)
 405       evdw1=0.0d0
 406 #endif
 407       ecorr=energia(4)
 408       ecorr5=energia(5)
 409       ecorr6=energia(6)
 410       eel_loc=energia(7)
 411       eello_turn3=energia(8)
 412       eello_turn4=energia(9)
 413       eturn6=energia(10)
 414       ebe=energia(11)
 415       escloc=energia(12)
 416       etors=energia(13)
 417       etors_d=energia(14)
 418       ehpb=energia(15)
 419       edihcnstr=energia(19)
 420       estr=energia(17)
 421       Uconst=energia(20)
 422       esccor=energia(21)
 423 #ifdef SPLITELE
 424       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 425      & +wang*ebe+wtor*etors+wscloc*escloc
 426      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 427      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 428      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 429      & +wbond*estr+Uconst+wsccor*esccor
 430 #else
 431       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 432      & +wang*ebe+wtor*etors+wscloc*escloc
 433      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 434      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 435      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 436      & +wbond*estr+Uconst+wsccor*esccor
 437 #endif
 438       energia(0)=etot
 439 c detecting NaNQ
 440 #ifdef ISNAN
 441 #ifdef AIX
 442       if (isnan(etot).ne.0) energia(0)=1.0d+99
 443 #else
 444       if (isnan(etot)) energia(0)=1.0d+99
 445 #endif
 446 #else
 447       i=0
 448 #ifdef WINPGI
 449       idumm=proc_proc(etot,i)
 450 #else
 451       call proc_proc(etot,i)
 452 #endif
 453       if(i.eq.1)energia(0)=1.0d+99
 454 #endif
 455 #ifdef MPI
 456       endif
 457 #endif
 458       return
 459       end
 460 c-------------------------------------------------------------------------------
 461       subroutine sum_gradient
 462       implicit real*8 (a-h,o-z)
 463       include 'DIMENSIONS'
 464 #ifndef ISNAN
 465       external proc_proc
 466 #ifdef WINPGI
 467 cMS$ATTRIBUTES C ::  proc_proc
 468 #endif
 469 #endif
 470 #ifdef MPI
 471       include 'mpif.h'
 472 #endif
 473       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 474      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 475       include 'COMMON.SETUP'
 476       include 'COMMON.IOUNITS'
 477       include 'COMMON.FFIELD'
 478       include 'COMMON.DERIV'
 479       include 'COMMON.INTERACT'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CHAIN'
 482       include 'COMMON.VAR'
 483       include 'COMMON.CONTROL'
 484       include 'COMMON.TIME1'
 485       include 'COMMON.MAXGRAD'
 486       include 'COMMON.SCCOR'
 487 #ifdef TIMING
 488 #ifdef MPI
 489       time01=MPI_Wtime()
 490 #else
 491       time01=tcpu()
 492 #endif
 493 #endif
 494 #ifdef DEBUG
 495       write (iout,*) "sum_gradient gvdwc, gvdwx"
 496       do i=1,nres
 497         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 498      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 499      &   (gvdwcT(j,i),j=1,3)
 500       enddo
 501       call flush(iout)
 502 #endif
 503 #ifdef MPI
 504 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 505         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 506      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 507 #endif
 508 C
 509 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 510 C            in virtual-bond-vector coordinates
 511 C
 512 #ifdef DEBUG
 513 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 514 c      do i=1,nres-1
 515 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 516 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 517 c      enddo
 518 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 521 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 522 c      enddo
 523       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 524       do i=1,nres
 525         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 526      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 527      &   g_corr5_loc(i)
 528       enddo
 529       call flush(iout)
 530 #endif
 531 #ifdef SPLITELE
 532 #ifdef TSCSC
 533       do i=1,nct
 534         do j=1,3
 535           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 536      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 537      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 538      &                wel_loc*gel_loc_long(j,i)+
 539      &                wcorr*gradcorr_long(j,i)+
 540      &                wcorr5*gradcorr5_long(j,i)+
 541      &                wcorr6*gradcorr6_long(j,i)+
 542      &                wturn6*gcorr6_turn_long(j,i)+
 543      &                wstrain*ghpbc(j,i)
 544         enddo
 545       enddo
 546 #else
 547       do i=1,nct
 548         do j=1,3
 549           gradbufc(j,i)=wsc*gvdwc(j,i)+
 550      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 551      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 552      &                wel_loc*gel_loc_long(j,i)+
 553      &                wcorr*gradcorr_long(j,i)+
 554      &                wcorr5*gradcorr5_long(j,i)+
 555      &                wcorr6*gradcorr6_long(j,i)+
 556      &                wturn6*gcorr6_turn_long(j,i)+
 557      &                wstrain*ghpbc(j,i)
 558         enddo
 559       enddo
 560 #endif
 561 #else
 562       do i=1,nct
 563         do j=1,3
 564           gradbufc(j,i)=wsc*gvdwc(j,i)+
 565      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 566      &                welec*gelc_long(j,i)+
 567      &                wbond*gradb(j,i)+
 568      &                wel_loc*gel_loc_long(j,i)+
 569      &                wcorr*gradcorr_long(j,i)+
 570      &                wcorr5*gradcorr5_long(j,i)+
 571      &                wcorr6*gradcorr6_long(j,i)+
 572      &                wturn6*gcorr6_turn_long(j,i)+
 573      &                wstrain*ghpbc(j,i)
 574         enddo
 575       enddo
 576 #endif
 577 #ifdef MPI
 578       if (nfgtasks.gt.1) then
 579       time00=MPI_Wtime()
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc before allreduce"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       do i=1,nres
 588         do j=1,3
 589           gradbufc_sum(j,i)=gradbufc(j,i)
 590         enddo
 591       enddo
 592 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 593 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 594 c      time_reduce=time_reduce+MPI_Wtime()-time00
 595 #ifdef DEBUG
 596 c      write (iout,*) "gradbufc_sum after allreduce"
 597 c      do i=1,nres
 598 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 599 c      enddo
 600 c      call flush(iout)
 601 #endif
 602 #ifdef TIMING
 603 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 604 #endif
 605       do i=nnt,nres
 606         do k=1,3
 607           gradbufc(k,i)=0.0d0
 608         enddo
 609       enddo
 610 #ifdef DEBUG
 611       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 612       write (iout,*) (i," jgrad_start",jgrad_start(i),
 613      &                  " jgrad_end  ",jgrad_end(i),
 614      &                  i=igrad_start,igrad_end)
 615 #endif
 616 c
 617 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 618 c do not parallelize this part.
 619 c
 620 c      do i=igrad_start,igrad_end
 621 c        do j=jgrad_start(i),jgrad_end(i)
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627       do j=1,3
 628         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 629       enddo
 630       do i=nres-2,nnt,-1
 631         do j=1,3
 632           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 633         enddo
 634       enddo
 635 #ifdef DEBUG
 636       write (iout,*) "gradbufc after summing"
 637       do i=1,nres
 638         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 639       enddo
 640       call flush(iout)
 641 #endif
 642       else
 643 #endif
 644 #ifdef DEBUG
 645       write (iout,*) "gradbufc"
 646       do i=1,nres
 647         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 648       enddo
 649       call flush(iout)
 650 #endif
 651       do i=1,nres
 652         do j=1,3
 653           gradbufc_sum(j,i)=gradbufc(j,i)
 654           gradbufc(j,i)=0.0d0
 655         enddo
 656       enddo
 657       do j=1,3
 658         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 659       enddo
 660       do i=nres-2,nnt,-1
 661         do j=1,3
 662           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 663         enddo
 664       enddo
 665 c      do i=nnt,nres-1
 666 c        do k=1,3
 667 c          gradbufc(k,i)=0.0d0
 668 c        enddo
 669 c        do j=i+1,nres
 670 c          do k=1,3
 671 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 672 c          enddo
 673 c        enddo
 674 c      enddo
 675 #ifdef DEBUG
 676       write (iout,*) "gradbufc after summing"
 677       do i=1,nres
 678         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 679       enddo
 680       call flush(iout)
 681 #endif
 682 #ifdef MPI
 683       endif
 684 #endif
 685       do k=1,3
 686         gradbufc(k,nres)=0.0d0
 687       enddo
 688       do i=1,nct
 689         do j=1,3
 690 #ifdef SPLITELE
 691           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 692      &                wel_loc*gel_loc(j,i)+
 693      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 694      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 695      &                wel_loc*gel_loc_long(j,i)+
 696      &                wcorr*gradcorr_long(j,i)+
 697      &                wcorr5*gradcorr5_long(j,i)+
 698      &                wcorr6*gradcorr6_long(j,i)+
 699      &                wturn6*gcorr6_turn_long(j,i))+
 700      &                wbond*gradb(j,i)+
 701      &                wcorr*gradcorr(j,i)+
 702      &                wturn3*gcorr3_turn(j,i)+
 703      &                wturn4*gcorr4_turn(j,i)+
 704      &                wcorr5*gradcorr5(j,i)+
 705      &                wcorr6*gradcorr6(j,i)+
 706      &                wturn6*gcorr6_turn(j,i)+
 707      &                wsccor*gsccorc(j,i)
 708      &               +wscloc*gscloc(j,i)
 709 #else
 710           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 711      &                wel_loc*gel_loc(j,i)+
 712      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 713      &                welec*gelc_long(j,i)+
 714      &                wel_loc*gel_loc_long(j,i)+
 715      &                wcorr*gcorr_long(j,i)+
 716      &                wcorr5*gradcorr5_long(j,i)+
 717      &                wcorr6*gradcorr6_long(j,i)+
 718      &                wturn6*gcorr6_turn_long(j,i))+
 719      &                wbond*gradb(j,i)+
 720      &                wcorr*gradcorr(j,i)+
 721      &                wturn3*gcorr3_turn(j,i)+
 722      &                wturn4*gcorr4_turn(j,i)+
 723      &                wcorr5*gradcorr5(j,i)+
 724      &                wcorr6*gradcorr6(j,i)+
 725      &                wturn6*gcorr6_turn(j,i)+
 726      &                wsccor*gsccorc(j,i)
 727      &               +wscloc*gscloc(j,i)
 728 #endif
 729 #ifdef TSCSC
 730           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 731      &                  wscp*gradx_scp(j,i)+
 732      &                  wbond*gradbx(j,i)+
 733      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 734      &                  wsccor*gsccorx(j,i)
 735      &                 +wscloc*gsclocx(j,i)
 736 #else
 737           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 738      &                  wbond*gradbx(j,i)+
 739      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 740      &                  wsccor*gsccorx(j,i)
 741      &                 +wscloc*gsclocx(j,i)
 742 #endif
 743         enddo
 744       enddo
 745 #ifdef DEBUG
 746       write (iout,*) "gloc before adding corr"
 747       do i=1,4*nres
 748         write (iout,*) i,gloc(i,icg)
 749       enddo
 750 #endif
 751       do i=1,nres-3
 752         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 753      &   +wcorr5*g_corr5_loc(i)
 754      &   +wcorr6*g_corr6_loc(i)
 755      &   +wturn4*gel_loc_turn4(i)
 756      &   +wturn3*gel_loc_turn3(i)
 757      &   +wturn6*gel_loc_turn6(i)
 758      &   +wel_loc*gel_loc_loc(i)
 759       enddo
 760 #ifdef DEBUG
 761       write (iout,*) "gloc after adding corr"
 762       do i=1,4*nres
 763         write (iout,*) i,gloc(i,icg)
 764       enddo
 765 #endif
 766 #ifdef MPI
 767       if (nfgtasks.gt.1) then
 768         do j=1,3
 769           do i=1,nres
 770             gradbufc(j,i)=gradc(j,i,icg)
 771             gradbufx(j,i)=gradx(j,i,icg)
 772           enddo
 773         enddo
 774         do i=1,4*nres
 775           glocbuf(i)=gloc(i,icg)
 776         enddo
 777 #define DEBUG
 778 #ifdef DEBUG
 779       write (iout,*) "gloc_sc before reduce"
 780       do i=1,nres
 781        do j=1,3
 782         write (iout,*) i,j,gloc_sc(j,i,icg)
 783        enddo
 784       enddo
 785 #endif
 786 #undef DEBUG
 787         do i=1,nres
 788          do j=1,3
 789           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 790          enddo
 791         enddo
 792         time00=MPI_Wtime()
 793         call MPI_Barrier(FG_COMM,IERR)
 794         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 795         time00=MPI_Wtime()
 796         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 797      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 798         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 799      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 800         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 802         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 803      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 804         time_reduce=time_reduce+MPI_Wtime()-time00
 805 #define DEBUG
 806 #ifdef DEBUG
 807       write (iout,*) "gloc_sc after reduce"
 808       do i=1,nres
 809        do j=1,3
 810         write (iout,*) i,j,gloc_sc(j,i,icg)
 811        enddo
 812       enddo
 813 #endif
 814 #undef DEBUG
 815 #ifdef DEBUG
 816       write (iout,*) "gloc after reduce"
 817       do i=1,4*nres
 818         write (iout,*) i,gloc(i,icg)
 819       enddo
 820 #endif
 821       endif
 822 #endif
 823       if (gnorm_check) then
 824 c
 825 c Compute the maximum elements of the gradient
 826 c
 827       gvdwc_max=0.0d0
 828       gvdwc_scp_max=0.0d0
 829       gelc_max=0.0d0
 830       gvdwpp_max=0.0d0
 831       gradb_max=0.0d0
 832       ghpbc_max=0.0d0
 833       gradcorr_max=0.0d0
 834       gel_loc_max=0.0d0
 835       gcorr3_turn_max=0.0d0
 836       gcorr4_turn_max=0.0d0
 837       gradcorr5_max=0.0d0
 838       gradcorr6_max=0.0d0
 839       gcorr6_turn_max=0.0d0
 840       gsccorc_max=0.0d0
 841       gscloc_max=0.0d0
 842       gvdwx_max=0.0d0
 843       gradx_scp_max=0.0d0
 844       ghpbx_max=0.0d0
 845       gradxorr_max=0.0d0
 846       gsccorx_max=0.0d0
 847       gsclocx_max=0.0d0
 848       do i=1,nct
 849         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 850         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 851 #ifdef TSCSC
 852         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 853         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 854 #endif
 855         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 856         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 857      &   gvdwc_scp_max=gvdwc_scp_norm
 858         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 859         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 860         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 861         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 862         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 863         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 864         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 865         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 866         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 867         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 868         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 869         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 870         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 871      &    gcorr3_turn(1,i)))
 872         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 873      &    gcorr3_turn_max=gcorr3_turn_norm
 874         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 875      &    gcorr4_turn(1,i)))
 876         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 877      &    gcorr4_turn_max=gcorr4_turn_norm
 878         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 879         if (gradcorr5_norm.gt.gradcorr5_max)
 880      &    gradcorr5_max=gradcorr5_norm
 881         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 882         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 883         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 884      &    gcorr6_turn(1,i)))
 885         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 886      &    gcorr6_turn_max=gcorr6_turn_norm
 887         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 888         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 889         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 890         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 891         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 892         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 893 #ifdef TSCSC
 894         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 895         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 896 #endif
 897         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 898         if (gradx_scp_norm.gt.gradx_scp_max)
 899      &    gradx_scp_max=gradx_scp_norm
 900         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 901         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 902         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 903         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 904         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 905         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 906         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 907         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 908       enddo
 909       if (gradout) then
 910 #ifdef AIX
 911         open(istat,file=statname,position="append")
 912 #else
 913         open(istat,file=statname,access="append")
 914 #endif
 915         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 916      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 917      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 918      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 919      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 920      &     gsccorx_max,gsclocx_max
 921         close(istat)
 922         if (gvdwc_max.gt.1.0d4) then
 923           write (iout,*) "gvdwc gvdwx gradb gradbx"
 924           do i=nnt,nct
 925             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 926      &        gradb(j,i),gradbx(j,i),j=1,3)
 927           enddo
 928           call pdbout(0.0d0,'cipiszcze',iout)
 929           call flush(iout)
 930         endif
 931       endif
 932       endif
 933 #ifdef DEBUG
 934       write (iout,*) "gradc gradx gloc"
 935       do i=1,nres
 936         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 937      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 938       enddo
 939 #endif
 940 #ifdef TIMING
 941 #ifdef MPI
 942       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 943 #else
 944       time_sumgradient=time_sumgradient+tcpu()-time01
 945 #endif
 946 #endif
 947       return
 948       end
 949 c-------------------------------------------------------------------------------
 950       subroutine rescale_weights(t_bath)
 951       implicit real*8 (a-h,o-z)
 952       include 'DIMENSIONS'
 953       include 'COMMON.IOUNITS'
 954       include 'COMMON.FFIELD'
 955       include 'COMMON.SBRIDGE'
 956       double precision kfac /2.4d0/
 957       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 958 c      facT=temp0/t_bath
 959 c      facT=2*temp0/(t_bath+temp0)
 960       if (rescale_mode.eq.0) then
 961         facT=1.0d0
 962         facT2=1.0d0
 963         facT3=1.0d0
 964         facT4=1.0d0
 965         facT5=1.0d0
 966       else if (rescale_mode.eq.1) then
 967         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 968         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 969         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 970         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 971         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 972       else if (rescale_mode.eq.2) then
 973         x=t_bath/temp0
 974         x2=x*x
 975         x3=x2*x
 976         x4=x3*x
 977         x5=x4*x
 978         facT=licznik/dlog(dexp(x)+dexp(-x))
 979         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 980         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 981         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 982         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 983       else
 984         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 985         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 986 #ifdef MPI
 987        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 988 #endif
 989        stop 555
 990       endif
 991       welec=weights(3)*fact
 992       wcorr=weights(4)*fact3
 993       wcorr5=weights(5)*fact4
 994       wcorr6=weights(6)*fact5
 995       wel_loc=weights(7)*fact2
 996       wturn3=weights(8)*fact2
 997       wturn4=weights(9)*fact3
 998       wturn6=weights(10)*fact5
 999       wtor=weights(13)*fact
1000       wtor_d=weights(14)*fact2
1001       wsccor=weights(21)*fact
1002 #ifdef TSCSC
1003 c      wsct=t_bath/temp0
1004       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1005 #endif
1006       return
1007       end
1008 C------------------------------------------------------------------------
1009       subroutine enerprint(energia)
1010       implicit real*8 (a-h,o-z)
1011       include 'DIMENSIONS'
1012       include 'COMMON.IOUNITS'
1013       include 'COMMON.FFIELD'
1014       include 'COMMON.SBRIDGE'
1015       include 'COMMON.MD'
1016       double precision energia(0:n_ene)
1017       etot=energia(0)
1018 #ifdef TSCSC
1019       evdw=energia(22)+wsct*energia(23)
1020 #else
1021       evdw=energia(1)
1022 #endif
1023       evdw2=energia(2)
1024 #ifdef SCP14
1025       evdw2=energia(2)+energia(18)
1026 #else
1027       evdw2=energia(2)
1028 #endif
1029       ees=energia(3)
1030 #ifdef SPLITELE
1031       evdw1=energia(16)
1032 #endif
1033       ecorr=energia(4)
1034       ecorr5=energia(5)
1035       ecorr6=energia(6)
1036       eel_loc=energia(7)
1037       eello_turn3=energia(8)
1038       eello_turn4=energia(9)
1039       eello_turn6=energia(10)
1040       ebe=energia(11)
1041       escloc=energia(12)
1042       etors=energia(13)
1043       etors_d=energia(14)
1044       ehpb=energia(15)
1045       edihcnstr=energia(19)
1046       estr=energia(17)
1047       Uconst=energia(20)
1048       esccor=energia(21)
1049 #ifdef SPLITELE
1050       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1051      &  estr,wbond,ebe,wang,
1052      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1053      &  ecorr,wcorr,
1054      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1055      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1056      &  edihcnstr,ebr*nss,
1057      &  Uconst,etot
1058    10 format (/'Virtual-chain energies:'//
1059      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1060      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1061      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1062      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1063      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1064      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1065      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1066      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1067      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1068      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1069      & ' (SS bridges & dist. cnstr.)'/
1070      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1071      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1072      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1073      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1074      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1075      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1076      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1077      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1078      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1079      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1080      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1081      & 'ETOT=  ',1pE16.6,' (total)')
1082 #else
1083       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1084      &  estr,wbond,ebe,wang,
1085      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1086      &  ecorr,wcorr,
1087      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1088      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1089      &  ebr*nss,Uconst,etot
1090    10 format (/'Virtual-chain energies:'//
1091      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1092      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1093      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1094      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1095      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1096      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1097      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1098      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1099      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1100      & ' (SS bridges & dist. cnstr.)'/
1101      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1102      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1105      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1106      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1107      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1108      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1109      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1110      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1111      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1112      & 'ETOT=  ',1pE16.6,' (total)')
1113 #endif
1114       return
1115       end
1116 C-----------------------------------------------------------------------
1117       subroutine elj(evdw,evdw_p,evdw_m)
1118 C
1119 C This subroutine calculates the interaction energy of nonbonded side chains
1120 C assuming the LJ potential of interaction.
1121 C
1122       implicit real*8 (a-h,o-z)
1123       include 'DIMENSIONS'
1124       parameter (accur=1.0d-10)
1125       include 'COMMON.GEO'
1126       include 'COMMON.VAR'
1127       include 'COMMON.LOCAL'
1128       include 'COMMON.CHAIN'
1129       include 'COMMON.DERIV'
1130       include 'COMMON.INTERACT'
1131       include 'COMMON.TORSION'
1132       include 'COMMON.SBRIDGE'
1133       include 'COMMON.NAMES'
1134       include 'COMMON.IOUNITS'
1135       include 'COMMON.CONTACTS'
1136       dimension gg(3)
1137 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1138       evdw=0.0D0
1139       do i=iatsc_s,iatsc_e
1140         itypi=iabs(itype(i))
1141         itypi1=iabs(itype(i+1))
1142         xi=c(1,nres+i)
1143         yi=c(2,nres+i)
1144         zi=c(3,nres+i)
1145 C Change 12/1/95
1146         num_conti=0
1147 C
1148 C Calculate SC interaction energy.
1149 C
1150         do iint=1,nint_gr(i)
1151 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1152 cd   &                  'iend=',iend(i,iint)
1153           do j=istart(i,iint),iend(i,iint)
1154             itypj=iabs(itype(j))
1155             xj=c(1,nres+j)-xi
1156             yj=c(2,nres+j)-yi
1157             zj=c(3,nres+j)-zi
1158 C Change 12/1/95 to calculate four-body interactions
1159             rij=xj*xj+yj*yj+zj*zj
1160             rrij=1.0D0/rij
1161 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1162             eps0ij=eps(itypi,itypj)
1163             fac=rrij**expon2
1164             e1=fac*fac*aa(itypi,itypj)
1165             e2=fac*bb(itypi,itypj)
1166             evdwij=e1+e2
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1170 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1173 #ifdef TSCSC
1174             if (bb(itypi,itypj).gt.0) then
1175                evdw_p=evdw_p+evdwij
1176             else
1177                evdw_m=evdw_m+evdwij
1178             endif
1179 #else
1180             evdw=evdw+evdwij
1181 #endif
1182 C
1183 C Calculate the components of the gradient in DC and X
1184 C
1185             fac=-rrij*(e1+evdwij)
1186             gg(1)=xj*fac
1187             gg(2)=yj*fac
1188             gg(3)=zj*fac
1189 #ifdef TSCSC
1190             if (bb(itypi,itypj).gt.0.0d0) then
1191               do k=1,3
1192                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1194                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1195                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1196               enddo
1197             else
1198               do k=1,3
1199                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1200                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1201                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1202                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1203               enddo
1204             endif
1205 #else
1206             do k=1,3
1207               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1208               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1209               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1210               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1211             enddo
1212 #endif
1213 cgrad            do k=i,j-1
1214 cgrad              do l=1,3
1215 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1216 cgrad              enddo
1217 cgrad            enddo
1218 C
1219 C 12/1/95, revised on 5/20/97
1220 C
1221 C Calculate the contact function. The ith column of the array JCONT will
1222 C contain the numbers of atoms that make contacts with the atom I (of numbers
1223 C greater than I). The arrays FACONT and GACONT will contain the values of
1224 C the contact function and its derivative.
1225 C
1226 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1227 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1228 C Uncomment next line, if the correlation interactions are contact function only
1229             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1230               rij=dsqrt(rij)
1231               sigij=sigma(itypi,itypj)
1232               r0ij=rs0(itypi,itypj)
1233 C
1234 C Check whether the SC's are not too far to make a contact.
1235 C
1236               rcut=1.5d0*r0ij
1237               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1238 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1239 C
1240               if (fcont.gt.0.0D0) then
1241 C If the SC-SC distance if close to sigma, apply spline.
1242 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1243 cAdam &             fcont1,fprimcont1)
1244 cAdam           fcont1=1.0d0-fcont1
1245 cAdam           if (fcont1.gt.0.0d0) then
1246 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1247 cAdam             fcont=fcont*fcont1
1248 cAdam           endif
1249 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1250 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1251 cga             do k=1,3
1252 cga               gg(k)=gg(k)*eps0ij
1253 cga             enddo
1254 cga             eps0ij=-evdwij*eps0ij
1255 C Uncomment for AL's type of SC correlation interactions.
1256 cadam           eps0ij=-evdwij
1257                 num_conti=num_conti+1
1258                 jcont(num_conti,i)=j
1259                 facont(num_conti,i)=fcont*eps0ij
1260                 fprimcont=eps0ij*fprimcont/rij
1261                 fcont=expon*fcont
1262 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1263 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1264 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1265 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1266                 gacont(1,num_conti,i)=-fprimcont*xj
1267                 gacont(2,num_conti,i)=-fprimcont*yj
1268                 gacont(3,num_conti,i)=-fprimcont*zj
1269 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1270 cd              write (iout,'(2i3,3f10.5)')
1271 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1272               endif
1273             endif
1274           enddo      ! j
1275         enddo        ! iint
1276 C Change 12/1/95
1277         num_cont(i)=num_conti
1278       enddo          ! i
1279       do i=1,nct
1280         do j=1,3
1281           gvdwc(j,i)=expon*gvdwc(j,i)
1282           gvdwx(j,i)=expon*gvdwx(j,i)
1283         enddo
1284       enddo
1285 C******************************************************************************
1286 C
1287 C                              N O T E !!!
1288 C
1289 C To save time, the factor of EXPON has been extracted from ALL components
1290 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1291 C use!
1292 C
1293 C******************************************************************************
1294       return
1295       end
1296 C-----------------------------------------------------------------------------
1297       subroutine eljk(evdw,evdw_p,evdw_m)
1298 C
1299 C This subroutine calculates the interaction energy of nonbonded side chains
1300 C assuming the LJK potential of interaction.
1301 C
1302       implicit real*8 (a-h,o-z)
1303       include 'DIMENSIONS'
1304       include 'COMMON.GEO'
1305       include 'COMMON.VAR'
1306       include 'COMMON.LOCAL'
1307       include 'COMMON.CHAIN'
1308       include 'COMMON.DERIV'
1309       include 'COMMON.INTERACT'
1310       include 'COMMON.IOUNITS'
1311       include 'COMMON.NAMES'
1312       dimension gg(3)
1313       logical scheck
1314 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1315       evdw=0.0D0
1316       do i=iatsc_s,iatsc_e
1317         itypi=iabs(itype(i))
1318         itypi1=iabs(itype(i+1))
1319         xi=c(1,nres+i)
1320         yi=c(2,nres+i)
1321         zi=c(3,nres+i)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             itypj=iabs(itype(j))
1328             xj=c(1,nres+j)-xi
1329             yj=c(2,nres+j)-yi
1330             zj=c(3,nres+j)-zi
1331             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1332             fac_augm=rrij**expon
1333             e_augm=augm(itypi,itypj)*fac_augm
1334             r_inv_ij=dsqrt(rrij)
1335             rij=1.0D0/r_inv_ij
1336             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1337             fac=r_shift_inv**expon
1338             e1=fac*fac*aa(itypi,itypj)
1339             e2=fac*bb(itypi,itypj)
1340             evdwij=e_augm+e1+e2
1341 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1342 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1343 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1344 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1345 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1346 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1347 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1348 #ifdef TSCSC
1349             if (bb(itypi,itypj).gt.0) then
1350                evdw_p=evdw_p+evdwij
1351             else
1352                evdw_m=evdw_m+evdwij
1353             endif
1354 #else
1355             evdw=evdw+evdwij
1356 #endif
1357 C
1358 C Calculate the components of the gradient in DC and X
1359 C
1360             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1361             gg(1)=xj*fac
1362             gg(2)=yj*fac
1363             gg(3)=zj*fac
1364 #ifdef TSCSC
1365             if (bb(itypi,itypj).gt.0.0d0) then
1366               do k=1,3
1367                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1368                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1369                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1370                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1371               enddo
1372             else
1373               do k=1,3
1374                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1375                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1376                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1377                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1378               enddo
1379             endif
1380 #else
1381             do k=1,3
1382               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1383               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1384               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1385               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1386             enddo
1387 #endif
1388 cgrad            do k=i,j-1
1389 cgrad              do l=1,3
1390 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1391 cgrad              enddo
1392 cgrad            enddo
1393           enddo      ! j
1394         enddo        ! iint
1395       enddo          ! i
1396       do i=1,nct
1397         do j=1,3
1398           gvdwc(j,i)=expon*gvdwc(j,i)
1399           gvdwx(j,i)=expon*gvdwx(j,i)
1400         enddo
1401       enddo
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine ebp(evdw,evdw_p,evdw_m)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Berne-Pechukas potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       common /srutu/ icall
1422 c     double precision rrsave(maxdim)
1423       logical lprn
1424       evdw=0.0D0
1425 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427 c     if (icall.eq.0) then
1428 c       lprn=.true.
1429 c     else
1430         lprn=.false.
1431 c     endif
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=iabs(itype(i))
1435         itypi1=iabs(itype(i+1))
1436         xi=c(1,nres+i)
1437         yi=c(2,nres+i)
1438         zi=c(3,nres+i)
1439         dxi=dc_norm(1,nres+i)
1440         dyi=dc_norm(2,nres+i)
1441         dzi=dc_norm(3,nres+i)
1442 c        dsci_inv=dsc_inv(itypi)
1443         dsci_inv=vbld_inv(i+nres)
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             ind=ind+1
1450             itypj=itype(j)
1451 c            dscj_inv=dsc_inv(itypj)
1452             dscj_inv=vbld_inv(j+nres)
1453             chi1=chi(itypi,itypj)
1454             chi2=chi(itypj,itypi)
1455             chi12=chi1*chi2
1456             chip1=chip(itypi)
1457             chip2=chip(itypj)
1458             chip12=chip1*chip2
1459             alf1=alp(itypi)
1460             alf2=alp(itypj)
1461             alf12=0.5D0*(alf1+alf2)
1462 C For diagnostics only!!!
1463 c           chi1=0.0D0
1464 c           chi2=0.0D0
1465 c           chi12=0.0D0
1466 c           chip1=0.0D0
1467 c           chip2=0.0D0
1468 c           chip12=0.0D0
1469 c           alf1=0.0D0
1470 c           alf2=0.0D0
1471 c           alf12=0.0D0
1472             xj=c(1,nres+j)-xi
1473             yj=c(2,nres+j)-yi
1474             zj=c(3,nres+j)-zi
1475             dxj=dc_norm(1,nres+j)
1476             dyj=dc_norm(2,nres+j)
1477             dzj=dc_norm(3,nres+j)
1478             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1479 cd          if (icall.eq.0) then
1480 cd            rrsave(ind)=rrij
1481 cd          else
1482 cd            rrij=rrsave(ind)
1483 cd          endif
1484             rij=dsqrt(rrij)
1485 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1486             call sc_angular
1487 C Calculate whole angle-dependent part of epsilon and contributions
1488 C to its derivatives
1489             fac=(rrij*sigsq)**expon2
1490             e1=fac*fac*aa(itypi,itypj)
1491             e2=fac*bb(itypi,itypj)
1492             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1493             eps2der=evdwij*eps3rt
1494             eps3der=evdwij*eps2rt
1495             evdwij=evdwij*eps2rt*eps3rt
1496 #ifdef TSCSC
1497             if (bb(itypi,itypj).gt.0) then
1498                evdw_p=evdw_p+evdwij
1499             else
1500                evdw_m=evdw_m+evdwij
1501             endif
1502 #else
1503             evdw=evdw+evdwij
1504 #endif
1505             if (lprn) then
1506             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1507             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1508 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1509 cd     &        restyp(itypi),i,restyp(itypj),j,
1510 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1511 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1512 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1513 cd     &        evdwij
1514             endif
1515 C Calculate gradient components.
1516             e1=e1*eps1*eps2rt**2*eps3rt**2
1517             fac=-expon*(e1+evdwij)
1518             sigder=fac/sigsq
1519             fac=rrij*fac
1520 C Calculate radial part of the gradient
1521             gg(1)=xj*fac
1522             gg(2)=yj*fac
1523             gg(3)=zj*fac
1524 C Calculate the angular part of the gradient and sum add the contributions
1525 C to the appropriate components of the Cartesian gradient.
1526 #ifdef TSCSC
1527             if (bb(itypi,itypj).gt.0) then
1528                call sc_grad
1529             else
1530                call sc_grad_T
1531             endif
1532 #else
1533             call sc_grad
1534 #endif
1535           enddo      ! j
1536         enddo        ! iint
1537       enddo          ! i
1538 c     stop
1539       return
1540       end
1541 C-----------------------------------------------------------------------------
1542       subroutine egb(evdw,evdw_p,evdw_m)
1543 C
1544 C This subroutine calculates the interaction energy of nonbonded side chains
1545 C assuming the Gay-Berne potential of interaction.
1546 C
1547       implicit real*8 (a-h,o-z)
1548       include 'DIMENSIONS'
1549       include 'COMMON.GEO'
1550       include 'COMMON.VAR'
1551       include 'COMMON.LOCAL'
1552       include 'COMMON.CHAIN'
1553       include 'COMMON.DERIV'
1554       include 'COMMON.NAMES'
1555       include 'COMMON.INTERACT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.CALC'
1558       include 'COMMON.CONTROL'
1559       logical lprn
1560       evdw=0.0D0
1561 ccccc      energy_dec=.false.
1562 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1563       evdw=0.0D0
1564       evdw_p=0.0D0
1565       evdw_m=0.0D0
1566       lprn=.false.
1567 c     if (icall.eq.0) lprn=.false.
1568       ind=0
1569       do i=iatsc_s,iatsc_e
1570         itypi=iabs(itype(i))
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1581 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1582 C
1583 C Calculate SC interaction energy.
1584 C
1585         do iint=1,nint_gr(i)
1586           do j=istart(i,iint),iend(i,iint)
1587             ind=ind+1
1588             itypj=iabs(itype(j))
1589 c            dscj_inv=dsc_inv(itypj)
1590             dscj_inv=vbld_inv(j+nres)
1591 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1592 c     &       1.0d0/vbld(j+nres)
1593 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1594             sig0ij=sigma(itypi,itypj)
1595             chi1=chi(itypi,itypj)
1596             chi2=chi(itypj,itypi)
1597             chi12=chi1*chi2
1598             chip1=chip(itypi)
1599             chip2=chip(itypj)
1600             chip12=chip1*chip2
1601             alf1=alp(itypi)
1602             alf2=alp(itypj)
1603             alf12=0.5D0*(alf1+alf2)
1604 C For diagnostics only!!!
1605 c           chi1=0.0D0
1606 c           chi2=0.0D0
1607 c           chi12=0.0D0
1608 c           chip1=0.0D0
1609 c           chip2=0.0D0
1610 c           chip12=0.0D0
1611 c           alf1=0.0D0
1612 c           alf2=0.0D0
1613 c           alf12=0.0D0
1614             xj=c(1,nres+j)-xi
1615             yj=c(2,nres+j)-yi
1616             zj=c(3,nres+j)-zi
1617             dxj=dc_norm(1,nres+j)
1618             dyj=dc_norm(2,nres+j)
1619             dzj=dc_norm(3,nres+j)
1620 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1621 c            write (iout,*) "j",j," dc_norm",
1622 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1623             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1624             rij=dsqrt(rrij)
1625 C Calculate angle-dependent terms of energy and contributions to their
1626 C derivatives.
1627             call sc_angular
1628             sigsq=1.0D0/sigsq
1629             sig=sig0ij*dsqrt(sigsq)
1630             rij_shift=1.0D0/rij-sig+sig0ij
1631 c for diagnostics; uncomment
1632 c            rij_shift=1.2*sig0ij
1633 C I hate to put IF's in the loops, but here don't have another choice!!!!
1634             if (rij_shift.le.0.0D0) then
1635               evdw=1.0D20
1636 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1637 cd     &        restyp(itypi),i,restyp(itypj),j,
1638 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1639               return
1640             endif
1641             sigder=-sig*sigsq
1642 c---------------------------------------------------------------
1643             rij_shift=1.0D0/rij_shift
1644             fac=rij_shift**expon
1645             e1=fac*fac*aa(itypi,itypj)
1646             e2=fac*bb(itypi,itypj)
1647             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1648             eps2der=evdwij*eps3rt
1649             eps3der=evdwij*eps2rt
1650 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1651 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1652             evdwij=evdwij*eps2rt*eps3rt
1653 #ifdef TSCSC
1654             if (bb(itypi,itypj).gt.0) then
1655                evdw_p=evdw_p+evdwij
1656             else
1657                evdw_m=evdw_m+evdwij
1658             endif
1659 #else
1660             evdw=evdw+evdwij
1661 #endif
1662             if (lprn) then
1663             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1664             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1665             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1666      &        restyp(itypi),i,restyp(itypj),j,
1667      &        epsi,sigm,chi1,chi2,chip1,chip2,
1668      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1669      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1670      &        evdwij
1671             endif
1672
1673             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1674      &                        'evdw',i,j,evdwij
1675
1676 C Calculate gradient components.
1677             e1=e1*eps1*eps2rt**2*eps3rt**2
1678             fac=-expon*(e1+evdwij)*rij_shift
1679             sigder=fac*sigder
1680             fac=rij*fac
1681 c            fac=0.0d0
1682 C Calculate the radial part of the gradient
1683             gg(1)=xj*fac
1684             gg(2)=yj*fac
1685             gg(3)=zj*fac
1686 C Calculate angular part of the gradient.
1687 #ifdef TSCSC
1688             if (bb(itypi,itypj).gt.0) then
1689                call sc_grad
1690             else
1691                call sc_grad_T
1692             endif
1693 #else
1694             call sc_grad
1695 #endif
1696           enddo      ! j
1697         enddo        ! iint
1698       enddo          ! i
1699 c      write (iout,*) "Number of loop steps in EGB:",ind
1700 cccc      energy_dec=.false.
1701       return
1702       end
1703 C-----------------------------------------------------------------------------
1704       subroutine egbv(evdw,evdw_p,evdw_m)
1705 C
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne-Vorobjev potential of interaction.
1708 C
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.NAMES'
1717       include 'COMMON.INTERACT'
1718       include 'COMMON.IOUNITS'
1719       include 'COMMON.CALC'
1720       common /srutu/ icall
1721       logical lprn
1722       evdw=0.0D0
1723 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1724       evdw=0.0D0
1725       lprn=.false.
1726 c     if (icall.eq.0) lprn=.true.
1727       ind=0
1728       do i=iatsc_s,iatsc_e
1729         itypi=iabs(itype(i))
1730         itypi1=iabs(itype(i+1))
1731         xi=c(1,nres+i)
1732         yi=c(2,nres+i)
1733         zi=c(3,nres+i)
1734         dxi=dc_norm(1,nres+i)
1735         dyi=dc_norm(2,nres+i)
1736         dzi=dc_norm(3,nres+i)
1737 c        dsci_inv=dsc_inv(itypi)
1738         dsci_inv=vbld_inv(i+nres)
1739 C
1740 C Calculate SC interaction energy.
1741 C
1742         do iint=1,nint_gr(i)
1743           do j=istart(i,iint),iend(i,iint)
1744             ind=ind+1
1745             itypj=iabs(itype(j))
1746 c            dscj_inv=dsc_inv(itypj)
1747             dscj_inv=vbld_inv(j+nres)
1748             sig0ij=sigma(itypi,itypj)
1749             r0ij=r0(itypi,itypj)
1750             chi1=chi(itypi,itypj)
1751             chi2=chi(itypj,itypi)
1752             chi12=chi1*chi2
1753             chip1=chip(itypi)
1754             chip2=chip(itypj)
1755             chip12=chip1*chip2
1756             alf1=alp(itypi)
1757             alf2=alp(itypj)
1758             alf12=0.5D0*(alf1+alf2)
1759 C For diagnostics only!!!
1760 c           chi1=0.0D0
1761 c           chi2=0.0D0
1762 c           chi12=0.0D0
1763 c           chip1=0.0D0
1764 c           chip2=0.0D0
1765 c           chip12=0.0D0
1766 c           alf1=0.0D0
1767 c           alf2=0.0D0
1768 c           alf12=0.0D0
1769             xj=c(1,nres+j)-xi
1770             yj=c(2,nres+j)-yi
1771             zj=c(3,nres+j)-zi
1772             dxj=dc_norm(1,nres+j)
1773             dyj=dc_norm(2,nres+j)
1774             dzj=dc_norm(3,nres+j)
1775             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1776             rij=dsqrt(rrij)
1777 C Calculate angle-dependent terms of energy and contributions to their
1778 C derivatives.
1779             call sc_angular
1780             sigsq=1.0D0/sigsq
1781             sig=sig0ij*dsqrt(sigsq)
1782             rij_shift=1.0D0/rij-sig+r0ij
1783 C I hate to put IF's in the loops, but here don't have another choice!!!!
1784             if (rij_shift.le.0.0D0) then
1785               evdw=1.0D20
1786               return
1787             endif
1788             sigder=-sig*sigsq
1789 c---------------------------------------------------------------
1790             rij_shift=1.0D0/rij_shift
1791             fac=rij_shift**expon
1792             e1=fac*fac*aa(itypi,itypj)
1793             e2=fac*bb(itypi,itypj)
1794             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1795             eps2der=evdwij*eps3rt
1796             eps3der=evdwij*eps2rt
1797             fac_augm=rrij**expon
1798             e_augm=augm(itypi,itypj)*fac_augm
1799             evdwij=evdwij*eps2rt*eps3rt
1800 #ifdef TSCSC
1801             if (bb(itypi,itypj).gt.0) then
1802                evdw_p=evdw_p+evdwij+e_augm
1803             else
1804                evdw_m=evdw_m+evdwij+e_augm
1805             endif
1806 #else
1807             evdw=evdw+evdwij+e_augm
1808 #endif
1809             if (lprn) then
1810             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1811             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1812             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813      &        restyp(itypi),i,restyp(itypj),j,
1814      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1815      &        chi1,chi2,chip1,chip2,
1816      &        eps1,eps2rt**2,eps3rt**2,
1817      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1818      &        evdwij+e_augm
1819             endif
1820 C Calculate gradient components.
1821             e1=e1*eps1*eps2rt**2*eps3rt**2
1822             fac=-expon*(e1+evdwij)*rij_shift
1823             sigder=fac*sigder
1824             fac=rij*fac-2*expon*rrij*e_augm
1825 C Calculate the radial part of the gradient
1826             gg(1)=xj*fac
1827             gg(2)=yj*fac
1828             gg(3)=zj*fac
1829 C Calculate angular part of the gradient.
1830 #ifdef TSCSC
1831             if (bb(itypi,itypj).gt.0) then
1832                call sc_grad
1833             else
1834                call sc_grad_T
1835             endif
1836 #else
1837             call sc_grad
1838 #endif
1839           enddo      ! j
1840         enddo        ! iint
1841       enddo          ! i
1842       end
1843 C-----------------------------------------------------------------------------
1844       subroutine sc_angular
1845 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1846 C om12. Called by ebp, egb, and egbv.
1847       implicit none
1848       include 'COMMON.CALC'
1849       include 'COMMON.IOUNITS'
1850       erij(1)=xj*rij
1851       erij(2)=yj*rij
1852       erij(3)=zj*rij
1853       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1854       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1855       om12=dxi*dxj+dyi*dyj+dzi*dzj
1856       chiom12=chi12*om12
1857 C Calculate eps1(om12) and its derivative in om12
1858       faceps1=1.0D0-om12*chiom12
1859       faceps1_inv=1.0D0/faceps1
1860       eps1=dsqrt(faceps1_inv)
1861 C Following variable is eps1*deps1/dom12
1862       eps1_om12=faceps1_inv*chiom12
1863 c diagnostics only
1864 c      faceps1_inv=om12
1865 c      eps1=om12
1866 c      eps1_om12=1.0d0
1867 c      write (iout,*) "om12",om12," eps1",eps1
1868 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1869 C and om12.
1870       om1om2=om1*om2
1871       chiom1=chi1*om1
1872       chiom2=chi2*om2
1873       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1874       sigsq=1.0D0-facsig*faceps1_inv
1875       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1876       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1877       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1878 c diagnostics only
1879 c      sigsq=1.0d0
1880 c      sigsq_om1=0.0d0
1881 c      sigsq_om2=0.0d0
1882 c      sigsq_om12=0.0d0
1883 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1884 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1885 c     &    " eps1",eps1
1886 C Calculate eps2 and its derivatives in om1, om2, and om12.
1887       chipom1=chip1*om1
1888       chipom2=chip2*om2
1889       chipom12=chip12*om12
1890       facp=1.0D0-om12*chipom12
1891       facp_inv=1.0D0/facp
1892       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1893 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1894 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1895 C Following variable is the square root of eps2
1896       eps2rt=1.0D0-facp1*facp_inv
1897 C Following three variables are the derivatives of the square root of eps
1898 C in om1, om2, and om12.
1899       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1900       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1901       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1902 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1903       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1904 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1905 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1906 c     &  " eps2rt_om12",eps2rt_om12
1907 C Calculate whole angle-dependent part of epsilon and contributions
1908 C to its derivatives
1909       return
1910       end
1911
1912 C----------------------------------------------------------------------------
1913       subroutine sc_grad_T
1914       implicit real*8 (a-h,o-z)
1915       include 'DIMENSIONS'
1916       include 'COMMON.CHAIN'
1917       include 'COMMON.DERIV'
1918       include 'COMMON.CALC'
1919       include 'COMMON.IOUNITS'
1920       double precision dcosom1(3),dcosom2(3)
1921       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1922       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1923       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1924      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1925 c diagnostics only
1926 c      eom1=0.0d0
1927 c      eom2=0.0d0
1928 c      eom12=evdwij*eps1_om12
1929 c end diagnostics
1930 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1931 c     &  " sigder",sigder
1932 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1933 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1934       do k=1,3
1935         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1936         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1937       enddo
1938       do k=1,3
1939         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1940       enddo
1941 c      write (iout,*) "gg",(gg(k),k=1,3)
1942       do k=1,3
1943         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1944      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1945      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1946         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1947      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1948      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1949 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1950 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1951 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1952 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1953       enddo
1954 C
1955 C Calculate the components of the gradient in DC and X
1956 C
1957 cgrad      do k=i,j-1
1958 cgrad        do l=1,3
1959 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1960 cgrad        enddo
1961 cgrad      enddo
1962       do l=1,3
1963         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1964         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1965       enddo
1966       return
1967       end
1968
1969 C----------------------------------------------------------------------------
1970       subroutine sc_grad
1971       implicit real*8 (a-h,o-z)
1972       include 'DIMENSIONS'
1973       include 'COMMON.CHAIN'
1974       include 'COMMON.DERIV'
1975       include 'COMMON.CALC'
1976       include 'COMMON.IOUNITS'
1977       double precision dcosom1(3),dcosom2(3)
1978       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1979       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1980       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1981      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1982 c diagnostics only
1983 c      eom1=0.0d0
1984 c      eom2=0.0d0
1985 c      eom12=evdwij*eps1_om12
1986 c end diagnostics
1987 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1988 c     &  " sigder",sigder
1989 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1990 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1991       do k=1,3
1992         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1993         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1994       enddo
1995       do k=1,3
1996         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1997       enddo
1998 c      write (iout,*) "gg",(gg(k),k=1,3)
1999       do k=1,3
2000         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2001      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2002      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2003         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2004      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2005      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2006 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2007 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2008 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2009 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2010       enddo
2011 C
2012 C Calculate the components of the gradient in DC and X
2013 C
2014 cgrad      do k=i,j-1
2015 cgrad        do l=1,3
2016 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2017 cgrad        enddo
2018 cgrad      enddo
2019       do l=1,3
2020         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2021         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2022       enddo
2023       return
2024       end
2025 C-----------------------------------------------------------------------
2026       subroutine e_softsphere(evdw)
2027 C
2028 C This subroutine calculates the interaction energy of nonbonded side chains
2029 C assuming the LJ potential of interaction.
2030 C
2031       implicit real*8 (a-h,o-z)
2032       include 'DIMENSIONS'
2033       parameter (accur=1.0d-10)
2034       include 'COMMON.GEO'
2035       include 'COMMON.VAR'
2036       include 'COMMON.LOCAL'
2037       include 'COMMON.CHAIN'
2038       include 'COMMON.DERIV'
2039       include 'COMMON.INTERACT'
2040       include 'COMMON.TORSION'
2041       include 'COMMON.SBRIDGE'
2042       include 'COMMON.NAMES'
2043       include 'COMMON.IOUNITS'
2044       include 'COMMON.CONTACTS'
2045       dimension gg(3)
2046 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2047       evdw=0.0D0
2048       do i=iatsc_s,iatsc_e
2049         itypi=iabs(itype(i))
2050         itypi1=iabs(itype(i+1))
2051         xi=c(1,nres+i)
2052         yi=c(2,nres+i)
2053         zi=c(3,nres+i)
2054 C
2055 C Calculate SC interaction energy.
2056 C
2057         do iint=1,nint_gr(i)
2058 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2059 cd   &                  'iend=',iend(i,iint)
2060           do j=istart(i,iint),iend(i,iint)
2061             itypj=iabs(itype(j))
2062             xj=c(1,nres+j)-xi
2063             yj=c(2,nres+j)-yi
2064             zj=c(3,nres+j)-zi
2065             rij=xj*xj+yj*yj+zj*zj
2066 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2067             r0ij=r0(itypi,itypj)
2068             r0ijsq=r0ij*r0ij
2069 c            print *,i,j,r0ij,dsqrt(rij)
2070             if (rij.lt.r0ijsq) then
2071               evdwij=0.25d0*(rij-r0ijsq)**2
2072               fac=rij-r0ijsq
2073             else
2074               evdwij=0.0d0
2075               fac=0.0d0
2076             endif
2077             evdw=evdw+evdwij
2078 C
2079 C Calculate the components of the gradient in DC and X
2080 C
2081             gg(1)=xj*fac
2082             gg(2)=yj*fac
2083             gg(3)=zj*fac
2084             do k=1,3
2085               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2086               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2087               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2088               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2089             enddo
2090 cgrad            do k=i,j-1
2091 cgrad              do l=1,3
2092 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2093 cgrad              enddo
2094 cgrad            enddo
2095           enddo ! j
2096         enddo ! iint
2097       enddo ! i
2098       return
2099       end
2100 C--------------------------------------------------------------------------
2101       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2102      &              eello_turn4)
2103 C
2104 C Soft-sphere potential of p-p interaction
2105 C
2106       implicit real*8 (a-h,o-z)
2107       include 'DIMENSIONS'
2108       include 'COMMON.CONTROL'
2109       include 'COMMON.IOUNITS'
2110       include 'COMMON.GEO'
2111       include 'COMMON.VAR'
2112       include 'COMMON.LOCAL'
2113       include 'COMMON.CHAIN'
2114       include 'COMMON.DERIV'
2115       include 'COMMON.INTERACT'
2116       include 'COMMON.CONTACTS'
2117       include 'COMMON.TORSION'
2118       include 'COMMON.VECTORS'
2119       include 'COMMON.FFIELD'
2120       dimension ggg(3)
2121 cd      write(iout,*) 'In EELEC_soft_sphere'
2122       ees=0.0D0
2123       evdw1=0.0D0
2124       eel_loc=0.0d0
2125       eello_turn3=0.0d0
2126       eello_turn4=0.0d0
2127       ind=0
2128       do i=iatel_s,iatel_e
2129         dxi=dc(1,i)
2130         dyi=dc(2,i)
2131         dzi=dc(3,i)
2132         xmedi=c(1,i)+0.5d0*dxi
2133         ymedi=c(2,i)+0.5d0*dyi
2134         zmedi=c(3,i)+0.5d0*dzi
2135         num_conti=0
2136 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2137         do j=ielstart(i),ielend(i)
2138           ind=ind+1
2139           iteli=itel(i)
2140           itelj=itel(j)
2141           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2142           r0ij=rpp(iteli,itelj)
2143           r0ijsq=r0ij*r0ij
2144           dxj=dc(1,j)
2145           dyj=dc(2,j)
2146           dzj=dc(3,j)
2147           xj=c(1,j)+0.5D0*dxj-xmedi
2148           yj=c(2,j)+0.5D0*dyj-ymedi
2149           zj=c(3,j)+0.5D0*dzj-zmedi
2150           rij=xj*xj+yj*yj+zj*zj
2151           if (rij.lt.r0ijsq) then
2152             evdw1ij=0.25d0*(rij-r0ijsq)**2
2153             fac=rij-r0ijsq
2154           else
2155             evdw1ij=0.0d0
2156             fac=0.0d0
2157           endif
2158           evdw1=evdw1+evdw1ij
2159 C
2160 C Calculate contributions to the Cartesian gradient.
2161 C
2162           ggg(1)=fac*xj
2163           ggg(2)=fac*yj
2164           ggg(3)=fac*zj
2165           do k=1,3
2166             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2167             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2168           enddo
2169 *
2170 * Loop over residues i+1 thru j-1.
2171 *
2172 cgrad          do k=i+1,j-1
2173 cgrad            do l=1,3
2174 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2175 cgrad            enddo
2176 cgrad          enddo
2177         enddo ! j
2178       enddo   ! i
2179 cgrad      do i=nnt,nct-1
2180 cgrad        do k=1,3
2181 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2182 cgrad        enddo
2183 cgrad        do j=i+1,nct-1
2184 cgrad          do k=1,3
2185 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2186 cgrad          enddo
2187 cgrad        enddo
2188 cgrad      enddo
2189       return
2190       end
2191 c------------------------------------------------------------------------------
2192       subroutine vec_and_deriv
2193       implicit real*8 (a-h,o-z)
2194       include 'DIMENSIONS'
2195 #ifdef MPI
2196       include 'mpif.h'
2197 #endif
2198       include 'COMMON.IOUNITS'
2199       include 'COMMON.GEO'
2200       include 'COMMON.VAR'
2201       include 'COMMON.LOCAL'
2202       include 'COMMON.CHAIN'
2203       include 'COMMON.VECTORS'
2204       include 'COMMON.SETUP'
2205       include 'COMMON.TIME1'
2206       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2207 C Compute the local reference systems. For reference system (i), the
2208 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2209 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2210 #ifdef PARVEC
2211       do i=ivec_start,ivec_end
2212 #else
2213       do i=1,nres-1
2214 #endif
2215           if (i.eq.nres-1) then
2216 C Case of the last full residue
2217 C Compute the Z-axis
2218             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2219             costh=dcos(pi-theta(nres))
2220             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2221             do k=1,3
2222               uz(k,i)=fac*uz(k,i)
2223             enddo
2224 C Compute the derivatives of uz
2225             uzder(1,1,1)= 0.0d0
2226             uzder(2,1,1)=-dc_norm(3,i-1)
2227             uzder(3,1,1)= dc_norm(2,i-1)
2228             uzder(1,2,1)= dc_norm(3,i-1)
2229             uzder(2,2,1)= 0.0d0
2230             uzder(3,2,1)=-dc_norm(1,i-1)
2231             uzder(1,3,1)=-dc_norm(2,i-1)
2232             uzder(2,3,1)= dc_norm(1,i-1)
2233             uzder(3,3,1)= 0.0d0
2234             uzder(1,1,2)= 0.0d0
2235             uzder(2,1,2)= dc_norm(3,i)
2236             uzder(3,1,2)=-dc_norm(2,i)
2237             uzder(1,2,2)=-dc_norm(3,i)
2238             uzder(2,2,2)= 0.0d0
2239             uzder(3,2,2)= dc_norm(1,i)
2240             uzder(1,3,2)= dc_norm(2,i)
2241             uzder(2,3,2)=-dc_norm(1,i)
2242             uzder(3,3,2)= 0.0d0
2243 C Compute the Y-axis
2244             facy=fac
2245             do k=1,3
2246               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2247             enddo
2248 C Compute the derivatives of uy
2249             do j=1,3
2250               do k=1,3
2251                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2252      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2253                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2254               enddo
2255               uyder(j,j,1)=uyder(j,j,1)-costh
2256               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2257             enddo
2258             do j=1,2
2259               do k=1,3
2260                 do l=1,3
2261                   uygrad(l,k,j,i)=uyder(l,k,j)
2262                   uzgrad(l,k,j,i)=uzder(l,k,j)
2263                 enddo
2264               enddo
2265             enddo
2266             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2267             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2268             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2269             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2270           else
2271 C Other residues
2272 C Compute the Z-axis
2273             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2274             costh=dcos(pi-theta(i+2))
2275             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2276             do k=1,3
2277               uz(k,i)=fac*uz(k,i)
2278             enddo
2279 C Compute the derivatives of uz
2280             uzder(1,1,1)= 0.0d0
2281             uzder(2,1,1)=-dc_norm(3,i+1)
2282             uzder(3,1,1)= dc_norm(2,i+1)
2283             uzder(1,2,1)= dc_norm(3,i+1)
2284             uzder(2,2,1)= 0.0d0
2285             uzder(3,2,1)=-dc_norm(1,i+1)
2286             uzder(1,3,1)=-dc_norm(2,i+1)
2287             uzder(2,3,1)= dc_norm(1,i+1)
2288             uzder(3,3,1)= 0.0d0
2289             uzder(1,1,2)= 0.0d0
2290             uzder(2,1,2)= dc_norm(3,i)
2291             uzder(3,1,2)=-dc_norm(2,i)
2292             uzder(1,2,2)=-dc_norm(3,i)
2293             uzder(2,2,2)= 0.0d0
2294             uzder(3,2,2)= dc_norm(1,i)
2295             uzder(1,3,2)= dc_norm(2,i)
2296             uzder(2,3,2)=-dc_norm(1,i)
2297             uzder(3,3,2)= 0.0d0
2298 C Compute the Y-axis
2299             facy=fac
2300             do k=1,3
2301               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2302             enddo
2303 C Compute the derivatives of uy
2304             do j=1,3
2305               do k=1,3
2306                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2307      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2308                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2309               enddo
2310               uyder(j,j,1)=uyder(j,j,1)-costh
2311               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2312             enddo
2313             do j=1,2
2314               do k=1,3
2315                 do l=1,3
2316                   uygrad(l,k,j,i)=uyder(l,k,j)
2317                   uzgrad(l,k,j,i)=uzder(l,k,j)
2318                 enddo
2319               enddo
2320             enddo
2321             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2322             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2323             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2324             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2325           endif
2326       enddo
2327       do i=1,nres-1
2328         vbld_inv_temp(1)=vbld_inv(i+1)
2329         if (i.lt.nres-1) then
2330           vbld_inv_temp(2)=vbld_inv(i+2)
2331           else
2332           vbld_inv_temp(2)=vbld_inv(i)
2333           endif
2334         do j=1,2
2335           do k=1,3
2336             do l=1,3
2337               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2338               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2339             enddo
2340           enddo
2341         enddo
2342       enddo
2343 #if defined(PARVEC) && defined(MPI)
2344       if (nfgtasks1.gt.1) then
2345         time00=MPI_Wtime()
2346 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2347 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2348 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2349         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2350      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2351      &   FG_COMM1,IERR)
2352         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2353      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2354      &   FG_COMM1,IERR)
2355         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2356      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2357      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2358         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2359      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2360      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2361         time_gather=time_gather+MPI_Wtime()-time00
2362       endif
2363 c      if (fg_rank.eq.0) then
2364 c        write (iout,*) "Arrays UY and UZ"
2365 c        do i=1,nres-1
2366 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2367 c     &     (uz(k,i),k=1,3)
2368 c        enddo
2369 c      endif
2370 #endif
2371       return
2372       end
2373 C-----------------------------------------------------------------------------
2374       subroutine check_vecgrad
2375       implicit real*8 (a-h,o-z)
2376       include 'DIMENSIONS'
2377       include 'COMMON.IOUNITS'
2378       include 'COMMON.GEO'
2379       include 'COMMON.VAR'
2380       include 'COMMON.LOCAL'
2381       include 'COMMON.CHAIN'
2382       include 'COMMON.VECTORS'
2383       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2384       dimension uyt(3,maxres),uzt(3,maxres)
2385       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2386       double precision delta /1.0d-7/
2387       call vec_and_deriv
2388 cd      do i=1,nres
2389 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2390 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2391 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2392 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2393 cd     &     (dc_norm(if90,i),if90=1,3)
2394 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2395 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2396 cd          write(iout,'(a)')
2397 cd      enddo
2398       do i=1,nres
2399         do j=1,2
2400           do k=1,3
2401             do l=1,3
2402               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2403               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2404             enddo
2405           enddo
2406         enddo
2407       enddo
2408       call vec_and_deriv
2409       do i=1,nres
2410         do j=1,3
2411           uyt(j,i)=uy(j,i)
2412           uzt(j,i)=uz(j,i)
2413         enddo
2414       enddo
2415       do i=1,nres
2416 cd        write (iout,*) 'i=',i
2417         do k=1,3
2418           erij(k)=dc_norm(k,i)
2419         enddo
2420         do j=1,3
2421           do k=1,3
2422             dc_norm(k,i)=erij(k)
2423           enddo
2424           dc_norm(j,i)=dc_norm(j,i)+delta
2425 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2426 c          do k=1,3
2427 c            dc_norm(k,i)=dc_norm(k,i)/fac
2428 c          enddo
2429 c          write (iout,*) (dc_norm(k,i),k=1,3)
2430 c          write (iout,*) (erij(k),k=1,3)
2431           call vec_and_deriv
2432           do k=1,3
2433             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2434             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2435             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2436             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2437           enddo
2438 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2439 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2440 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2441         enddo
2442         do k=1,3
2443           dc_norm(k,i)=erij(k)
2444         enddo
2445 cd        do k=1,3
2446 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2447 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2448 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2449 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2451 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2452 cd          write (iout,'(a)')
2453 cd        enddo
2454       enddo
2455       return
2456       end
2457 C--------------------------------------------------------------------------
2458       subroutine set_matrices
2459       implicit real*8 (a-h,o-z)
2460       include 'DIMENSIONS'
2461 #ifdef MPI
2462       include "mpif.h"
2463       include "COMMON.SETUP"
2464       integer IERR
2465       integer status(MPI_STATUS_SIZE)
2466 #endif
2467       include 'COMMON.IOUNITS'
2468       include 'COMMON.GEO'
2469       include 'COMMON.VAR'
2470       include 'COMMON.LOCAL'
2471       include 'COMMON.CHAIN'
2472       include 'COMMON.DERIV'
2473       include 'COMMON.INTERACT'
2474       include 'COMMON.CONTACTS'
2475       include 'COMMON.TORSION'
2476       include 'COMMON.VECTORS'
2477       include 'COMMON.FFIELD'
2478       double precision auxvec(2),auxmat(2,2)
2479 C
2480 C Compute the virtual-bond-torsional-angle dependent quantities needed
2481 C to calculate the el-loc multibody terms of various order.
2482 C
2483 #ifdef PARMAT
2484       do i=ivec_start+2,ivec_end+2
2485 #else
2486       do i=3,nres+1
2487 #endif
2488         if (i .lt. nres+1) then
2489           sin1=dsin(phi(i))
2490           cos1=dcos(phi(i))
2491           sintab(i-2)=sin1
2492           costab(i-2)=cos1
2493           obrot(1,i-2)=cos1
2494           obrot(2,i-2)=sin1
2495           sin2=dsin(2*phi(i))
2496           cos2=dcos(2*phi(i))
2497           sintab2(i-2)=sin2
2498           costab2(i-2)=cos2
2499           obrot2(1,i-2)=cos2
2500           obrot2(2,i-2)=sin2
2501           Ug(1,1,i-2)=-cos1
2502           Ug(1,2,i-2)=-sin1
2503           Ug(2,1,i-2)=-sin1
2504           Ug(2,2,i-2)= cos1
2505           Ug2(1,1,i-2)=-cos2
2506           Ug2(1,2,i-2)=-sin2
2507           Ug2(2,1,i-2)=-sin2
2508           Ug2(2,2,i-2)= cos2
2509         else
2510           costab(i-2)=1.0d0
2511           sintab(i-2)=0.0d0
2512           obrot(1,i-2)=1.0d0
2513           obrot(2,i-2)=0.0d0
2514           obrot2(1,i-2)=0.0d0
2515           obrot2(2,i-2)=0.0d0
2516           Ug(1,1,i-2)=1.0d0
2517           Ug(1,2,i-2)=0.0d0
2518           Ug(2,1,i-2)=0.0d0
2519           Ug(2,2,i-2)=1.0d0
2520           Ug2(1,1,i-2)=0.0d0
2521           Ug2(1,2,i-2)=0.0d0
2522           Ug2(2,1,i-2)=0.0d0
2523           Ug2(2,2,i-2)=0.0d0
2524         endif
2525         if (i .gt. 3 .and. i .lt. nres+1) then
2526           obrot_der(1,i-2)=-sin1
2527           obrot_der(2,i-2)= cos1
2528           Ugder(1,1,i-2)= sin1
2529           Ugder(1,2,i-2)=-cos1
2530           Ugder(2,1,i-2)=-cos1
2531           Ugder(2,2,i-2)=-sin1
2532           dwacos2=cos2+cos2
2533           dwasin2=sin2+sin2
2534           obrot2_der(1,i-2)=-dwasin2
2535           obrot2_der(2,i-2)= dwacos2
2536           Ug2der(1,1,i-2)= dwasin2
2537           Ug2der(1,2,i-2)=-dwacos2
2538           Ug2der(2,1,i-2)=-dwacos2
2539           Ug2der(2,2,i-2)=-dwasin2
2540         else
2541           obrot_der(1,i-2)=0.0d0
2542           obrot_der(2,i-2)=0.0d0
2543           Ugder(1,1,i-2)=0.0d0
2544           Ugder(1,2,i-2)=0.0d0
2545           Ugder(2,1,i-2)=0.0d0
2546           Ugder(2,2,i-2)=0.0d0
2547           obrot2_der(1,i-2)=0.0d0
2548           obrot2_der(2,i-2)=0.0d0
2549           Ug2der(1,1,i-2)=0.0d0
2550           Ug2der(1,2,i-2)=0.0d0
2551           Ug2der(2,1,i-2)=0.0d0
2552           Ug2der(2,2,i-2)=0.0d0
2553         endif
2554 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2555         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2556           iti = itortyp(itype(i-2))
2557         else
2558           iti=ntortyp+1
2559         endif
2560 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2561         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2562           iti1 = itortyp(itype(i-1))
2563         else
2564           iti1=ntortyp+1
2565         endif
2566 cd        write (iout,*) '*******i',i,' iti1',iti
2567 cd        write (iout,*) 'b1',b1(:,iti)
2568 cd        write (iout,*) 'b2',b2(:,iti)
2569 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2570 c        if (i .gt. iatel_s+2) then
2571         if (i .gt. nnt+2) then
2572           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2573           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2574           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2575      &    then
2576           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2577           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2578           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2579           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2580           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2581           endif
2582         else
2583           do k=1,2
2584             Ub2(k,i-2)=0.0d0
2585             Ctobr(k,i-2)=0.0d0
2586             Dtobr2(k,i-2)=0.0d0
2587             do l=1,2
2588               EUg(l,k,i-2)=0.0d0
2589               CUg(l,k,i-2)=0.0d0
2590               DUg(l,k,i-2)=0.0d0
2591               DtUg2(l,k,i-2)=0.0d0
2592             enddo
2593           enddo
2594         endif
2595         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2596         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2597         do k=1,2
2598           muder(k,i-2)=Ub2der(k,i-2)
2599         enddo
2600 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2601         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2602           iti1 = itortyp(itype(i-1))
2603         else
2604           iti1=ntortyp+1
2605         endif
2606         do k=1,2
2607           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2608         enddo
2609 cd        write (iout,*) 'mu ',mu(:,i-2)
2610 cd        write (iout,*) 'mu1',mu1(:,i-2)
2611 cd        write (iout,*) 'mu2',mu2(:,i-2)
2612         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2613      &  then
2614         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2615         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2616         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2617         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2618         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2619 C Vectors and matrices dependent on a single virtual-bond dihedral.
2620         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2621         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2622         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2623         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2624         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2625         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2626         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2627         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2628         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2629         endif
2630       enddo
2631 C Matrices dependent on two consecutive virtual-bond dihedrals.
2632 C The order of matrices is from left to right.
2633       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2634      &then
2635 c      do i=max0(ivec_start,2),ivec_end
2636       do i=2,nres-1
2637         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2638         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2639         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2640         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2641         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2642         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2643         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2644         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2645       enddo
2646       endif
2647 #if defined(MPI) && defined(PARMAT)
2648 #ifdef DEBUG
2649 c      if (fg_rank.eq.0) then
2650         write (iout,*) "Arrays UG and UGDER before GATHER"
2651         do i=1,nres-1
2652           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2653      &     ((ug(l,k,i),l=1,2),k=1,2),
2654      &     ((ugder(l,k,i),l=1,2),k=1,2)
2655         enddo
2656         write (iout,*) "Arrays UG2 and UG2DER"
2657         do i=1,nres-1
2658           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2659      &     ((ug2(l,k,i),l=1,2),k=1,2),
2660      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2661         enddo
2662         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2663         do i=1,nres-1
2664           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2665      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2666      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2667         enddo
2668         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2669         do i=1,nres-1
2670           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2671      &     costab(i),sintab(i),costab2(i),sintab2(i)
2672         enddo
2673         write (iout,*) "Array MUDER"
2674         do i=1,nres-1
2675           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2676         enddo
2677 c      endif
2678 #endif
2679       if (nfgtasks.gt.1) then
2680         time00=MPI_Wtime()
2681 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2682 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2683 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2684 #ifdef MATGATHER
2685         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2689      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2690      &   FG_COMM1,IERR)
2691         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2692      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2693      &   FG_COMM1,IERR)
2694         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2704      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2705      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2706         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2707      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2708      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2709         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2710      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2711      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2712         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2713      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2714      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2715         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2716      &  then
2717         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2718      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2719      &   FG_COMM1,IERR)
2720         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2721      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2722      &   FG_COMM1,IERR)
2723         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2724      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2725      &   FG_COMM1,IERR)
2726        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2733      &   ivec_count(fg_rank1),
2734      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2758      &   ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2769      &   FG_COMM1,IERR)
2770        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2774      &   ivec_count(fg_rank1),
2775      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2778      &   ivec_count(fg_rank1),
2779      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2782      &   ivec_count(fg_rank1),
2783      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2784      &   MPI_MAT2,FG_COMM1,IERR)
2785         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2786      &   ivec_count(fg_rank1),
2787      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2788      &   MPI_MAT2,FG_COMM1,IERR)
2789         endif
2790 #else
2791 c Passes matrix info through the ring
2792       isend=fg_rank1
2793       irecv=fg_rank1-1
2794       if (irecv.lt.0) irecv=nfgtasks1-1
2795       iprev=irecv
2796       inext=fg_rank1+1
2797       if (inext.ge.nfgtasks1) inext=0
2798       do i=1,nfgtasks1-1
2799 c        write (iout,*) "isend",isend," irecv",irecv
2800 c        call flush(iout)
2801         lensend=lentyp(isend)
2802         lenrecv=lentyp(irecv)
2803 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2804 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2805 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2806 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2807 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2808 c        write (iout,*) "Gather ROTAT1"
2809 c        call flush(iout)
2810 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2811 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2812 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2813 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather ROTAT2"
2815 c        call flush(iout)
2816         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2817      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2818      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2819      &   iprev,4400+irecv,FG_COMM,status,IERR)
2820 c        write (iout,*) "Gather ROTAT_OLD"
2821 c        call flush(iout)
2822         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2823      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2824      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2825      &   iprev,5500+irecv,FG_COMM,status,IERR)
2826 c        write (iout,*) "Gather PRECOMP11"
2827 c        call flush(iout)
2828         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2829      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2830      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2831      &   iprev,6600+irecv,FG_COMM,status,IERR)
2832 c        write (iout,*) "Gather PRECOMP12"
2833 c        call flush(iout)
2834         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2835      &  then
2836         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2837      &   MPI_ROTAT2(lensend),inext,7700+isend,
2838      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2839      &   iprev,7700+irecv,FG_COMM,status,IERR)
2840 c        write (iout,*) "Gather PRECOMP21"
2841 c        call flush(iout)
2842         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2843      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2844      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2845      &   iprev,8800+irecv,FG_COMM,status,IERR)
2846 c        write (iout,*) "Gather PRECOMP22"
2847 c        call flush(iout)
2848         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2849      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2850      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2851      &   MPI_PRECOMP23(lenrecv),
2852      &   iprev,9900+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather PRECOMP23"
2854 c        call flush(iout)
2855         endif
2856         isend=irecv
2857         irecv=irecv-1
2858         if (irecv.lt.0) irecv=nfgtasks1-1
2859       enddo
2860 #endif
2861         time_gather=time_gather+MPI_Wtime()-time00
2862       endif
2863 #ifdef DEBUG
2864 c      if (fg_rank.eq.0) then
2865         write (iout,*) "Arrays UG and UGDER"
2866         do i=1,nres-1
2867           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2868      &     ((ug(l,k,i),l=1,2),k=1,2),
2869      &     ((ugder(l,k,i),l=1,2),k=1,2)
2870         enddo
2871         write (iout,*) "Arrays UG2 and UG2DER"
2872         do i=1,nres-1
2873           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2874      &     ((ug2(l,k,i),l=1,2),k=1,2),
2875      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2876         enddo
2877         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2878         do i=1,nres-1
2879           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2880      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2881      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2882         enddo
2883         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2884         do i=1,nres-1
2885           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2886      &     costab(i),sintab(i),costab2(i),sintab2(i)
2887         enddo
2888         write (iout,*) "Array MUDER"
2889         do i=1,nres-1
2890           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2891         enddo
2892 c      endif
2893 #endif
2894 #endif
2895 cd      do i=1,nres
2896 cd        iti = itortyp(itype(i))
2897 cd        write (iout,*) i
2898 cd        do j=1,2
2899 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2900 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2901 cd        enddo
2902 cd      enddo
2903       return
2904       end
2905 C--------------------------------------------------------------------------
2906       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2907 C
2908 C This subroutine calculates the average interaction energy and its gradient
2909 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2910 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2911 C The potential depends both on the distance of peptide-group centers and on
2912 C the orientation of the CA-CA virtual bonds.
2913 C
2914       implicit real*8 (a-h,o-z)
2915 #ifdef MPI
2916       include 'mpif.h'
2917 #endif
2918       include 'DIMENSIONS'
2919       include 'COMMON.CONTROL'
2920       include 'COMMON.SETUP'
2921       include 'COMMON.IOUNITS'
2922       include 'COMMON.GEO'
2923       include 'COMMON.VAR'
2924       include 'COMMON.LOCAL'
2925       include 'COMMON.CHAIN'
2926       include 'COMMON.DERIV'
2927       include 'COMMON.INTERACT'
2928       include 'COMMON.CONTACTS'
2929       include 'COMMON.TORSION'
2930       include 'COMMON.VECTORS'
2931       include 'COMMON.FFIELD'
2932       include 'COMMON.TIME1'
2933       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2934      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2935       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2936      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2937       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2938      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2939      &    num_conti,j1,j2
2940 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2941 #ifdef MOMENT
2942       double precision scal_el /1.0d0/
2943 #else
2944       double precision scal_el /0.5d0/
2945 #endif
2946 C 12/13/98
2947 C 13-go grudnia roku pamietnego...
2948       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2949      &                   0.0d0,1.0d0,0.0d0,
2950      &                   0.0d0,0.0d0,1.0d0/
2951 cd      write(iout,*) 'In EELEC'
2952 cd      do i=1,nloctyp
2953 cd        write(iout,*) 'Type',i
2954 cd        write(iout,*) 'B1',B1(:,i)
2955 cd        write(iout,*) 'B2',B2(:,i)
2956 cd        write(iout,*) 'CC',CC(:,:,i)
2957 cd        write(iout,*) 'DD',DD(:,:,i)
2958 cd        write(iout,*) 'EE',EE(:,:,i)
2959 cd      enddo
2960 cd      call check_vecgrad
2961 cd      stop
2962       if (icheckgrad.eq.1) then
2963         do i=1,nres-1
2964           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2965           do k=1,3
2966             dc_norm(k,i)=dc(k,i)*fac
2967           enddo
2968 c          write (iout,*) 'i',i,' fac',fac
2969         enddo
2970       endif
2971       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2972      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2973      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2974 c        call vec_and_deriv
2975 #ifdef TIMING
2976         time01=MPI_Wtime()
2977 #endif
2978         call set_matrices
2979 #ifdef TIMING
2980         time_mat=time_mat+MPI_Wtime()-time01
2981 #endif
2982       endif
2983 cd      do i=1,nres-1
2984 cd        write (iout,*) 'i=',i
2985 cd        do k=1,3
2986 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2987 cd        enddo
2988 cd        do k=1,3
2989 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2990 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2991 cd        enddo
2992 cd      enddo
2993       t_eelecij=0.0d0
2994       ees=0.0D0
2995       evdw1=0.0D0
2996       eel_loc=0.0d0
2997       eello_turn3=0.0d0
2998       eello_turn4=0.0d0
2999       ind=0
3000       do i=1,nres
3001         num_cont_hb(i)=0
3002       enddo
3003 cd      print '(a)','Enter EELEC'
3004 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3005       do i=1,nres
3006         gel_loc_loc(i)=0.0d0
3007         gcorr_loc(i)=0.0d0
3008       enddo
3009 c
3010 c
3011 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3012 C
3013 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3014 C
3015       do i=iturn3_start,iturn3_end
3016         dxi=dc(1,i)
3017         dyi=dc(2,i)
3018         dzi=dc(3,i)
3019         dx_normi=dc_norm(1,i)
3020         dy_normi=dc_norm(2,i)
3021         dz_normi=dc_norm(3,i)
3022         xmedi=c(1,i)+0.5d0*dxi
3023         ymedi=c(2,i)+0.5d0*dyi
3024         zmedi=c(3,i)+0.5d0*dzi
3025         num_conti=0
3026         call eelecij(i,i+2,ees,evdw1,eel_loc)
3027         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3028         num_cont_hb(i)=num_conti
3029       enddo
3030       do i=iturn4_start,iturn4_end
3031         dxi=dc(1,i)
3032         dyi=dc(2,i)
3033         dzi=dc(3,i)
3034         dx_normi=dc_norm(1,i)
3035         dy_normi=dc_norm(2,i)
3036         dz_normi=dc_norm(3,i)
3037         xmedi=c(1,i)+0.5d0*dxi
3038         ymedi=c(2,i)+0.5d0*dyi
3039         zmedi=c(3,i)+0.5d0*dzi
3040         num_conti=num_cont_hb(i)
3041         call eelecij(i,i+3,ees,evdw1,eel_loc)
3042         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3043         num_cont_hb(i)=num_conti
3044       enddo   ! i
3045 c
3046 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3047 c
3048       do i=iatel_s,iatel_e
3049         dxi=dc(1,i)
3050         dyi=dc(2,i)
3051         dzi=dc(3,i)
3052         dx_normi=dc_norm(1,i)
3053         dy_normi=dc_norm(2,i)
3054         dz_normi=dc_norm(3,i)
3055         xmedi=c(1,i)+0.5d0*dxi
3056         ymedi=c(2,i)+0.5d0*dyi
3057         zmedi=c(3,i)+0.5d0*dzi
3058 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3059         num_conti=num_cont_hb(i)
3060         do j=ielstart(i),ielend(i)
3061           call eelecij(i,j,ees,evdw1,eel_loc)
3062         enddo ! j
3063         num_cont_hb(i)=num_conti
3064       enddo   ! i
3065 c      write (iout,*) "Number of loop steps in EELEC:",ind
3066 cd      do i=1,nres
3067 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3068 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3069 cd      enddo
3070 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3071 ccc      eel_loc=eel_loc+eello_turn3
3072 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3073       return
3074       end
3075 C-------------------------------------------------------------------------------
3076       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3077       implicit real*8 (a-h,o-z)
3078       include 'DIMENSIONS'
3079 #ifdef MPI
3080       include "mpif.h"
3081 #endif
3082       include 'COMMON.CONTROL'
3083       include 'COMMON.IOUNITS'
3084       include 'COMMON.GEO'
3085       include 'COMMON.VAR'
3086       include 'COMMON.LOCAL'
3087       include 'COMMON.CHAIN'
3088       include 'COMMON.DERIV'
3089       include 'COMMON.INTERACT'
3090       include 'COMMON.CONTACTS'
3091       include 'COMMON.TORSION'
3092       include 'COMMON.VECTORS'
3093       include 'COMMON.FFIELD'
3094       include 'COMMON.TIME1'
3095       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3096      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3097       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3098      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3099       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3100      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3101      &    num_conti,j1,j2
3102 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3103 #ifdef MOMENT
3104       double precision scal_el /1.0d0/
3105 #else
3106       double precision scal_el /0.5d0/
3107 #endif
3108 C 12/13/98
3109 C 13-go grudnia roku pamietnego...
3110       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3111      &                   0.0d0,1.0d0,0.0d0,
3112      &                   0.0d0,0.0d0,1.0d0/
3113 c          time00=MPI_Wtime()
3114 cd      write (iout,*) "eelecij",i,j
3115 c          ind=ind+1
3116           iteli=itel(i)
3117           itelj=itel(j)
3118           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3119           aaa=app(iteli,itelj)
3120           bbb=bpp(iteli,itelj)
3121           ael6i=ael6(iteli,itelj)
3122           ael3i=ael3(iteli,itelj)
3123           dxj=dc(1,j)
3124           dyj=dc(2,j)
3125           dzj=dc(3,j)
3126           dx_normj=dc_norm(1,j)
3127           dy_normj=dc_norm(2,j)
3128           dz_normj=dc_norm(3,j)
3129           xj=c(1,j)+0.5D0*dxj-xmedi
3130           yj=c(2,j)+0.5D0*dyj-ymedi
3131           zj=c(3,j)+0.5D0*dzj-zmedi
3132           rij=xj*xj+yj*yj+zj*zj
3133           rrmij=1.0D0/rij
3134           rij=dsqrt(rij)
3135           rmij=1.0D0/rij
3136           r3ij=rrmij*rmij
3137           r6ij=r3ij*r3ij
3138           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3139           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3140           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3141           fac=cosa-3.0D0*cosb*cosg
3142           ev1=aaa*r6ij*r6ij
3143 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3144           if (j.eq.i+2) ev1=scal_el*ev1
3145           ev2=bbb*r6ij
3146           fac3=ael6i*r6ij
3147           fac4=ael3i*r3ij
3148           evdwij=ev1+ev2
3149           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3150           el2=fac4*fac
3151           eesij=el1+el2
3152 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3153           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3154           ees=ees+eesij
3155           evdw1=evdw1+evdwij
3156 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3157 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3158 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3159 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3160
3161           if (energy_dec) then
3162               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3163               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3164           endif
3165
3166 C
3167 C Calculate contributions to the Cartesian gradient.
3168 C
3169 #ifdef SPLITELE
3170           facvdw=-6*rrmij*(ev1+evdwij)
3171           facel=-3*rrmij*(el1+eesij)
3172           fac1=fac
3173           erij(1)=xj*rmij
3174           erij(2)=yj*rmij
3175           erij(3)=zj*rmij
3176 *
3177 * Radial derivatives. First process both termini of the fragment (i,j)
3178 *
3179           ggg(1)=facel*xj
3180           ggg(2)=facel*yj
3181           ggg(3)=facel*zj
3182 c          do k=1,3
3183 c            ghalf=0.5D0*ggg(k)
3184 c            gelc(k,i)=gelc(k,i)+ghalf
3185 c            gelc(k,j)=gelc(k,j)+ghalf
3186 c          enddo
3187 c 9/28/08 AL Gradient compotents will be summed only at the end
3188           do k=1,3
3189             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3190             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3191           enddo
3192 *
3193 * Loop over residues i+1 thru j-1.
3194 *
3195 cgrad          do k=i+1,j-1
3196 cgrad            do l=1,3
3197 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3198 cgrad            enddo
3199 cgrad          enddo
3200           ggg(1)=facvdw*xj
3201           ggg(2)=facvdw*yj
3202           ggg(3)=facvdw*zj
3203 c          do k=1,3
3204 c            ghalf=0.5D0*ggg(k)
3205 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3206 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3207 c          enddo
3208 c 9/28/08 AL Gradient compotents will be summed only at the end
3209           do k=1,3
3210             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3211             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3212           enddo
3213 *
3214 * Loop over residues i+1 thru j-1.
3215 *
3216 cgrad          do k=i+1,j-1
3217 cgrad            do l=1,3
3218 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3219 cgrad            enddo
3220 cgrad          enddo
3221 #else
3222           facvdw=ev1+evdwij
3223           facel=el1+eesij
3224           fac1=fac
3225           fac=-3*rrmij*(facvdw+facvdw+facel)
3226           erij(1)=xj*rmij
3227           erij(2)=yj*rmij
3228           erij(3)=zj*rmij
3229 *
3230 * Radial derivatives. First process both termini of the fragment (i,j)
3231 *
3232           ggg(1)=fac*xj
3233           ggg(2)=fac*yj
3234           ggg(3)=fac*zj
3235 c          do k=1,3
3236 c            ghalf=0.5D0*ggg(k)
3237 c            gelc(k,i)=gelc(k,i)+ghalf
3238 c            gelc(k,j)=gelc(k,j)+ghalf
3239 c          enddo
3240 c 9/28/08 AL Gradient compotents will be summed only at the end
3241           do k=1,3
3242             gelc_long(k,j)=gelc(k,j)+ggg(k)
3243             gelc_long(k,i)=gelc(k,i)-ggg(k)
3244           enddo
3245 *
3246 * Loop over residues i+1 thru j-1.
3247 *
3248 cgrad          do k=i+1,j-1
3249 cgrad            do l=1,3
3250 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3251 cgrad            enddo
3252 cgrad          enddo
3253 c 9/28/08 AL Gradient compotents will be summed only at the end
3254           ggg(1)=facvdw*xj
3255           ggg(2)=facvdw*yj
3256           ggg(3)=facvdw*zj
3257           do k=1,3
3258             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3259             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3260           enddo
3261 #endif
3262 *
3263 * Angular part
3264 *
3265           ecosa=2.0D0*fac3*fac1+fac4
3266           fac4=-3.0D0*fac4
3267           fac3=-6.0D0*fac3
3268           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3269           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3270           do k=1,3
3271             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3272             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3273           enddo
3274 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3275 cd   &          (dcosg(k),k=1,3)
3276           do k=1,3
3277             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3278           enddo
3279 c          do k=1,3
3280 c            ghalf=0.5D0*ggg(k)
3281 c            gelc(k,i)=gelc(k,i)+ghalf
3282 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3283 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3284 c            gelc(k,j)=gelc(k,j)+ghalf
3285 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3286 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3287 c          enddo
3288 cgrad          do k=i+1,j-1
3289 cgrad            do l=1,3
3290 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3291 cgrad            enddo
3292 cgrad          enddo
3293           do k=1,3
3294             gelc(k,i)=gelc(k,i)
3295      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3296      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3297             gelc(k,j)=gelc(k,j)
3298      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3299      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3300             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3301             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3302           enddo
3303           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3304      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3305      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3306 C
3307 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3308 C   energy of a peptide unit is assumed in the form of a second-order
3309 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3310 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3311 C   are computed for EVERY pair of non-contiguous peptide groups.
3312 C
3313           if (j.lt.nres-1) then
3314             j1=j+1
3315             j2=j-1
3316           else
3317             j1=j-1
3318             j2=j-2
3319           endif
3320           kkk=0
3321           do k=1,2
3322             do l=1,2
3323               kkk=kkk+1
3324               muij(kkk)=mu(k,i)*mu(l,j)
3325             enddo
3326           enddo
3327 cd         write (iout,*) 'EELEC: i',i,' j',j
3328 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3329 cd          write(iout,*) 'muij',muij
3330           ury=scalar(uy(1,i),erij)
3331           urz=scalar(uz(1,i),erij)
3332           vry=scalar(uy(1,j),erij)
3333           vrz=scalar(uz(1,j),erij)
3334           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3335           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3336           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3337           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3338           fac=dsqrt(-ael6i)*r3ij
3339           a22=a22*fac
3340           a23=a23*fac
3341           a32=a32*fac
3342           a33=a33*fac
3343 cd          write (iout,'(4i5,4f10.5)')
3344 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3345 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3346 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3347 cd     &      uy(:,j),uz(:,j)
3348 cd          write (iout,'(4f10.5)')
3349 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3350 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3351 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3352 cd           write (iout,'(9f10.5/)')
3353 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3354 C Derivatives of the elements of A in virtual-bond vectors
3355           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3356           do k=1,3
3357             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3358             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3359             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3360             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3361             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3362             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3363             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3364             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3365             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3366             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3367             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3368             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3369           enddo
3370 C Compute radial contributions to the gradient
3371           facr=-3.0d0*rrmij
3372           a22der=a22*facr
3373           a23der=a23*facr
3374           a32der=a32*facr
3375           a33der=a33*facr
3376           agg(1,1)=a22der*xj
3377           agg(2,1)=a22der*yj
3378           agg(3,1)=a22der*zj
3379           agg(1,2)=a23der*xj
3380           agg(2,2)=a23der*yj
3381           agg(3,2)=a23der*zj
3382           agg(1,3)=a32der*xj
3383           agg(2,3)=a32der*yj
3384           agg(3,3)=a32der*zj
3385           agg(1,4)=a33der*xj
3386           agg(2,4)=a33der*yj
3387           agg(3,4)=a33der*zj
3388 C Add the contributions coming from er
3389           fac3=-3.0d0*fac
3390           do k=1,3
3391             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3392             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3393             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3394             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3395           enddo
3396           do k=1,3
3397 C Derivatives in DC(i)
3398 cgrad            ghalf1=0.5d0*agg(k,1)
3399 cgrad            ghalf2=0.5d0*agg(k,2)
3400 cgrad            ghalf3=0.5d0*agg(k,3)
3401 cgrad            ghalf4=0.5d0*agg(k,4)
3402             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3403      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3404             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3405      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3406             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3407      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3408             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3409      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3410 C Derivatives in DC(i+1)
3411             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3412      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3413             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3414      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3415             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3416      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3417             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3418      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3419 C Derivatives in DC(j)
3420             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3421      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3422             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3423      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3424             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3425      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3426             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3427      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3428 C Derivatives in DC(j+1) or DC(nres-1)
3429             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3430      &      -3.0d0*vryg(k,3)*ury)
3431             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3432      &      -3.0d0*vrzg(k,3)*ury)
3433             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3434      &      -3.0d0*vryg(k,3)*urz)
3435             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3436      &      -3.0d0*vrzg(k,3)*urz)
3437 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3438 cgrad              do l=1,4
3439 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3440 cgrad              enddo
3441 cgrad            endif
3442           enddo
3443           acipa(1,1)=a22
3444           acipa(1,2)=a23
3445           acipa(2,1)=a32
3446           acipa(2,2)=a33
3447           a22=-a22
3448           a23=-a23
3449           do l=1,2
3450             do k=1,3
3451               agg(k,l)=-agg(k,l)
3452               aggi(k,l)=-aggi(k,l)
3453               aggi1(k,l)=-aggi1(k,l)
3454               aggj(k,l)=-aggj(k,l)
3455               aggj1(k,l)=-aggj1(k,l)
3456             enddo
3457           enddo
3458           if (j.lt.nres-1) then
3459             a22=-a22
3460             a32=-a32
3461             do l=1,3,2
3462               do k=1,3
3463                 agg(k,l)=-agg(k,l)
3464                 aggi(k,l)=-aggi(k,l)
3465                 aggi1(k,l)=-aggi1(k,l)
3466                 aggj(k,l)=-aggj(k,l)
3467                 aggj1(k,l)=-aggj1(k,l)
3468               enddo
3469             enddo
3470           else
3471             a22=-a22
3472             a23=-a23
3473             a32=-a32
3474             a33=-a33
3475             do l=1,4
3476               do k=1,3
3477                 agg(k,l)=-agg(k,l)
3478                 aggi(k,l)=-aggi(k,l)
3479                 aggi1(k,l)=-aggi1(k,l)
3480                 aggj(k,l)=-aggj(k,l)
3481                 aggj1(k,l)=-aggj1(k,l)
3482               enddo
3483             enddo
3484           endif
3485           ENDIF ! WCORR
3486           IF (wel_loc.gt.0.0d0) THEN
3487 C Contribution to the local-electrostatic energy coming from the i-j pair
3488           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3489      &     +a33*muij(4)
3490 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3491
3492           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3493      &            'eelloc',i,j,eel_loc_ij
3494
3495           eel_loc=eel_loc+eel_loc_ij
3496 C Partial derivatives in virtual-bond dihedral angles gamma
3497           if (i.gt.1)
3498      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3499      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3500      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3501           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3502      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3503      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3504 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3505           do l=1,3
3506             ggg(l)=agg(l,1)*muij(1)+
3507      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3508             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3509             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3510 cgrad            ghalf=0.5d0*ggg(l)
3511 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3512 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3513           enddo
3514 cgrad          do k=i+1,j2
3515 cgrad            do l=1,3
3516 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3517 cgrad            enddo
3518 cgrad          enddo
3519 C Remaining derivatives of eello
3520           do l=1,3
3521             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3522      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3523             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3524      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3525             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3526      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3527             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3528      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3529           enddo
3530           ENDIF
3531 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3532 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3533           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3534      &       .and. num_conti.le.maxconts) then
3535 c            write (iout,*) i,j," entered corr"
3536 C
3537 C Calculate the contact function. The ith column of the array JCONT will
3538 C contain the numbers of atoms that make contacts with the atom I (of numbers
3539 C greater than I). The arrays FACONT and GACONT will contain the values of
3540 C the contact function and its derivative.
3541 c           r0ij=1.02D0*rpp(iteli,itelj)
3542 c           r0ij=1.11D0*rpp(iteli,itelj)
3543             r0ij=2.20D0*rpp(iteli,itelj)
3544 c           r0ij=1.55D0*rpp(iteli,itelj)
3545             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3546             if (fcont.gt.0.0D0) then
3547               num_conti=num_conti+1
3548               if (num_conti.gt.maxconts) then
3549                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3550      &                         ' will skip next contacts for this conf.'
3551               else
3552                 jcont_hb(num_conti,i)=j
3553 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3554 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3555                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3556      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3557 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3558 C  terms.
3559                 d_cont(num_conti,i)=rij
3560 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3561 C     --- Electrostatic-interaction matrix ---
3562                 a_chuj(1,1,num_conti,i)=a22
3563                 a_chuj(1,2,num_conti,i)=a23
3564                 a_chuj(2,1,num_conti,i)=a32
3565                 a_chuj(2,2,num_conti,i)=a33
3566 C     --- Gradient of rij
3567                 do kkk=1,3
3568                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3569                 enddo
3570                 kkll=0
3571                 do k=1,2
3572                   do l=1,2
3573                     kkll=kkll+1
3574                     do m=1,3
3575                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3576                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3577                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3578                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3579                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3580                     enddo
3581                   enddo
3582                 enddo
3583                 ENDIF
3584                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3585 C Calculate contact energies
3586                 cosa4=4.0D0*cosa
3587                 wij=cosa-3.0D0*cosb*cosg
3588                 cosbg1=cosb+cosg
3589                 cosbg2=cosb-cosg
3590 c               fac3=dsqrt(-ael6i)/r0ij**3
3591                 fac3=dsqrt(-ael6i)*r3ij
3592 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3593                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3594                 if (ees0tmp.gt.0) then
3595                   ees0pij=dsqrt(ees0tmp)
3596                 else
3597                   ees0pij=0
3598                 endif
3599 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3600                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3601                 if (ees0tmp.gt.0) then
3602                   ees0mij=dsqrt(ees0tmp)
3603                 else
3604                   ees0mij=0
3605                 endif
3606 c               ees0mij=0.0D0
3607                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3608                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3609 C Diagnostics. Comment out or remove after debugging!
3610 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3611 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3612 c               ees0m(num_conti,i)=0.0D0
3613 C End diagnostics.
3614 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3615 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3616 C Angular derivatives of the contact function
3617                 ees0pij1=fac3/ees0pij
3618                 ees0mij1=fac3/ees0mij
3619                 fac3p=-3.0D0*fac3*rrmij
3620                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3621                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3622 c               ees0mij1=0.0D0
3623                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3624                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3625                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3626                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3627                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3628                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3629                 ecosap=ecosa1+ecosa2
3630                 ecosbp=ecosb1+ecosb2
3631                 ecosgp=ecosg1+ecosg2
3632                 ecosam=ecosa1-ecosa2
3633                 ecosbm=ecosb1-ecosb2
3634                 ecosgm=ecosg1-ecosg2
3635 C Diagnostics
3636 c               ecosap=ecosa1
3637 c               ecosbp=ecosb1
3638 c               ecosgp=ecosg1
3639 c               ecosam=0.0D0
3640 c               ecosbm=0.0D0
3641 c               ecosgm=0.0D0
3642 C End diagnostics
3643                 facont_hb(num_conti,i)=fcont
3644                 fprimcont=fprimcont/rij
3645 cd              facont_hb(num_conti,i)=1.0D0
3646 C Following line is for diagnostics.
3647 cd              fprimcont=0.0D0
3648                 do k=1,3
3649                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3650                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3651                 enddo
3652                 do k=1,3
3653                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3654                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3655                 enddo
3656                 gggp(1)=gggp(1)+ees0pijp*xj
3657                 gggp(2)=gggp(2)+ees0pijp*yj
3658                 gggp(3)=gggp(3)+ees0pijp*zj
3659                 gggm(1)=gggm(1)+ees0mijp*xj
3660                 gggm(2)=gggm(2)+ees0mijp*yj
3661                 gggm(3)=gggm(3)+ees0mijp*zj
3662 C Derivatives due to the contact function
3663                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3664                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3665                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3666                 do k=1,3
3667 c
3668 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3669 c          following the change of gradient-summation algorithm.
3670 c
3671 cgrad                  ghalfp=0.5D0*gggp(k)
3672 cgrad                  ghalfm=0.5D0*gggm(k)
3673                   gacontp_hb1(k,num_conti,i)=!ghalfp
3674      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3675      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3676                   gacontp_hb2(k,num_conti,i)=!ghalfp
3677      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3678      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3679                   gacontp_hb3(k,num_conti,i)=gggp(k)
3680                   gacontm_hb1(k,num_conti,i)=!ghalfm
3681      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3682      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3683                   gacontm_hb2(k,num_conti,i)=!ghalfm
3684      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3685      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3686                   gacontm_hb3(k,num_conti,i)=gggm(k)
3687                 enddo
3688 C Diagnostics. Comment out or remove after debugging!
3689 cdiag           do k=1,3
3690 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3691 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3692 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3693 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3694 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3695 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3696 cdiag           enddo
3697               ENDIF ! wcorr
3698               endif  ! num_conti.le.maxconts
3699             endif  ! fcont.gt.0
3700           endif    ! j.gt.i+1
3701           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3702             do k=1,4
3703               do l=1,3
3704                 ghalf=0.5d0*agg(l,k)
3705                 aggi(l,k)=aggi(l,k)+ghalf
3706                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3707                 aggj(l,k)=aggj(l,k)+ghalf
3708               enddo
3709             enddo
3710             if (j.eq.nres-1 .and. i.lt.j-2) then
3711               do k=1,4
3712                 do l=1,3
3713                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3714                 enddo
3715               enddo
3716             endif
3717           endif
3718 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3719       return
3720       end
3721 C-----------------------------------------------------------------------------
3722       subroutine eturn3(i,eello_turn3)
3723 C Third- and fourth-order contributions from turns
3724       implicit real*8 (a-h,o-z)
3725       include 'DIMENSIONS'
3726       include 'COMMON.IOUNITS'
3727       include 'COMMON.GEO'
3728       include 'COMMON.VAR'
3729       include 'COMMON.LOCAL'
3730       include 'COMMON.CHAIN'
3731       include 'COMMON.DERIV'
3732       include 'COMMON.INTERACT'
3733       include 'COMMON.CONTACTS'
3734       include 'COMMON.TORSION'
3735       include 'COMMON.VECTORS'
3736       include 'COMMON.FFIELD'
3737       include 'COMMON.CONTROL'
3738       dimension ggg(3)
3739       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3740      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3741      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3742       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3743      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3744       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3745      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3746      &    num_conti,j1,j2
3747       j=i+2
3748 c      write (iout,*) "eturn3",i,j,j1,j2
3749       a_temp(1,1)=a22
3750       a_temp(1,2)=a23
3751       a_temp(2,1)=a32
3752       a_temp(2,2)=a33
3753 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3754 C
3755 C               Third-order contributions
3756 C
3757 C                 (i+2)o----(i+3)
3758 C                      | |
3759 C                      | |
3760 C                 (i+1)o----i
3761 C
3762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3763 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3764         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3765         call transpose2(auxmat(1,1),auxmat1(1,1))
3766         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3767         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3768         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3769      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3770 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3771 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3772 cd     &    ' eello_turn3_num',4*eello_turn3_num
3773 C Derivatives in gamma(i)
3774         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3775         call transpose2(auxmat2(1,1),auxmat3(1,1))
3776         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3777         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3778 C Derivatives in gamma(i+1)
3779         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3780         call transpose2(auxmat2(1,1),auxmat3(1,1))
3781         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3782         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3783      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3784 C Cartesian derivatives
3785         do l=1,3
3786 c            ghalf1=0.5d0*agg(l,1)
3787 c            ghalf2=0.5d0*agg(l,2)
3788 c            ghalf3=0.5d0*agg(l,3)
3789 c            ghalf4=0.5d0*agg(l,4)
3790           a_temp(1,1)=aggi(l,1)!+ghalf1
3791           a_temp(1,2)=aggi(l,2)!+ghalf2
3792           a_temp(2,1)=aggi(l,3)!+ghalf3
3793           a_temp(2,2)=aggi(l,4)!+ghalf4
3794           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3795           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3796      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3797           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3798           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3799           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3800           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3802           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3804           a_temp(1,1)=aggj(l,1)!+ghalf1
3805           a_temp(1,2)=aggj(l,2)!+ghalf2
3806           a_temp(2,1)=aggj(l,3)!+ghalf3
3807           a_temp(2,2)=aggj(l,4)!+ghalf4
3808           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3809           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3810      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3811           a_temp(1,1)=aggj1(l,1)
3812           a_temp(1,2)=aggj1(l,2)
3813           a_temp(2,1)=aggj1(l,3)
3814           a_temp(2,2)=aggj1(l,4)
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818         enddo
3819       return
3820       end
3821 C-------------------------------------------------------------------------------
3822       subroutine eturn4(i,eello_turn4)
3823 C Third- and fourth-order contributions from turns
3824       implicit real*8 (a-h,o-z)
3825       include 'DIMENSIONS'
3826       include 'COMMON.IOUNITS'
3827       include 'COMMON.GEO'
3828       include 'COMMON.VAR'
3829       include 'COMMON.LOCAL'
3830       include 'COMMON.CHAIN'
3831       include 'COMMON.DERIV'
3832       include 'COMMON.INTERACT'
3833       include 'COMMON.CONTACTS'
3834       include 'COMMON.TORSION'
3835       include 'COMMON.VECTORS'
3836       include 'COMMON.FFIELD'
3837       include 'COMMON.CONTROL'
3838       dimension ggg(3)
3839       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3840      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3841      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3842       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3843      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3844       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3845      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3846      &    num_conti,j1,j2
3847       j=i+3
3848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3849 C
3850 C               Fourth-order contributions
3851 C
3852 C                 (i+3)o----(i+4)
3853 C                     /  |
3854 C               (i+2)o   |
3855 C                     \  |
3856 C                 (i+1)o----i
3857 C
3858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3859 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3860 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3861         a_temp(1,1)=a22
3862         a_temp(1,2)=a23
3863         a_temp(2,1)=a32
3864         a_temp(2,2)=a33
3865         iti1=itortyp(itype(i+1))
3866         iti2=itortyp(itype(i+2))
3867         iti3=itortyp(itype(i+3))
3868 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3869         call transpose2(EUg(1,1,i+1),e1t(1,1))
3870         call transpose2(Eug(1,1,i+2),e2t(1,1))
3871         call transpose2(Eug(1,1,i+3),e3t(1,1))
3872         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3873         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3874         s1=scalar2(b1(1,iti2),auxvec(1))
3875         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3876         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3877         s2=scalar2(b1(1,iti1),auxvec(1))
3878         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3879         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3880         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3881         eello_turn4=eello_turn4-(s1+s2+s3)
3882         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3883      &      'eturn4',i,j,-(s1+s2+s3)
3884 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3885 cd     &    ' eello_turn4_num',8*eello_turn4_num
3886 C Derivatives in gamma(i)
3887         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3888         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3889         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3890         s1=scalar2(b1(1,iti2),auxvec(1))
3891         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3892         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3893         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3894 C Derivatives in gamma(i+1)
3895         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3896         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3897         s2=scalar2(b1(1,iti1),auxvec(1))
3898         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3899         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3900         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3901         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3902 C Derivatives in gamma(i+2)
3903         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3904         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3905         s1=scalar2(b1(1,iti2),auxvec(1))
3906         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3907         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3908         s2=scalar2(b1(1,iti1),auxvec(1))
3909         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3910         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3913 C Cartesian derivatives
3914 C Derivatives of this turn contributions in DC(i+2)
3915         if (j.lt.nres-1) then
3916           do l=1,3
3917             a_temp(1,1)=agg(l,1)
3918             a_temp(1,2)=agg(l,2)
3919             a_temp(2,1)=agg(l,3)
3920             a_temp(2,2)=agg(l,4)
3921             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3922             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3923             s1=scalar2(b1(1,iti2),auxvec(1))
3924             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3925             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3926             s2=scalar2(b1(1,iti1),auxvec(1))
3927             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3928             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3929             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3930             ggg(l)=-(s1+s2+s3)
3931             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3932           enddo
3933         endif
3934 C Remaining derivatives of this turn contribution
3935         do l=1,3
3936           a_temp(1,1)=aggi(l,1)
3937           a_temp(1,2)=aggi(l,2)
3938           a_temp(2,1)=aggi(l,3)
3939           a_temp(2,2)=aggi(l,4)
3940           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3941           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3942           s1=scalar2(b1(1,iti2),auxvec(1))
3943           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3944           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3945           s2=scalar2(b1(1,iti1),auxvec(1))
3946           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3947           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3948           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3949           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3950           a_temp(1,1)=aggi1(l,1)
3951           a_temp(1,2)=aggi1(l,2)
3952           a_temp(2,1)=aggi1(l,3)
3953           a_temp(2,2)=aggi1(l,4)
3954           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3955           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3956           s1=scalar2(b1(1,iti2),auxvec(1))
3957           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3958           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3959           s2=scalar2(b1(1,iti1),auxvec(1))
3960           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3961           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3962           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3963           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3964           a_temp(1,1)=aggj(l,1)
3965           a_temp(1,2)=aggj(l,2)
3966           a_temp(2,1)=aggj(l,3)
3967           a_temp(2,2)=aggj(l,4)
3968           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3969           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3970           s1=scalar2(b1(1,iti2),auxvec(1))
3971           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3972           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3973           s2=scalar2(b1(1,iti1),auxvec(1))
3974           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3975           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3976           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3977           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3978           a_temp(1,1)=aggj1(l,1)
3979           a_temp(1,2)=aggj1(l,2)
3980           a_temp(2,1)=aggj1(l,3)
3981           a_temp(2,2)=aggj1(l,4)
3982           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3983           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3984           s1=scalar2(b1(1,iti2),auxvec(1))
3985           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3986           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3987           s2=scalar2(b1(1,iti1),auxvec(1))
3988           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3989           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3990           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3991 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3992           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3993         enddo
3994       return
3995       end
3996 C-----------------------------------------------------------------------------
3997       subroutine vecpr(u,v,w)
3998       implicit real*8(a-h,o-z)
3999       dimension u(3),v(3),w(3)
4000       w(1)=u(2)*v(3)-u(3)*v(2)
4001       w(2)=-u(1)*v(3)+u(3)*v(1)
4002       w(3)=u(1)*v(2)-u(2)*v(1)
4003       return
4004       end
4005 C-----------------------------------------------------------------------------
4006       subroutine unormderiv(u,ugrad,unorm,ungrad)
4007 C This subroutine computes the derivatives of a normalized vector u, given
4008 C the derivatives computed without normalization conditions, ugrad. Returns
4009 C ungrad.
4010       implicit none
4011       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4012       double precision vec(3)
4013       double precision scalar
4014       integer i,j
4015 c      write (2,*) 'ugrad',ugrad
4016 c      write (2,*) 'u',u
4017       do i=1,3
4018         vec(i)=scalar(ugrad(1,i),u(1))
4019       enddo
4020 c      write (2,*) 'vec',vec
4021       do i=1,3
4022         do j=1,3
4023           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4024         enddo
4025       enddo
4026 c      write (2,*) 'ungrad',ungrad
4027       return
4028       end
4029 C-----------------------------------------------------------------------------
4030       subroutine escp_soft_sphere(evdw2,evdw2_14)
4031 C
4032 C This subroutine calculates the excluded-volume interaction energy between
4033 C peptide-group centers and side chains and its gradient in virtual-bond and
4034 C side-chain vectors.
4035 C
4036       implicit real*8 (a-h,o-z)
4037       include 'DIMENSIONS'
4038       include 'COMMON.GEO'
4039       include 'COMMON.VAR'
4040       include 'COMMON.LOCAL'
4041       include 'COMMON.CHAIN'
4042       include 'COMMON.DERIV'
4043       include 'COMMON.INTERACT'
4044       include 'COMMON.FFIELD'
4045       include 'COMMON.IOUNITS'
4046       include 'COMMON.CONTROL'
4047       dimension ggg(3)
4048       evdw2=0.0D0
4049       evdw2_14=0.0d0
4050       r0_scp=4.5d0
4051 cd    print '(a)','Enter ESCP'
4052 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4053       do i=iatscp_s,iatscp_e
4054         iteli=itel(i)
4055         xi=0.5D0*(c(1,i)+c(1,i+1))
4056         yi=0.5D0*(c(2,i)+c(2,i+1))
4057         zi=0.5D0*(c(3,i)+c(3,i+1))
4058
4059         do iint=1,nscp_gr(i)
4060
4061         do j=iscpstart(i,iint),iscpend(i,iint)
4062           itypj=iabs(itype(j))
4063 C Uncomment following three lines for SC-p interactions
4064 c         xj=c(1,nres+j)-xi
4065 c         yj=c(2,nres+j)-yi
4066 c         zj=c(3,nres+j)-zi
4067 C Uncomment following three lines for Ca-p interactions
4068           xj=c(1,j)-xi
4069           yj=c(2,j)-yi
4070           zj=c(3,j)-zi
4071           rij=xj*xj+yj*yj+zj*zj
4072           r0ij=r0_scp
4073           r0ijsq=r0ij*r0ij
4074           if (rij.lt.r0ijsq) then
4075             evdwij=0.25d0*(rij-r0ijsq)**2
4076             fac=rij-r0ijsq
4077           else
4078             evdwij=0.0d0
4079             fac=0.0d0
4080           endif
4081           evdw2=evdw2+evdwij
4082 C
4083 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4084 C
4085           ggg(1)=xj*fac
4086           ggg(2)=yj*fac
4087           ggg(3)=zj*fac
4088 cgrad          if (j.lt.i) then
4089 cd          write (iout,*) 'j<i'
4090 C Uncomment following three lines for SC-p interactions
4091 c           do k=1,3
4092 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4093 c           enddo
4094 cgrad          else
4095 cd          write (iout,*) 'j>i'
4096 cgrad            do k=1,3
4097 cgrad              ggg(k)=-ggg(k)
4098 C Uncomment following line for SC-p interactions
4099 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4100 cgrad            enddo
4101 cgrad          endif
4102 cgrad          do k=1,3
4103 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4104 cgrad          enddo
4105 cgrad          kstart=min0(i+1,j)
4106 cgrad          kend=max0(i-1,j-1)
4107 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4108 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4109 cgrad          do k=kstart,kend
4110 cgrad            do l=1,3
4111 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4112 cgrad            enddo
4113 cgrad          enddo
4114           do k=1,3
4115             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4116             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4117           enddo
4118         enddo
4119
4120         enddo ! iint
4121       enddo ! i
4122       return
4123       end
4124 C-----------------------------------------------------------------------------
4125       subroutine escp(evdw2,evdw2_14)
4126 C
4127 C This subroutine calculates the excluded-volume interaction energy between
4128 C peptide-group centers and side chains and its gradient in virtual-bond and
4129 C side-chain vectors.
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.GEO'
4134       include 'COMMON.VAR'
4135       include 'COMMON.LOCAL'
4136       include 'COMMON.CHAIN'
4137       include 'COMMON.DERIV'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.FFIELD'
4140       include 'COMMON.IOUNITS'
4141       include 'COMMON.CONTROL'
4142       dimension ggg(3)
4143       evdw2=0.0D0
4144       evdw2_14=0.0d0
4145 cd    print '(a)','Enter ESCP'
4146 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4147       do i=iatscp_s,iatscp_e
4148         iteli=itel(i)
4149         xi=0.5D0*(c(1,i)+c(1,i+1))
4150         yi=0.5D0*(c(2,i)+c(2,i+1))
4151         zi=0.5D0*(c(3,i)+c(3,i+1))
4152
4153         do iint=1,nscp_gr(i)
4154
4155         do j=iscpstart(i,iint),iscpend(i,iint)
4156           itypj=iabs(itype(j))
4157 C Uncomment following three lines for SC-p interactions
4158 c         xj=c(1,nres+j)-xi
4159 c         yj=c(2,nres+j)-yi
4160 c         zj=c(3,nres+j)-zi
4161 C Uncomment following three lines for Ca-p interactions
4162           xj=c(1,j)-xi
4163           yj=c(2,j)-yi
4164           zj=c(3,j)-zi
4165           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4166           fac=rrij**expon2
4167           e1=fac*fac*aad(itypj,iteli)
4168           e2=fac*bad(itypj,iteli)
4169           if (iabs(j-i) .le. 2) then
4170             e1=scal14*e1
4171             e2=scal14*e2
4172             evdw2_14=evdw2_14+e1+e2
4173           endif
4174           evdwij=e1+e2
4175           evdw2=evdw2+evdwij
4176           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4177      &        'evdw2',i,j,evdwij
4178 C
4179 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4180 C
4181           fac=-(evdwij+e1)*rrij
4182           ggg(1)=xj*fac
4183           ggg(2)=yj*fac
4184           ggg(3)=zj*fac
4185 cgrad          if (j.lt.i) then
4186 cd          write (iout,*) 'j<i'
4187 C Uncomment following three lines for SC-p interactions
4188 c           do k=1,3
4189 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4190 c           enddo
4191 cgrad          else
4192 cd          write (iout,*) 'j>i'
4193 cgrad            do k=1,3
4194 cgrad              ggg(k)=-ggg(k)
4195 C Uncomment following line for SC-p interactions
4196 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4197 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4198 cgrad            enddo
4199 cgrad          endif
4200 cgrad          do k=1,3
4201 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4202 cgrad          enddo
4203 cgrad          kstart=min0(i+1,j)
4204 cgrad          kend=max0(i-1,j-1)
4205 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4206 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4207 cgrad          do k=kstart,kend
4208 cgrad            do l=1,3
4209 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4210 cgrad            enddo
4211 cgrad          enddo
4212           do k=1,3
4213             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4214             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4215           enddo
4216         enddo
4217
4218         enddo ! iint
4219       enddo ! i
4220       do i=1,nct
4221         do j=1,3
4222           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4223           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4224           gradx_scp(j,i)=expon*gradx_scp(j,i)
4225         enddo
4226       enddo
4227 C******************************************************************************
4228 C
4229 C                              N O T E !!!
4230 C
4231 C To save time the factor EXPON has been extracted from ALL components
4232 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4233 C use!
4234 C
4235 C******************************************************************************
4236       return
4237       end
4238 C--------------------------------------------------------------------------
4239       subroutine edis(ehpb)
4240 C
4241 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4242 C
4243       implicit real*8 (a-h,o-z)
4244       include 'DIMENSIONS'
4245       include 'COMMON.SBRIDGE'
4246       include 'COMMON.CHAIN'
4247       include 'COMMON.DERIV'
4248       include 'COMMON.VAR'
4249       include 'COMMON.INTERACT'
4250       include 'COMMON.IOUNITS'
4251       dimension ggg(3)
4252       ehpb=0.0D0
4253 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4254 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4255       if (link_end.eq.0) return
4256       do i=link_start,link_end
4257 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4258 C CA-CA distance used in regularization of structure.
4259         ii=ihpb(i)
4260         jj=jhpb(i)
4261 C iii and jjj point to the residues for which the distance is assigned.
4262         if (ii.gt.nres) then
4263           iii=ii-nres
4264           jjj=jj-nres
4265         else
4266           iii=ii
4267           jjj=jj
4268         endif
4269 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4270 c     &    dhpb(i),dhpb1(i),forcon(i)
4271 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4272 C    distance and angle dependent SS bond potential.
4273         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. iabs(itype(jjj
4274      &)).eq.1) then
4275           call ssbond_ene(iii,jjj,eij)
4276           ehpb=ehpb+2*eij
4277 cd          write (iout,*) "eij",eij
4278         else if (ii.gt.nres .and. jj.gt.nres) then
4279 c Restraints from contact prediction
4280           dd=dist(ii,jj)
4281           if (dhpb1(i).gt.0.0d0) then
4282             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4283             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4284 c            write (iout,*) "beta nmr",
4285 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4286           else
4287             dd=dist(ii,jj)
4288             rdis=dd-dhpb(i)
4289 C Get the force constant corresponding to this distance.
4290             waga=forcon(i)
4291 C Calculate the contribution to energy.
4292             ehpb=ehpb+waga*rdis*rdis
4293 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4294 C
4295 C Evaluate gradient.
4296 C
4297             fac=waga*rdis/dd
4298           endif
4299           do j=1,3
4300             ggg(j)=fac*(c(j,jj)-c(j,ii))
4301           enddo
4302           do j=1,3
4303             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4304             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4305           enddo
4306           do k=1,3
4307             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4308             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4309           enddo
4310         else
4311 C Calculate the distance between the two points and its difference from the
4312 C target distance.
4313           dd=dist(ii,jj)
4314           if (dhpb1(i).gt.0.0d0) then
4315             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4316             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4317 c            write (iout,*) "alph nmr",
4318 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4319           else
4320             rdis=dd-dhpb(i)
4321 C Get the force constant corresponding to this distance.
4322             waga=forcon(i)
4323 C Calculate the contribution to energy.
4324             ehpb=ehpb+waga*rdis*rdis
4325 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4326 C
4327 C Evaluate gradient.
4328 C
4329             fac=waga*rdis/dd
4330           endif
4331 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4332 cd   &   ' waga=',waga,' fac=',fac
4333             do j=1,3
4334               ggg(j)=fac*(c(j,jj)-c(j,ii))
4335             enddo
4336 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4337 C If this is a SC-SC distance, we need to calculate the contributions to the
4338 C Cartesian gradient in the SC vectors (ghpbx).
4339           if (iii.lt.ii) then
4340           do j=1,3
4341             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4342             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4343           enddo
4344           endif
4345 cgrad        do j=iii,jjj-1
4346 cgrad          do k=1,3
4347 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4348 cgrad          enddo
4349 cgrad        enddo
4350           do k=1,3
4351             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4352             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4353           enddo
4354         endif
4355       enddo
4356       ehpb=0.5D0*ehpb
4357       return
4358       end
4359 C--------------------------------------------------------------------------
4360       subroutine ssbond_ene(i,j,eij)
4361 C
4362 C Calculate the distance and angle dependent SS-bond potential energy
4363 C using a free-energy function derived based on RHF/6-31G** ab initio
4364 C calculations of diethyl disulfide.
4365 C
4366 C A. Liwo and U. Kozlowska, 11/24/03
4367 C
4368       implicit real*8 (a-h,o-z)
4369       include 'DIMENSIONS'
4370       include 'COMMON.SBRIDGE'
4371       include 'COMMON.CHAIN'
4372       include 'COMMON.DERIV'
4373       include 'COMMON.LOCAL'
4374       include 'COMMON.INTERACT'
4375       include 'COMMON.VAR'
4376       include 'COMMON.IOUNITS'
4377       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4378       itypi=iabs(itype(i))
4379       xi=c(1,nres+i)
4380       yi=c(2,nres+i)
4381       zi=c(3,nres+i)
4382       dxi=dc_norm(1,nres+i)
4383       dyi=dc_norm(2,nres+i)
4384       dzi=dc_norm(3,nres+i)
4385 c      dsci_inv=dsc_inv(itypi)
4386       dsci_inv=vbld_inv(nres+i)
4387       itypj=iabs(itype(j))
4388 c      dscj_inv=dsc_inv(itypj)
4389       dscj_inv=vbld_inv(nres+j)
4390       xj=c(1,nres+j)-xi
4391       yj=c(2,nres+j)-yi
4392       zj=c(3,nres+j)-zi
4393       dxj=dc_norm(1,nres+j)
4394       dyj=dc_norm(2,nres+j)
4395       dzj=dc_norm(3,nres+j)
4396       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4397       rij=dsqrt(rrij)
4398       erij(1)=xj*rij
4399       erij(2)=yj*rij
4400       erij(3)=zj*rij
4401       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4402       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4403       om12=dxi*dxj+dyi*dyj+dzi*dzj
4404       do k=1,3
4405         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4406         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4407       enddo
4408       rij=1.0d0/rij
4409       deltad=rij-d0cm
4410       deltat1=1.0d0-om1
4411       deltat2=1.0d0+om2
4412       deltat12=om2-om1+2.0d0
4413       cosphi=om12-om1*om2
4414       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4415      &  +akct*deltad*deltat12
4416      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4417 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4418 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4419 c     &  " deltat12",deltat12," eij",eij
4420       ed=2*akcm*deltad+akct*deltat12
4421       pom1=akct*deltad
4422       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4423       eom1=-2*akth*deltat1-pom1-om2*pom2
4424       eom2= 2*akth*deltat2+pom1-om1*pom2
4425       eom12=pom2
4426       do k=1,3
4427         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4428         ghpbx(k,i)=ghpbx(k,i)-ggk
4429      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4430      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4431         ghpbx(k,j)=ghpbx(k,j)+ggk
4432      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4433      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4434         ghpbc(k,i)=ghpbc(k,i)-ggk
4435         ghpbc(k,j)=ghpbc(k,j)+ggk
4436       enddo
4437 C
4438 C Calculate the components of the gradient in DC and X
4439 C
4440 cgrad      do k=i,j-1
4441 cgrad        do l=1,3
4442 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4443 cgrad        enddo
4444 cgrad      enddo
4445       return
4446       end
4447 C--------------------------------------------------------------------------
4448       subroutine ebond(estr)
4449 c
4450 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4451 c
4452       implicit real*8 (a-h,o-z)
4453       include 'DIMENSIONS'
4454       include 'COMMON.LOCAL'
4455       include 'COMMON.GEO'
4456       include 'COMMON.INTERACT'
4457       include 'COMMON.DERIV'
4458       include 'COMMON.VAR'
4459       include 'COMMON.CHAIN'
4460       include 'COMMON.IOUNITS'
4461       include 'COMMON.NAMES'
4462       include 'COMMON.FFIELD'
4463       include 'COMMON.CONTROL'
4464       include 'COMMON.SETUP'
4465       double precision u(3),ud(3)
4466       estr=0.0d0
4467       do i=ibondp_start,ibondp_end
4468         diff = vbld(i)-vbldp0
4469 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4470         estr=estr+diff*diff
4471         do j=1,3
4472           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4473         enddo
4474 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4475       enddo
4476       estr=0.5d0*AKP*estr
4477 c
4478 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4479 c
4480       do i=ibond_start,ibond_end
4481         iti=iabs(itype(i))
4482         if (iti.ne.10) then
4483           nbi=nbondterm(iti)
4484           if (nbi.eq.1) then
4485             diff=vbld(i+nres)-vbldsc0(1,iti)
4486 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4487 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4488             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4489             do j=1,3
4490               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4491             enddo
4492           else
4493             do j=1,nbi
4494               diff=vbld(i+nres)-vbldsc0(j,iti)
4495               ud(j)=aksc(j,iti)*diff
4496               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4497             enddo
4498             uprod=u(1)
4499             do j=2,nbi
4500               uprod=uprod*u(j)
4501             enddo
4502             usum=0.0d0
4503             usumsqder=0.0d0
4504             do j=1,nbi
4505               uprod1=1.0d0
4506               uprod2=1.0d0
4507               do k=1,nbi
4508                 if (k.ne.j) then
4509                   uprod1=uprod1*u(k)
4510                   uprod2=uprod2*u(k)*u(k)
4511                 endif
4512               enddo
4513               usum=usum+uprod1
4514               usumsqder=usumsqder+ud(j)*uprod2
4515             enddo
4516             estr=estr+uprod/usum
4517             do j=1,3
4518              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4519             enddo
4520           endif
4521         endif
4522       enddo
4523       return
4524       end
4525 #ifdef CRYST_THETA
4526 C--------------------------------------------------------------------------
4527       subroutine ebend(etheta)
4528 C
4529 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4530 C angles gamma and its derivatives in consecutive thetas and gammas.
4531 C
4532       implicit real*8 (a-h,o-z)
4533       include 'DIMENSIONS'
4534       include 'COMMON.LOCAL'
4535       include 'COMMON.GEO'
4536       include 'COMMON.INTERACT'
4537       include 'COMMON.DERIV'
4538       include 'COMMON.VAR'
4539       include 'COMMON.CHAIN'
4540       include 'COMMON.IOUNITS'
4541       include 'COMMON.NAMES'
4542       include 'COMMON.FFIELD'
4543       include 'COMMON.CONTROL'
4544       common /calcthet/ term1,term2,termm,diffak,ratak,
4545      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4546      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4547       double precision y(2),z(2)
4548       delta=0.02d0*pi
4549 c      time11=dexp(-2*time)
4550 c      time12=1.0d0
4551       etheta=0.0D0
4552 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4553       do i=ithet_start,ithet_end
4554 C Zero the energy function and its derivative at 0 or pi.
4555         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4556         it=(itype(i-1))
4557         ichir1=isign(1,itype(i-2))
4558         ichir2=isign(1,itype(i))
4559         if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4560         if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4561         if (itype(i-1).eq.10) then
4562          itype1=isign(10,itype(i-2))
4563          ichir11=isign(1,itype(i-2))
4564          ichir12=isign(1,itype(i-2))
4565          itype2=isign(10,itype(i))
4566          ichir21=isign(1,itype(i))
4567          ichir22=isign(1,itype(i))
4568         endif
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,ichir1,ichir2)
4603           bthetk=bthet(k,it,ichir1,ichir2)
4604         if (it.eq.10) then
4605            athetk=athet(k,itype1,ichir11,ichir12)
4606            bthetk=bthet(k,itype2,ichir21,ichir22)
4607         endif
4608           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4609         enddo
4610         dthett=thet_pred_mean*ssd
4611         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4612 C Derivatives of the "mean" values in gamma1 and gamma2.
4613         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4614      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4615         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4616      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4617         if (it.eq.10) then
4618       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4619      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4620         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4621      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4622         endif
4623         if (theta(i).gt.pi-delta) then
4624           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4625      &         E_tc0)
4626           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4627           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4628           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4629      &        E_theta)
4630           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4631      &        E_tc)
4632         else if (theta(i).lt.delta) then
4633           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4634           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4635           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4636      &        E_theta)
4637           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4638           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4639      &        E_tc)
4640         else
4641           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4642      &        E_theta,E_tc)
4643         endif
4644         etheta=etheta+ethetai
4645         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4646      &      'ebend',i,ethetai
4647         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4648         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4649         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4650       enddo
4651 C Ufff.... We've done all this!!!
4652       return
4653       end
4654 C---------------------------------------------------------------------------
4655       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4656      &     E_tc)
4657       implicit real*8 (a-h,o-z)
4658       include 'DIMENSIONS'
4659       include 'COMMON.LOCAL'
4660       include 'COMMON.IOUNITS'
4661       common /calcthet/ term1,term2,termm,diffak,ratak,
4662      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4663      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4664 C Calculate the contributions to both Gaussian lobes.
4665 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4666 C The "polynomial part" of the "standard deviation" of this part of
4667 C the distribution.
4668         sig=polthet(3,it)
4669         do j=2,0,-1
4670           sig=sig*thet_pred_mean+polthet(j,it)
4671         enddo
4672 C Derivative of the "interior part" of the "standard deviation of the"
4673 C gamma-dependent Gaussian lobe in t_c.
4674         sigtc=3*polthet(3,it)
4675         do j=2,1,-1
4676           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4677         enddo
4678         sigtc=sig*sigtc
4679 C Set the parameters of both Gaussian lobes of the distribution.
4680 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4681         fac=sig*sig+sigc0(it)
4682         sigcsq=fac+fac
4683         sigc=1.0D0/sigcsq
4684 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4685         sigsqtc=-4.0D0*sigcsq*sigtc
4686 c       print *,i,sig,sigtc,sigsqtc
4687 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4688         sigtc=-sigtc/(fac*fac)
4689 C Following variable is sigma(t_c)**(-2)
4690         sigcsq=sigcsq*sigcsq
4691         sig0i=sig0(it)
4692         sig0inv=1.0D0/sig0i**2
4693         delthec=thetai-thet_pred_mean
4694         delthe0=thetai-theta0i
4695         term1=-0.5D0*sigcsq*delthec*delthec
4696         term2=-0.5D0*sig0inv*delthe0*delthe0
4697 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4698 C NaNs in taking the logarithm. We extract the largest exponent which is added
4699 C to the energy (this being the log of the distribution) at the end of energy
4700 C term evaluation for this virtual-bond angle.
4701         if (term1.gt.term2) then
4702           termm=term1
4703           term2=dexp(term2-termm)
4704           term1=1.0d0
4705         else
4706           termm=term2
4707           term1=dexp(term1-termm)
4708           term2=1.0d0
4709         endif
4710 C The ratio between the gamma-independent and gamma-dependent lobes of
4711 C the distribution is a Gaussian function of thet_pred_mean too.
4712         diffak=gthet(2,it)-thet_pred_mean
4713         ratak=diffak/gthet(3,it)**2
4714         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4715 C Let's differentiate it in thet_pred_mean NOW.
4716         aktc=ak*ratak
4717 C Now put together the distribution terms to make complete distribution.
4718         termexp=term1+ak*term2
4719         termpre=sigc+ak*sig0i
4720 C Contribution of the bending energy from this theta is just the -log of
4721 C the sum of the contributions from the two lobes and the pre-exponential
4722 C factor. Simple enough, isn't it?
4723         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4724 C NOW the derivatives!!!
4725 C 6/6/97 Take into account the deformation.
4726         E_theta=(delthec*sigcsq*term1
4727      &       +ak*delthe0*sig0inv*term2)/termexp
4728         E_tc=((sigtc+aktc*sig0i)/termpre
4729      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4730      &       aktc*term2)/termexp)
4731       return
4732       end
4733 c-----------------------------------------------------------------------------
4734       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4735       implicit real*8 (a-h,o-z)
4736       include 'DIMENSIONS'
4737       include 'COMMON.LOCAL'
4738       include 'COMMON.IOUNITS'
4739       common /calcthet/ term1,term2,termm,diffak,ratak,
4740      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4741      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4742       delthec=thetai-thet_pred_mean
4743       delthe0=thetai-theta0i
4744 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4745       t3 = thetai-thet_pred_mean
4746       t6 = t3**2
4747       t9 = term1
4748       t12 = t3*sigcsq
4749       t14 = t12+t6*sigsqtc
4750       t16 = 1.0d0
4751       t21 = thetai-theta0i
4752       t23 = t21**2
4753       t26 = term2
4754       t27 = t21*t26
4755       t32 = termexp
4756       t40 = t32**2
4757       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4758      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4759      & *(-t12*t9-ak*sig0inv*t27)
4760       return
4761       end
4762 #else
4763 C--------------------------------------------------------------------------
4764       subroutine ebend(etheta)
4765 C
4766 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4767 C angles gamma and its derivatives in consecutive thetas and gammas.
4768 C ab initio-derived potentials from
4769 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4770 C
4771       implicit real*8 (a-h,o-z)
4772       include 'DIMENSIONS'
4773       include 'COMMON.LOCAL'
4774       include 'COMMON.GEO'
4775       include 'COMMON.INTERACT'
4776       include 'COMMON.DERIV'
4777       include 'COMMON.VAR'
4778       include 'COMMON.CHAIN'
4779       include 'COMMON.IOUNITS'
4780       include 'COMMON.NAMES'
4781       include 'COMMON.FFIELD'
4782       include 'COMMON.CONTROL'
4783       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4784      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4785      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4786      & sinph1ph2(maxdouble,maxdouble)
4787       logical lprn /.false./, lprn1 /.false./
4788       etheta=0.0D0
4789       do i=ithet_start,ithet_end
4790         dethetai=0.0d0
4791         dephii=0.0d0
4792         dephii1=0.0d0
4793         theti2=0.5d0*theta(i)
4794         ityp2=ithetyp(iabs(itype(i-1)))
4795         do k=1,nntheterm
4796           coskt(k)=dcos(k*theti2)
4797           sinkt(k)=dsin(k*theti2)
4798         enddo
4799         if (i.gt.3) then
4800 #ifdef OSF
4801           phii=phi(i)
4802           if (phii.ne.phii) phii=150.0
4803 #else
4804           phii=phi(i)
4805 #endif
4806           ityp1=ithetyp(iabs(itype(i-2)))
4807           do k=1,nsingle
4808             cosph1(k)=dcos(k*phii)
4809             sinph1(k)=dsin(k*phii)
4810           enddo
4811         else
4812           phii=0.0d0
4813           ityp1=nthetyp+1
4814           do k=1,nsingle
4815             cosph1(k)=0.0d0
4816             sinph1(k)=0.0d0
4817           enddo
4818         endif
4819         if (i.lt.nres) then
4820 #ifdef OSF
4821           phii1=phi(i+1)
4822           if (phii1.ne.phii1) phii1=150.0
4823           phii1=pinorm(phii1)
4824 #else
4825           phii1=phi(i+1)
4826 #endif
4827           ityp3=ithetyp(iabs(itype(i)))
4828           do k=1,nsingle
4829             cosph2(k)=dcos(k*phii1)
4830             sinph2(k)=dsin(k*phii1)
4831           enddo
4832         else
4833           phii1=0.0d0
4834           ityp3=nthetyp+1
4835           do k=1,nsingle
4836             cosph2(k)=0.0d0
4837             sinph2(k)=0.0d0
4838           enddo
4839         endif
4840         ethetai=aa0thet(ityp1,ityp2,ityp3)
4841         do k=1,ndouble
4842           do l=1,k-1
4843             ccl=cosph1(l)*cosph2(k-l)
4844             ssl=sinph1(l)*sinph2(k-l)
4845             scl=sinph1(l)*cosph2(k-l)
4846             csl=cosph1(l)*sinph2(k-l)
4847             cosph1ph2(l,k)=ccl-ssl
4848             cosph1ph2(k,l)=ccl+ssl
4849             sinph1ph2(l,k)=scl+csl
4850             sinph1ph2(k,l)=scl-csl
4851           enddo
4852         enddo
4853         if (lprn) then
4854         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4855      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4856         write (iout,*) "coskt and sinkt"
4857         do k=1,nntheterm
4858           write (iout,*) k,coskt(k),sinkt(k)
4859         enddo
4860         endif
4861         do k=1,ntheterm
4862           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4863           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4864      &      *coskt(k)
4865           if (lprn)
4866      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4867      &     " ethetai",ethetai
4868         enddo
4869         if (lprn) then
4870         write (iout,*) "cosph and sinph"
4871         do k=1,nsingle
4872           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4873         enddo
4874         write (iout,*) "cosph1ph2 and sinph2ph2"
4875         do k=2,ndouble
4876           do l=1,k-1
4877             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4878      &         sinph1ph2(l,k),sinph1ph2(k,l)
4879           enddo
4880         enddo
4881         write(iout,*) "ethetai",ethetai
4882         endif
4883         do m=1,ntheterm2
4884           do k=1,nsingle
4885             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4886      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4887      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4888      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4889             ethetai=ethetai+sinkt(m)*aux
4890             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4891             dephii=dephii+k*sinkt(m)*(
4892      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4893      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4894             dephii1=dephii1+k*sinkt(m)*(
4895      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4896      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4897             if (lprn)
4898      &      write (iout,*) "m",m," k",k," bbthet",
4899      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4900      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4901      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4902      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4903           enddo
4904         enddo
4905         if (lprn)
4906      &  write(iout,*) "ethetai",ethetai
4907         do m=1,ntheterm3
4908           do k=2,ndouble
4909             do l=1,k-1
4910               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4911      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4912      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4913      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4914               ethetai=ethetai+sinkt(m)*aux
4915               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4916               dephii=dephii+l*sinkt(m)*(
4917      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4918      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4919      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4920      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4921               dephii1=dephii1+(k-l)*sinkt(m)*(
4922      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4923      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4924      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4925      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4926               if (lprn) then
4927               write (iout,*) "m",m," k",k," l",l," ffthet",
4928      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4929      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4930      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4931      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4932               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4933      &            cosph1ph2(k,l)*sinkt(m),
4934      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4935               endif
4936             enddo
4937           enddo
4938         enddo
4939 10      continue
4940         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4941      &   i,theta(i)*rad2deg,phii*rad2deg,
4942      &   phii1*rad2deg,ethetai
4943         etheta=etheta+ethetai
4944         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4945         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4946         gloc(nphi+i-2,icg)=wang*dethetai
4947       enddo
4948       return
4949       end
4950 #endif
4951 #ifdef CRYST_SC
4952 c-----------------------------------------------------------------------------
4953       subroutine esc(escloc)
4954 C Calculate the local energy of a side chain and its derivatives in the
4955 C corresponding virtual-bond valence angles THETA and the spherical angles
4956 C ALPHA and OMEGA.
4957       implicit real*8 (a-h,o-z)
4958       include 'DIMENSIONS'
4959       include 'COMMON.GEO'
4960       include 'COMMON.LOCAL'
4961       include 'COMMON.VAR'
4962       include 'COMMON.INTERACT'
4963       include 'COMMON.DERIV'
4964       include 'COMMON.CHAIN'
4965       include 'COMMON.IOUNITS'
4966       include 'COMMON.NAMES'
4967       include 'COMMON.FFIELD'
4968       include 'COMMON.CONTROL'
4969       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4970      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4971       common /sccalc/ time11,time12,time112,theti,it,nlobit
4972       delta=0.02d0*pi
4973       escloc=0.0D0
4974 c     write (iout,'(a)') 'ESC'
4975       do i=loc_start,loc_end
4976         it=itype(i)
4977         if (it.eq.10) goto 1
4978         nlobit=nlob(iabs(it))
4979 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4980 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4981         theti=theta(i+1)-pipol
4982         x(1)=dtan(theti)
4983         x(2)=alph(i)
4984         x(3)=omeg(i)
4985
4986         if (x(2).gt.pi-delta) then
4987           xtemp(1)=x(1)
4988           xtemp(2)=pi-delta
4989           xtemp(3)=x(3)
4990           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4991           xtemp(2)=pi
4992           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4993           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4994      &        escloci,dersc(2))
4995           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4996      &        ddersc0(1),dersc(1))
4997           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4998      &        ddersc0(3),dersc(3))
4999           xtemp(2)=pi-delta
5000           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5001           xtemp(2)=pi
5002           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5003           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5004      &            dersc0(2),esclocbi,dersc02)
5005           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5006      &            dersc12,dersc01)
5007           call splinthet(x(2),0.5d0*delta,ss,ssd)
5008           dersc0(1)=dersc01
5009           dersc0(2)=dersc02
5010           dersc0(3)=0.0d0
5011           do k=1,3
5012             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5013           enddo
5014           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5015 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5016 c    &             esclocbi,ss,ssd
5017           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5018 c         escloci=esclocbi
5019 c         write (iout,*) escloci
5020         else if (x(2).lt.delta) then
5021           xtemp(1)=x(1)
5022           xtemp(2)=delta
5023           xtemp(3)=x(3)
5024           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5025           xtemp(2)=0.0d0
5026           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5027           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5028      &        escloci,dersc(2))
5029           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5030      &        ddersc0(1),dersc(1))
5031           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5032      &        ddersc0(3),dersc(3))
5033           xtemp(2)=delta
5034           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5035           xtemp(2)=0.0d0
5036           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5037           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5038      &            dersc0(2),esclocbi,dersc02)
5039           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5040      &            dersc12,dersc01)
5041           dersc0(1)=dersc01
5042           dersc0(2)=dersc02
5043           dersc0(3)=0.0d0
5044           call splinthet(x(2),0.5d0*delta,ss,ssd)
5045           do k=1,3
5046             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5047           enddo
5048           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5049 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5050 c    &             esclocbi,ss,ssd
5051           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5052 c         write (iout,*) escloci
5053         else
5054           call enesc(x,escloci,dersc,ddummy,.false.)
5055         endif
5056
5057         escloc=escloc+escloci
5058         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5059      &     'escloc',i,escloci
5060 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5061
5062         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5063      &   wscloc*dersc(1)
5064         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5065         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5066     1   continue
5067       enddo
5068       return
5069       end
5070 C---------------------------------------------------------------------------
5071       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5072       implicit real*8 (a-h,o-z)
5073       include 'DIMENSIONS'
5074       include 'COMMON.GEO'
5075       include 'COMMON.LOCAL'
5076       include 'COMMON.IOUNITS'
5077       common /sccalc/ time11,time12,time112,theti,it,nlobit
5078       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5079       double precision contr(maxlob,-1:1)
5080       logical mixed
5081 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5082         escloc_i=0.0D0
5083         do j=1,3
5084           dersc(j)=0.0D0
5085           if (mixed) ddersc(j)=0.0d0
5086         enddo
5087         x3=x(3)
5088
5089 C Because of periodicity of the dependence of the SC energy in omega we have
5090 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5091 C To avoid underflows, first compute & store the exponents.
5092
5093         do iii=-1,1
5094
5095           x(3)=x3+iii*dwapi
5096
5097           do j=1,nlobit
5098             do k=1,3
5099               z(k)=x(k)-censc(k,j,it)
5100             enddo
5101             do k=1,3
5102               Axk=0.0D0
5103               do l=1,3
5104                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5105               enddo
5106               Ax(k,j,iii)=Axk
5107             enddo
5108             expfac=0.0D0
5109             do k=1,3
5110               expfac=expfac+Ax(k,j,iii)*z(k)
5111             enddo
5112             contr(j,iii)=expfac
5113           enddo ! j
5114
5115         enddo ! iii
5116
5117         x(3)=x3
5118 C As in the case of ebend, we want to avoid underflows in exponentiation and
5119 C subsequent NaNs and INFs in energy calculation.
5120 C Find the largest exponent
5121         emin=contr(1,-1)
5122         do iii=-1,1
5123           do j=1,nlobit
5124             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5125           enddo
5126         enddo
5127         emin=0.5D0*emin
5128 cd      print *,'it=',it,' emin=',emin
5129
5130 C Compute the contribution to SC energy and derivatives
5131         do iii=-1,1
5132
5133           do j=1,nlobit
5134 #ifdef OSF
5135             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5136             if(adexp.ne.adexp) adexp=1.0
5137             expfac=dexp(adexp)
5138 #else
5139             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5140 #endif
5141 cd          print *,'j=',j,' expfac=',expfac
5142             escloc_i=escloc_i+expfac
5143             do k=1,3
5144               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5145             enddo
5146             if (mixed) then
5147               do k=1,3,2
5148                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5149      &            +gaussc(k,2,j,it))*expfac
5150               enddo
5151             endif
5152           enddo
5153
5154         enddo ! iii
5155
5156         dersc(1)=dersc(1)/cos(theti)**2
5157         ddersc(1)=ddersc(1)/cos(theti)**2
5158         ddersc(3)=ddersc(3)
5159
5160         escloci=-(dlog(escloc_i)-emin)
5161         do j=1,3
5162           dersc(j)=dersc(j)/escloc_i
5163         enddo
5164         if (mixed) then
5165           do j=1,3,2
5166             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5167           enddo
5168         endif
5169       return
5170       end
5171 C------------------------------------------------------------------------------
5172       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5173       implicit real*8 (a-h,o-z)
5174       include 'DIMENSIONS'
5175       include 'COMMON.GEO'
5176       include 'COMMON.LOCAL'
5177       include 'COMMON.IOUNITS'
5178       common /sccalc/ time11,time12,time112,theti,it,nlobit
5179       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5180       double precision contr(maxlob)
5181       logical mixed
5182
5183       escloc_i=0.0D0
5184
5185       do j=1,3
5186         dersc(j)=0.0D0
5187       enddo
5188
5189       do j=1,nlobit
5190         do k=1,2
5191           z(k)=x(k)-censc(k,j,it)
5192         enddo
5193         z(3)=dwapi
5194         do k=1,3
5195           Axk=0.0D0
5196           do l=1,3
5197             Axk=Axk+gaussc(l,k,j,it)*z(l)
5198           enddo
5199           Ax(k,j)=Axk
5200         enddo
5201         expfac=0.0D0
5202         do k=1,3
5203           expfac=expfac+Ax(k,j)*z(k)
5204         enddo
5205         contr(j)=expfac
5206       enddo ! j
5207
5208 C As in the case of ebend, we want to avoid underflows in exponentiation and
5209 C subsequent NaNs and INFs in energy calculation.
5210 C Find the largest exponent
5211       emin=contr(1)
5212       do j=1,nlobit
5213         if (emin.gt.contr(j)) emin=contr(j)
5214       enddo
5215       emin=0.5D0*emin
5216
5217 C Compute the contribution to SC energy and derivatives
5218
5219       dersc12=0.0d0
5220       do j=1,nlobit
5221         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5222         escloc_i=escloc_i+expfac
5223         do k=1,2
5224           dersc(k)=dersc(k)+Ax(k,j)*expfac
5225         enddo
5226         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5227      &            +gaussc(1,2,j,it))*expfac
5228         dersc(3)=0.0d0
5229       enddo
5230
5231       dersc(1)=dersc(1)/cos(theti)**2
5232       dersc12=dersc12/cos(theti)**2
5233       escloci=-(dlog(escloc_i)-emin)
5234       do j=1,2
5235         dersc(j)=dersc(j)/escloc_i
5236       enddo
5237       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5238       return
5239       end
5240 #else
5241 c----------------------------------------------------------------------------------
5242       subroutine esc(escloc)
5243 C Calculate the local energy of a side chain and its derivatives in the
5244 C corresponding virtual-bond valence angles THETA and the spherical angles
5245 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5246 C added by Urszula Kozlowska. 07/11/2007
5247 C
5248       implicit real*8 (a-h,o-z)
5249       include 'DIMENSIONS'
5250       include 'COMMON.GEO'
5251       include 'COMMON.LOCAL'
5252       include 'COMMON.VAR'
5253       include 'COMMON.SCROT'
5254       include 'COMMON.INTERACT'
5255       include 'COMMON.DERIV'
5256       include 'COMMON.CHAIN'
5257       include 'COMMON.IOUNITS'
5258       include 'COMMON.NAMES'
5259       include 'COMMON.FFIELD'
5260       include 'COMMON.CONTROL'
5261       include 'COMMON.VECTORS'
5262       double precision x_prime(3),y_prime(3),z_prime(3)
5263      &    , sumene,dsc_i,dp2_i,x(65),
5264      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5265      &    de_dxx,de_dyy,de_dzz,de_dt
5266       double precision s1_t,s1_6_t,s2_t,s2_6_t
5267       double precision
5268      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5269      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5270      & dt_dCi(3),dt_dCi1(3)
5271       common /sccalc/ time11,time12,time112,theti,it,nlobit
5272       delta=0.02d0*pi
5273       escloc=0.0D0
5274       do i=loc_start,loc_end
5275         costtab(i+1) =dcos(theta(i+1))
5276         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5277         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5278         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5279         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5280         cosfac=dsqrt(cosfac2)
5281         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5282         sinfac=dsqrt(sinfac2)
5283         it=itype(i)
5284         if (it.eq.10) goto 1
5285 c
5286 C  Compute the axes of tghe local cartesian coordinates system; store in
5287 c   x_prime, y_prime and z_prime
5288 c
5289         do j=1,3
5290           x_prime(j) = 0.00
5291           y_prime(j) = 0.00
5292           z_prime(j) = 0.00
5293         enddo
5294 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5295 C     &   dc_norm(3,i+nres)
5296         do j = 1,3
5297           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5298           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5299         enddo
5300         do j = 1,3
5301           z_prime(j) = -uz(j,i-1)
5302         enddo
5303 c       write (2,*) "i",i
5304 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5305 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5306 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5307 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5308 c      & " xy",scalar(x_prime(1),y_prime(1)),
5309 c      & " xz",scalar(x_prime(1),z_prime(1)),
5310 c      & " yy",scalar(y_prime(1),y_prime(1)),
5311 c      & " yz",scalar(y_prime(1),z_prime(1)),
5312 c      & " zz",scalar(z_prime(1),z_prime(1))
5313 c
5314 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5315 C to local coordinate system. Store in xx, yy, zz.
5316 c
5317         xx=0.0d0
5318         yy=0.0d0
5319         zz=0.0d0
5320         do j = 1,3
5321           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5322           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5323           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5324         enddo
5325
5326         xxtab(i)=xx
5327         yytab(i)=yy
5328         zztab(i)=zz
5329 C
5330 C Compute the energy of the ith side cbain
5331 C
5332 c        write (2,*) "xx",xx," yy",yy," zz",zz
5333         it=itype(i)
5334         do j = 1,65
5335           x(j) = sc_parmin(j,it)
5336         enddo
5337 #ifdef CHECK_COORD
5338 Cc diagnostics - remove later
5339         xx1 = dcos(alph(2))
5340         yy1 = dsin(alph(2))*dcos(omeg(2))
5341         zz1 = -dsin(alph(2))*dsin(omeg(2))
5342         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5343      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5344      &    xx1,yy1,zz1
5345 C,"  --- ", xx_w,yy_w,zz_w
5346 c end diagnostics
5347 #endif
5348         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5349      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5350      &   + x(10)*yy*zz
5351         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5352      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5353      & + x(20)*yy*zz
5354         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5355      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5356      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5357      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5358      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5359      &  +x(40)*xx*yy*zz
5360         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5361      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5362      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5363      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5364      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5365      &  +x(60)*xx*yy*zz
5366         dsc_i   = 0.743d0+x(61)
5367         dp2_i   = 1.9d0+x(62)
5368         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5369      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5370         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5371      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5372         s1=(1+x(63))/(0.1d0 + dscp1)
5373         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5374         s2=(1+x(65))/(0.1d0 + dscp2)
5375         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5376         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5377      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5378 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5379 c     &   sumene4,
5380 c     &   dscp1,dscp2,sumene
5381 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5382         escloc = escloc + sumene
5383 c        write (2,*) "i",i," escloc",sumene,escloc
5384 #ifdef DEBUG
5385 C
5386 C This section to check the numerical derivatives of the energy of ith side
5387 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5388 C #define DEBUG in the code to turn it on.
5389 C
5390         write (2,*) "sumene               =",sumene
5391         aincr=1.0d-7
5392         xxsave=xx
5393         xx=xx+aincr
5394         write (2,*) xx,yy,zz
5395         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5396         de_dxx_num=(sumenep-sumene)/aincr
5397         xx=xxsave
5398         write (2,*) "xx+ sumene from enesc=",sumenep
5399         yysave=yy
5400         yy=yy+aincr
5401         write (2,*) xx,yy,zz
5402         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5403         de_dyy_num=(sumenep-sumene)/aincr
5404         yy=yysave
5405         write (2,*) "yy+ sumene from enesc=",sumenep
5406         zzsave=zz
5407         zz=zz+aincr
5408         write (2,*) xx,yy,zz
5409         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5410         de_dzz_num=(sumenep-sumene)/aincr
5411         zz=zzsave
5412         write (2,*) "zz+ sumene from enesc=",sumenep
5413         costsave=cost2tab(i+1)
5414         sintsave=sint2tab(i+1)
5415         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5416         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5417         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5418         de_dt_num=(sumenep-sumene)/aincr
5419         write (2,*) " t+ sumene from enesc=",sumenep
5420         cost2tab(i+1)=costsave
5421         sint2tab(i+1)=sintsave
5422 C End of diagnostics section.
5423 #endif
5424 C
5425 C Compute the gradient of esc
5426 C
5427         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5428         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5429         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5430         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5431         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5432         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5433         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5434         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5435         pom1=(sumene3*sint2tab(i+1)+sumene1)
5436      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5437         pom2=(sumene4*cost2tab(i+1)+sumene2)
5438      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5439         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5440         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5441      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5442      &  +x(40)*yy*zz
5443         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5444         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5445      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5446      &  +x(60)*yy*zz
5447         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5448      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5449      &        +(pom1+pom2)*pom_dx
5450 #ifdef DEBUG
5451         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5452 #endif
5453 C
5454         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5455         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5456      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5457      &  +x(40)*xx*zz
5458         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5459         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5460      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5461      &  +x(59)*zz**2 +x(60)*xx*zz
5462         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5463      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5464      &        +(pom1-pom2)*pom_dy
5465 #ifdef DEBUG
5466         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5467 #endif
5468 C
5469         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5470      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5471      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5472      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5473      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5474      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5475      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5476      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5477 #ifdef DEBUG
5478         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5479 #endif
5480 C
5481         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5482      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5483      &  +pom1*pom_dt1+pom2*pom_dt2
5484 #ifdef DEBUG
5485         write(2,*), "de_dt = ", de_dt,de_dt_num
5486 #endif
5487 c
5488 C
5489        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5490        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5491        cosfac2xx=cosfac2*xx
5492        sinfac2yy=sinfac2*yy
5493        do k = 1,3
5494          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5495      &      vbld_inv(i+1)
5496          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5497      &      vbld_inv(i)
5498          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5499          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5500 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5501 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5502 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5503 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5504          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5505          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5506          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5507          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5508          dZZ_Ci1(k)=0.0d0
5509          dZZ_Ci(k)=0.0d0
5510          do j=1,3
5511            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5512            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5513          enddo
5514
5515          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5516          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5517          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5518 c
5519          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5520          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5521        enddo
5522
5523        do k=1,3
5524          dXX_Ctab(k,i)=dXX_Ci(k)
5525          dXX_C1tab(k,i)=dXX_Ci1(k)
5526          dYY_Ctab(k,i)=dYY_Ci(k)
5527          dYY_C1tab(k,i)=dYY_Ci1(k)
5528          dZZ_Ctab(k,i)=dZZ_Ci(k)
5529          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5530          dXX_XYZtab(k,i)=dXX_XYZ(k)
5531          dYY_XYZtab(k,i)=dYY_XYZ(k)
5532          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5533        enddo
5534
5535        do k = 1,3
5536 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5537 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5538 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5539 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5540 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5541 c     &    dt_dci(k)
5542 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5543 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5544          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5545      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5546          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5547      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5548          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5549      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5550        enddo
5551 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5552 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5553
5554 C to check gradient call subroutine check_grad
5555
5556     1 continue
5557       enddo
5558       return
5559       end
5560 c------------------------------------------------------------------------------
5561       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5562       implicit none
5563       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5564      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5565       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5566      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5567      &   + x(10)*yy*zz
5568       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5569      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5570      & + x(20)*yy*zz
5571       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5572      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5573      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5574      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5575      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5576      &  +x(40)*xx*yy*zz
5577       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5578      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5579      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5580      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5581      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5582      &  +x(60)*xx*yy*zz
5583       dsc_i   = 0.743d0+x(61)
5584       dp2_i   = 1.9d0+x(62)
5585       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5586      &          *(xx*cost2+yy*sint2))
5587       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5588      &          *(xx*cost2-yy*sint2))
5589       s1=(1+x(63))/(0.1d0 + dscp1)
5590       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5591       s2=(1+x(65))/(0.1d0 + dscp2)
5592       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5593       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5594      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5595       enesc=sumene
5596       return
5597       end
5598 #endif
5599 c------------------------------------------------------------------------------
5600       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5601 C
5602 C This procedure calculates two-body contact function g(rij) and its derivative:
5603 C
5604 C           eps0ij                                     !       x < -1
5605 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5606 C            0                                         !       x > 1
5607 C
5608 C where x=(rij-r0ij)/delta
5609 C
5610 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5611 C
5612       implicit none
5613       double precision rij,r0ij,eps0ij,fcont,fprimcont
5614       double precision x,x2,x4,delta
5615 c     delta=0.02D0*r0ij
5616 c      delta=0.2D0*r0ij
5617       x=(rij-r0ij)/delta
5618       if (x.lt.-1.0D0) then
5619         fcont=eps0ij
5620         fprimcont=0.0D0
5621       else if (x.le.1.0D0) then
5622         x2=x*x
5623         x4=x2*x2
5624         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5625         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5626       else
5627         fcont=0.0D0
5628         fprimcont=0.0D0
5629       endif
5630       return
5631       end
5632 c------------------------------------------------------------------------------
5633       subroutine splinthet(theti,delta,ss,ssder)
5634       implicit real*8 (a-h,o-z)
5635       include 'DIMENSIONS'
5636       include 'COMMON.VAR'
5637       include 'COMMON.GEO'
5638       thetup=pi-delta
5639       thetlow=delta
5640       if (theti.gt.pipol) then
5641         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5642       else
5643         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5644         ssder=-ssder
5645       endif
5646       return
5647       end
5648 c------------------------------------------------------------------------------
5649       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5650       implicit none
5651       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5652       double precision ksi,ksi2,ksi3,a1,a2,a3
5653       a1=fprim0*delta/(f1-f0)
5654       a2=3.0d0-2.0d0*a1
5655       a3=a1-2.0d0
5656       ksi=(x-x0)/delta
5657       ksi2=ksi*ksi
5658       ksi3=ksi2*ksi
5659       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5660       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5661       return
5662       end
5663 c------------------------------------------------------------------------------
5664       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5665       implicit none
5666       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5667       double precision ksi,ksi2,ksi3,a1,a2,a3
5668       ksi=(x-x0)/delta
5669       ksi2=ksi*ksi
5670       ksi3=ksi2*ksi
5671       a1=fprim0x*delta
5672       a2=3*(f1x-f0x)-2*fprim0x*delta
5673       a3=fprim0x*delta-2*(f1x-f0x)
5674       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5675       return
5676       end
5677 C-----------------------------------------------------------------------------
5678 #ifdef CRYST_TOR
5679 C-----------------------------------------------------------------------------
5680       subroutine etor(etors,edihcnstr)
5681       implicit real*8 (a-h,o-z)
5682       include 'DIMENSIONS'
5683       include 'COMMON.VAR'
5684       include 'COMMON.GEO'
5685       include 'COMMON.LOCAL'
5686       include 'COMMON.TORSION'
5687       include 'COMMON.INTERACT'
5688       include 'COMMON.DERIV'
5689       include 'COMMON.CHAIN'
5690       include 'COMMON.NAMES'
5691       include 'COMMON.IOUNITS'
5692       include 'COMMON.FFIELD'
5693       include 'COMMON.TORCNSTR'
5694       include 'COMMON.CONTROL'
5695       logical lprn
5696 C Set lprn=.true. for debugging
5697       lprn=.false.
5698 c      lprn=.true.
5699       etors=0.0D0
5700       do i=iphi_start,iphi_end
5701       etors_ii=0.0D0
5702         itori=itortyp(itype(i-2))
5703         itori1=itortyp(itype(i-1))
5704         phii=phi(i)
5705         gloci=0.0D0
5706 C Proline-Proline pair is a special case...
5707         if (itori.eq.3 .and. itori1.eq.3) then
5708           if (phii.gt.-dwapi3) then
5709             cosphi=dcos(3*phii)
5710             fac=1.0D0/(1.0D0-cosphi)
5711             etorsi=v1(1,3,3)*fac
5712             etorsi=etorsi+etorsi
5713             etors=etors+etorsi-v1(1,3,3)
5714             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5715             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5716           endif
5717           do j=1,3
5718             v1ij=v1(j+1,itori,itori1)
5719             v2ij=v2(j+1,itori,itori1)
5720             cosphi=dcos(j*phii)
5721             sinphi=dsin(j*phii)
5722             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5723             if (energy_dec) etors_ii=etors_ii+
5724      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5725             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5726           enddo
5727         else
5728           do j=1,nterm_old
5729             v1ij=v1(j,itori,itori1)
5730             v2ij=v2(j,itori,itori1)
5731             cosphi=dcos(j*phii)
5732             sinphi=dsin(j*phii)
5733             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5734             if (energy_dec) etors_ii=etors_ii+
5735      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5736             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5737           enddo
5738         endif
5739         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5740      &        'etor',i,etors_ii
5741         if (lprn)
5742      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5743      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5744      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5745         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5746         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5747       enddo
5748 ! 6/20/98 - dihedral angle constraints
5749       edihcnstr=0.0d0
5750       do i=1,ndih_constr
5751         itori=idih_constr(i)
5752         phii=phi(itori)
5753         difi=phii-phi0(i)
5754         if (difi.gt.drange(i)) then
5755           difi=difi-drange(i)
5756           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5757           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5758         else if (difi.lt.-drange(i)) then
5759           difi=difi+drange(i)
5760           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5761           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5762         endif
5763 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5764 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5765       enddo
5766 !      write (iout,*) 'edihcnstr',edihcnstr
5767       return
5768       end
5769 c------------------------------------------------------------------------------
5770       subroutine etor_d(etors_d)
5771       etors_d=0.0d0
5772       return
5773       end
5774 c----------------------------------------------------------------------------
5775 #else
5776       subroutine etor(etors,edihcnstr)
5777       implicit real*8 (a-h,o-z)
5778       include 'DIMENSIONS'
5779       include 'COMMON.VAR'
5780       include 'COMMON.GEO'
5781       include 'COMMON.LOCAL'
5782       include 'COMMON.TORSION'
5783       include 'COMMON.INTERACT'
5784       include 'COMMON.DERIV'
5785       include 'COMMON.CHAIN'
5786       include 'COMMON.NAMES'
5787       include 'COMMON.IOUNITS'
5788       include 'COMMON.FFIELD'
5789       include 'COMMON.TORCNSTR'
5790       include 'COMMON.CONTROL'
5791       logical lprn
5792 C Set lprn=.true. for debugging
5793       lprn=.false.
5794 c     lprn=.true.
5795       etors=0.0D0
5796       do i=iphi_start,iphi_end
5797       etors_ii=0.0D0
5798         itori=itortyp(itype(i-2))
5799         itori1=itortyp(itype(i-1))
5800         if (iabs(itype(i)).eq.20) then
5801         iblock=2
5802         else
5803         iblock=1
5804         endif
5805         phii=phi(i)
5806         gloci=0.0D0
5807 C Regular cosine and sine terms
5808         do j=1,nterm(itori,itori1,iblock)
5809           v1ij=v1(j,itori,itori1,iblock)
5810           v2ij=v2(j,itori,itori1,iblock)
5811           cosphi=dcos(j*phii)
5812           sinphi=dsin(j*phii)
5813           etors=etors+v1ij*cosphi+v2ij*sinphi
5814           if (energy_dec) etors_ii=etors_ii+
5815      &                v1ij*cosphi+v2ij*sinphi
5816           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5817         enddo
5818 C Lorentz terms
5819 C                         v1
5820 C  E = SUM ----------------------------------- - v1
5821 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5822 C
5823         cosphi=dcos(0.5d0*phii)
5824         sinphi=dsin(0.5d0*phii)
5825         do j=1,nlor(itori,itori1,iblock)
5826           vl1ij=vlor1(j,itori,itori1)
5827           vl2ij=vlor2(j,itori,itori1)
5828           vl3ij=vlor3(j,itori,itori1)
5829           pom=vl2ij*cosphi+vl3ij*sinphi
5830           pom1=1.0d0/(pom*pom+1.0d0)
5831           etors=etors+vl1ij*pom1
5832           if (energy_dec) etors_ii=etors_ii+
5833      &                vl1ij*pom1
5834           pom=-pom*pom1*pom1
5835           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5836         enddo
5837 C Subtract the constant term
5838         etors=etors-v0(itori,itori1,iblock)
5839           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5840      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5841         if (lprn)
5842      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5843      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5844      &  (v1(j,itori,itori1,iblock),j=1,6),
5845      &  (v2(j,itori,itori1,iblock),j=1,6)
5846         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5847 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5848       enddo
5849 ! 6/20/98 - dihedral angle constraints
5850       edihcnstr=0.0d0
5851 c      do i=1,ndih_constr
5852       do i=idihconstr_start,idihconstr_end
5853         itori=idih_constr(i)
5854         phii=phi(itori)
5855         difi=pinorm(phii-phi0(i))
5856         if (difi.gt.drange(i)) then
5857           difi=difi-drange(i)
5858           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5859           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5860         else if (difi.lt.-drange(i)) then
5861           difi=difi+drange(i)
5862           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5863           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5864         else
5865           difi=0.0
5866         endif
5867 c        write (iout,*) "gloci", gloc(i-3,icg)
5868 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5869 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5870 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5871       enddo
5872 cd       write (iout,*) 'edihcnstr',edihcnstr
5873       return
5874       end
5875 c----------------------------------------------------------------------------
5876       subroutine etor_d(etors_d)
5877 C 6/23/01 Compute double torsional energy
5878       implicit real*8 (a-h,o-z)
5879       include 'DIMENSIONS'
5880       include 'COMMON.VAR'
5881       include 'COMMON.GEO'
5882       include 'COMMON.LOCAL'
5883       include 'COMMON.TORSION'
5884       include 'COMMON.INTERACT'
5885       include 'COMMON.DERIV'
5886       include 'COMMON.CHAIN'
5887       include 'COMMON.NAMES'
5888       include 'COMMON.IOUNITS'
5889       include 'COMMON.FFIELD'
5890       include 'COMMON.TORCNSTR'
5891       logical lprn
5892 C Set lprn=.true. for debugging
5893       lprn=.false.
5894 c     lprn=.true.
5895       etors_d=0.0D0
5896       do i=iphid_start,iphid_end
5897         itori=itortyp(itype(i-2))
5898         itori1=itortyp(itype(i-1))
5899         itori2=itortyp(itype(i))
5900         iblock=1
5901         if (iabs(itype(i+1)).eq.20) iblock=2
5902         phii=phi(i)
5903         phii1=phi(i+1)
5904         gloci1=0.0D0
5905         gloci2=0.0D0
5906         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5907           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5908           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5909           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5910           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5911           cosphi1=dcos(j*phii)
5912           sinphi1=dsin(j*phii)
5913           cosphi2=dcos(j*phii1)
5914           sinphi2=dsin(j*phii1)
5915           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5916      &     v2cij*cosphi2+v2sij*sinphi2
5917           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5918           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5919         enddo
5920         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5921           do l=1,k-1
5922             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5923             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5924             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5925             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5926             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5927             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5928             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5929             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5930             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5931      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5932             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5933      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5934             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5935      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5936           enddo
5937         enddo
5938         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5939         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5940 c        write (iout,*) "gloci", gloc(i-3,icg)
5941       enddo
5942       return
5943       end
5944 #endif
5945 c------------------------------------------------------------------------------
5946       subroutine eback_sc_corr(esccor)
5947 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5948 c        conformational states; temporarily implemented as differences
5949 c        between UNRES torsional potentials (dependent on three types of
5950 c        residues) and the torsional potentials dependent on all 20 types
5951 c        of residues computed from AM1  energy surfaces of terminally-blocked
5952 c        amino-acid residues.
5953       implicit real*8 (a-h,o-z)
5954       include 'DIMENSIONS'
5955       include 'COMMON.VAR'
5956       include 'COMMON.GEO'
5957       include 'COMMON.LOCAL'
5958       include 'COMMON.TORSION'
5959       include 'COMMON.SCCOR'
5960       include 'COMMON.INTERACT'
5961       include 'COMMON.DERIV'
5962       include 'COMMON.CHAIN'
5963       include 'COMMON.NAMES'
5964       include 'COMMON.IOUNITS'
5965       include 'COMMON.FFIELD'
5966       include 'COMMON.CONTROL'
5967       logical lprn
5968 C Set lprn=.true. for debugging
5969       lprn=.false.
5970 c      lprn=.true.
5971 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5972       esccor=0.0D0
5973       do i=itau_start,itau_end
5974         esccor_ii=0.0D0
5975         isccori=isccortyp(itype(i-2))
5976         isccori1=isccortyp(itype(i-1))
5977         phii=phi(i)
5978 cccc  Added 9 May 2012
5979 cc Tauangle is torsional engle depending on the value of first digit
5980 c(see comment below)
5981 cc Omicron is flat angle depending on the value of first digit
5982 c(see comment below)
5983
5984
5985         do intertyp=1,3 !intertyp
5986 cc Added 09 May 2012 (Adasko)
5987 cc  Intertyp means interaction type of backbone mainchain correlation:
5988 c   1 = SC...Ca...Ca...Ca
5989 c   2 = Ca...Ca...Ca...SC
5990 c   3 = SC...Ca...Ca...SCi
5991         gloci=0.0D0
5992         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5993      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5994      &      (itype(i-1).eq.21)))
5995      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5996      &     .or.(itype(i-2).eq.21)))
5997      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5998      &      (itype(i-1).eq.21)))) cycle
5999         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6000         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6001      & cycle
6002         do j=1,nterm_sccor(isccori,isccori1)
6003           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6004           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6005           cosphi=dcos(j*tauangle(intertyp,i))
6006           sinphi=dsin(j*tauangle(intertyp,i))
6007           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6008           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6009         enddo
6010         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6011 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6012 c     &gloc_sc(intertyp,i-3,icg)
6013         if (lprn)
6014      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6015      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6016      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6017      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6018         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6019        enddo !intertyp
6020       enddo
6021 c        do i=1,nres
6022 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6023 c        enddo
6024       return
6025       end
6026 c----------------------------------------------------------------------------
6027       subroutine multibody(ecorr)
6028 C This subroutine calculates multi-body contributions to energy following
6029 C the idea of Skolnick et al. If side chains I and J make a contact and
6030 C at the same time side chains I+1 and J+1 make a contact, an extra
6031 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6032       implicit real*8 (a-h,o-z)
6033       include 'DIMENSIONS'
6034       include 'COMMON.IOUNITS'
6035       include 'COMMON.DERIV'
6036       include 'COMMON.INTERACT'
6037       include 'COMMON.CONTACTS'
6038       double precision gx(3),gx1(3)
6039       logical lprn
6040
6041 C Set lprn=.true. for debugging
6042       lprn=.false.
6043
6044       if (lprn) then
6045         write (iout,'(a)') 'Contact function values:'
6046         do i=nnt,nct-2
6047           write (iout,'(i2,20(1x,i2,f10.5))')
6048      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6049         enddo
6050       endif
6051       ecorr=0.0D0
6052       do i=nnt,nct
6053         do j=1,3
6054           gradcorr(j,i)=0.0D0
6055           gradxorr(j,i)=0.0D0
6056         enddo
6057       enddo
6058       do i=nnt,nct-2
6059
6060         DO ISHIFT = 3,4
6061
6062         i1=i+ishift
6063         num_conti=num_cont(i)
6064         num_conti1=num_cont(i1)
6065         do jj=1,num_conti
6066           j=jcont(jj,i)
6067           do kk=1,num_conti1
6068             j1=jcont(kk,i1)
6069             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6070 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6071 cd   &                   ' ishift=',ishift
6072 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6073 C The system gains extra energy.
6074               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6075             endif   ! j1==j+-ishift
6076           enddo     ! kk
6077         enddo       ! jj
6078
6079         ENDDO ! ISHIFT
6080
6081       enddo         ! i
6082       return
6083       end
6084 c------------------------------------------------------------------------------
6085       double precision function esccorr(i,j,k,l,jj,kk)
6086       implicit real*8 (a-h,o-z)
6087       include 'DIMENSIONS'
6088       include 'COMMON.IOUNITS'
6089       include 'COMMON.DERIV'
6090       include 'COMMON.INTERACT'
6091       include 'COMMON.CONTACTS'
6092       double precision gx(3),gx1(3)
6093       logical lprn
6094       lprn=.false.
6095       eij=facont(jj,i)
6096       ekl=facont(kk,k)
6097 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6098 C Calculate the multi-body contribution to energy.
6099 C Calculate multi-body contributions to the gradient.
6100 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6101 cd   & k,l,(gacont(m,kk,k),m=1,3)
6102       do m=1,3
6103         gx(m) =ekl*gacont(m,jj,i)
6104         gx1(m)=eij*gacont(m,kk,k)
6105         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6106         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6107         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6108         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6109       enddo
6110       do m=i,j-1
6111         do ll=1,3
6112           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6113         enddo
6114       enddo
6115       do m=k,l-1
6116         do ll=1,3
6117           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6118         enddo
6119       enddo
6120       esccorr=-eij*ekl
6121       return
6122       end
6123 c------------------------------------------------------------------------------
6124       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6125 C This subroutine calculates multi-body contributions to hydrogen-bonding
6126       implicit real*8 (a-h,o-z)
6127       include 'DIMENSIONS'
6128       include 'COMMON.IOUNITS'
6129 #ifdef MPI
6130       include "mpif.h"
6131       parameter (max_cont=maxconts)
6132       parameter (max_dim=26)
6133       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6134       double precision zapas(max_dim,maxconts,max_fg_procs),
6135      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6136       common /przechowalnia/ zapas
6137       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6138      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6139 #endif
6140       include 'COMMON.SETUP'
6141       include 'COMMON.FFIELD'
6142       include 'COMMON.DERIV'
6143       include 'COMMON.INTERACT'
6144       include 'COMMON.CONTACTS'
6145       include 'COMMON.CONTROL'
6146       include 'COMMON.LOCAL'
6147       double precision gx(3),gx1(3),time00
6148       logical lprn,ldone
6149
6150 C Set lprn=.true. for debugging
6151       lprn=.false.
6152 #ifdef MPI
6153       n_corr=0
6154       n_corr1=0
6155       if (nfgtasks.le.1) goto 30
6156       if (lprn) then
6157         write (iout,'(a)') 'Contact function values before RECEIVE:'
6158         do i=nnt,nct-2
6159           write (iout,'(2i3,50(1x,i2,f5.2))')
6160      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6161      &    j=1,num_cont_hb(i))
6162         enddo
6163       endif
6164       call flush(iout)
6165       do i=1,ntask_cont_from
6166         ncont_recv(i)=0
6167       enddo
6168       do i=1,ntask_cont_to
6169         ncont_sent(i)=0
6170       enddo
6171 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6172 c     & ntask_cont_to
6173 C Make the list of contacts to send to send to other procesors
6174 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6175 c      call flush(iout)
6176       do i=iturn3_start,iturn3_end
6177 c        write (iout,*) "make contact list turn3",i," num_cont",
6178 c     &    num_cont_hb(i)
6179         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6180       enddo
6181       do i=iturn4_start,iturn4_end
6182 c        write (iout,*) "make contact list turn4",i," num_cont",
6183 c     &   num_cont_hb(i)
6184         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6185       enddo
6186       do ii=1,nat_sent
6187         i=iat_sent(ii)
6188 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6189 c     &    num_cont_hb(i)
6190         do j=1,num_cont_hb(i)
6191         do k=1,4
6192           jjc=jcont_hb(j,i)
6193           iproc=iint_sent_local(k,jjc,ii)
6194 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6195           if (iproc.gt.0) then
6196             ncont_sent(iproc)=ncont_sent(iproc)+1
6197             nn=ncont_sent(iproc)
6198             zapas(1,nn,iproc)=i
6199             zapas(2,nn,iproc)=jjc
6200             zapas(3,nn,iproc)=facont_hb(j,i)
6201             zapas(4,nn,iproc)=ees0p(j,i)
6202             zapas(5,nn,iproc)=ees0m(j,i)
6203             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6204             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6205             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6206             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6207             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6208             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6209             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6210             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6211             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6212             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6213             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6214             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6215             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6216             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6217             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6218             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6219             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6220             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6221             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6222             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6223             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6224           endif
6225         enddo
6226         enddo
6227       enddo
6228       if (lprn) then
6229       write (iout,*)
6230      &  "Numbers of contacts to be sent to other processors",
6231      &  (ncont_sent(i),i=1,ntask_cont_to)
6232       write (iout,*) "Contacts sent"
6233       do ii=1,ntask_cont_to
6234         nn=ncont_sent(ii)
6235         iproc=itask_cont_to(ii)
6236         write (iout,*) nn," contacts to processor",iproc,
6237      &   " of CONT_TO_COMM group"
6238         do i=1,nn
6239           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6240         enddo
6241       enddo
6242       call flush(iout)
6243       endif
6244       CorrelType=477
6245       CorrelID=fg_rank+1
6246       CorrelType1=478
6247       CorrelID1=nfgtasks+fg_rank+1
6248       ireq=0
6249 C Receive the numbers of needed contacts from other processors
6250       do ii=1,ntask_cont_from
6251         iproc=itask_cont_from(ii)
6252         ireq=ireq+1
6253         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6254      &    FG_COMM,req(ireq),IERR)
6255       enddo
6256 c      write (iout,*) "IRECV ended"
6257 c      call flush(iout)
6258 C Send the number of contacts needed by other processors
6259       do ii=1,ntask_cont_to
6260         iproc=itask_cont_to(ii)
6261         ireq=ireq+1
6262         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6263      &    FG_COMM,req(ireq),IERR)
6264       enddo
6265 c      write (iout,*) "ISEND ended"
6266 c      write (iout,*) "number of requests (nn)",ireq
6267       call flush(iout)
6268       if (ireq.gt.0)
6269      &  call MPI_Waitall(ireq,req,status_array,ierr)
6270 c      write (iout,*)
6271 c     &  "Numbers of contacts to be received from other processors",
6272 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6273 c      call flush(iout)
6274 C Receive contacts
6275       ireq=0
6276       do ii=1,ntask_cont_from
6277         iproc=itask_cont_from(ii)
6278         nn=ncont_recv(ii)
6279 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6280 c     &   " of CONT_TO_COMM group"
6281         call flush(iout)
6282         if (nn.gt.0) then
6283           ireq=ireq+1
6284           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6285      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6286 c          write (iout,*) "ireq,req",ireq,req(ireq)
6287         endif
6288       enddo
6289 C Send the contacts to processors that need them
6290       do ii=1,ntask_cont_to
6291         iproc=itask_cont_to(ii)
6292         nn=ncont_sent(ii)
6293 c        write (iout,*) nn," contacts to processor",iproc,
6294 c     &   " of CONT_TO_COMM group"
6295         if (nn.gt.0) then
6296           ireq=ireq+1
6297           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6298      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6299 c          write (iout,*) "ireq,req",ireq,req(ireq)
6300 c          do i=1,nn
6301 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6302 c          enddo
6303         endif
6304       enddo
6305 c      write (iout,*) "number of requests (contacts)",ireq
6306 c      write (iout,*) "req",(req(i),i=1,4)
6307 c      call flush(iout)
6308       if (ireq.gt.0)
6309      & call MPI_Waitall(ireq,req,status_array,ierr)
6310       do iii=1,ntask_cont_from
6311         iproc=itask_cont_from(iii)
6312         nn=ncont_recv(iii)
6313         if (lprn) then
6314         write (iout,*) "Received",nn," contacts from processor",iproc,
6315      &   " of CONT_FROM_COMM group"
6316         call flush(iout)
6317         do i=1,nn
6318           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6319         enddo
6320         call flush(iout)
6321         endif
6322         do i=1,nn
6323           ii=zapas_recv(1,i,iii)
6324 c Flag the received contacts to prevent double-counting
6325           jj=-zapas_recv(2,i,iii)
6326 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6327 c          call flush(iout)
6328           nnn=num_cont_hb(ii)+1
6329           num_cont_hb(ii)=nnn
6330           jcont_hb(nnn,ii)=jj
6331           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6332           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6333           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6334           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6335           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6336           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6337           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6338           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6339           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6340           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6341           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6342           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6343           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6344           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6345           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6346           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6347           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6348           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6349           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6350           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6351           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6352           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6353           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6354           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6355         enddo
6356       enddo
6357       call flush(iout)
6358       if (lprn) then
6359         write (iout,'(a)') 'Contact function values after receive:'
6360         do i=nnt,nct-2
6361           write (iout,'(2i3,50(1x,i3,f5.2))')
6362      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6363      &    j=1,num_cont_hb(i))
6364         enddo
6365         call flush(iout)
6366       endif
6367    30 continue
6368 #endif
6369       if (lprn) then
6370         write (iout,'(a)') 'Contact function values:'
6371         do i=nnt,nct-2
6372           write (iout,'(2i3,50(1x,i3,f5.2))')
6373      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6374      &    j=1,num_cont_hb(i))
6375         enddo
6376       endif
6377       ecorr=0.0D0
6378 C Remove the loop below after debugging !!!
6379       do i=nnt,nct
6380         do j=1,3
6381           gradcorr(j,i)=0.0D0
6382           gradxorr(j,i)=0.0D0
6383         enddo
6384       enddo
6385 C Calculate the local-electrostatic correlation terms
6386       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6387         i1=i+1
6388         num_conti=num_cont_hb(i)
6389         num_conti1=num_cont_hb(i+1)
6390         do jj=1,num_conti
6391           j=jcont_hb(jj,i)
6392           jp=iabs(j)
6393           do kk=1,num_conti1
6394             j1=jcont_hb(kk,i1)
6395             jp1=iabs(j1)
6396 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6397 c     &         ' jj=',jj,' kk=',kk
6398             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6399      &          .or. j.lt.0 .and. j1.gt.0) .and.
6400      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6401 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6402 C The system gains extra energy.
6403               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6404               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6405      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6406               n_corr=n_corr+1
6407             else if (j1.eq.j) then
6408 C Contacts I-J and I-(J+1) occur simultaneously.
6409 C The system loses extra energy.
6410 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6411             endif
6412           enddo ! kk
6413           do kk=1,num_conti
6414             j1=jcont_hb(kk,i)
6415 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6416 c    &         ' jj=',jj,' kk=',kk
6417             if (j1.eq.j+1) then
6418 C Contacts I-J and (I+1)-J occur simultaneously.
6419 C The system loses extra energy.
6420 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6421             endif ! j1==j+1
6422           enddo ! kk
6423         enddo ! jj
6424       enddo ! i
6425       return
6426       end
6427 c------------------------------------------------------------------------------
6428       subroutine add_hb_contact(ii,jj,itask)
6429       implicit real*8 (a-h,o-z)
6430       include "DIMENSIONS"
6431       include "COMMON.IOUNITS"
6432       integer max_cont
6433       integer max_dim
6434       parameter (max_cont=maxconts)
6435       parameter (max_dim=26)
6436       include "COMMON.CONTACTS"
6437       double precision zapas(max_dim,maxconts,max_fg_procs),
6438      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6439       common /przechowalnia/ zapas
6440       integer i,j,ii,jj,iproc,itask(4),nn
6441 c      write (iout,*) "itask",itask
6442       do i=1,2
6443         iproc=itask(i)
6444         if (iproc.gt.0) then
6445           do j=1,num_cont_hb(ii)
6446             jjc=jcont_hb(j,ii)
6447 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6448             if (jjc.eq.jj) then
6449               ncont_sent(iproc)=ncont_sent(iproc)+1
6450               nn=ncont_sent(iproc)
6451               zapas(1,nn,iproc)=ii
6452               zapas(2,nn,iproc)=jjc
6453               zapas(3,nn,iproc)=facont_hb(j,ii)
6454               zapas(4,nn,iproc)=ees0p(j,ii)
6455               zapas(5,nn,iproc)=ees0m(j,ii)
6456               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6457               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6458               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6459               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6460               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6461               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6462               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6463               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6464               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6465               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6466               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6467               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6468               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6469               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6470               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6471               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6472               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6473               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6474               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6475               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6476               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6477               exit
6478             endif
6479           enddo
6480         endif
6481       enddo
6482       return
6483       end
6484 c------------------------------------------------------------------------------
6485       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6486      &  n_corr1)
6487 C This subroutine calculates multi-body contributions to hydrogen-bonding
6488       implicit real*8 (a-h,o-z)
6489       include 'DIMENSIONS'
6490       include 'COMMON.IOUNITS'
6491 #ifdef MPI
6492       include "mpif.h"
6493       parameter (max_cont=maxconts)
6494       parameter (max_dim=70)
6495       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6496       double precision zapas(max_dim,maxconts,max_fg_procs),
6497      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6498       common /przechowalnia/ zapas
6499       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6500      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6501 #endif
6502       include 'COMMON.SETUP'
6503       include 'COMMON.FFIELD'
6504       include 'COMMON.DERIV'
6505       include 'COMMON.LOCAL'
6506       include 'COMMON.INTERACT'
6507       include 'COMMON.CONTACTS'
6508       include 'COMMON.CHAIN'
6509       include 'COMMON.CONTROL'
6510       double precision gx(3),gx1(3)
6511       integer num_cont_hb_old(maxres)
6512       logical lprn,ldone
6513       double precision eello4,eello5,eelo6,eello_turn6
6514       external eello4,eello5,eello6,eello_turn6
6515 C Set lprn=.true. for debugging
6516       lprn=.false.
6517       eturn6=0.0d0
6518 #ifdef MPI
6519       do i=1,nres
6520         num_cont_hb_old(i)=num_cont_hb(i)
6521       enddo
6522       n_corr=0
6523       n_corr1=0
6524       if (nfgtasks.le.1) goto 30
6525       if (lprn) then
6526         write (iout,'(a)') 'Contact function values before RECEIVE:'
6527         do i=nnt,nct-2
6528           write (iout,'(2i3,50(1x,i2,f5.2))')
6529      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6530      &    j=1,num_cont_hb(i))
6531         enddo
6532       endif
6533       call flush(iout)
6534       do i=1,ntask_cont_from
6535         ncont_recv(i)=0
6536       enddo
6537       do i=1,ntask_cont_to
6538         ncont_sent(i)=0
6539       enddo
6540 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6541 c     & ntask_cont_to
6542 C Make the list of contacts to send to send to other procesors
6543       do i=iturn3_start,iturn3_end
6544 c        write (iout,*) "make contact list turn3",i," num_cont",
6545 c     &    num_cont_hb(i)
6546         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6547       enddo
6548       do i=iturn4_start,iturn4_end
6549 c        write (iout,*) "make contact list turn4",i," num_cont",
6550 c     &   num_cont_hb(i)
6551         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6552       enddo
6553       do ii=1,nat_sent
6554         i=iat_sent(ii)
6555 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6556 c     &    num_cont_hb(i)
6557         do j=1,num_cont_hb(i)
6558         do k=1,4
6559           jjc=jcont_hb(j,i)
6560           iproc=iint_sent_local(k,jjc,ii)
6561 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6562           if (iproc.ne.0) then
6563             ncont_sent(iproc)=ncont_sent(iproc)+1
6564             nn=ncont_sent(iproc)
6565             zapas(1,nn,iproc)=i
6566             zapas(2,nn,iproc)=jjc
6567             zapas(3,nn,iproc)=d_cont(j,i)
6568             ind=3
6569             do kk=1,3
6570               ind=ind+1
6571               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6572             enddo
6573             do kk=1,2
6574               do ll=1,2
6575                 ind=ind+1
6576                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6577               enddo
6578             enddo
6579             do jj=1,5
6580               do kk=1,3
6581                 do ll=1,2
6582                   do mm=1,2
6583                     ind=ind+1
6584                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6585                   enddo
6586                 enddo
6587               enddo
6588             enddo
6589           endif
6590         enddo
6591         enddo
6592       enddo
6593       if (lprn) then
6594       write (iout,*)
6595      &  "Numbers of contacts to be sent to other processors",
6596      &  (ncont_sent(i),i=1,ntask_cont_to)
6597       write (iout,*) "Contacts sent"
6598       do ii=1,ntask_cont_to
6599         nn=ncont_sent(ii)
6600         iproc=itask_cont_to(ii)
6601         write (iout,*) nn," contacts to processor",iproc,
6602      &   " of CONT_TO_COMM group"
6603         do i=1,nn
6604           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6605         enddo
6606       enddo
6607       call flush(iout)
6608       endif
6609       CorrelType=477
6610       CorrelID=fg_rank+1
6611       CorrelType1=478
6612       CorrelID1=nfgtasks+fg_rank+1
6613       ireq=0
6614 C Receive the numbers of needed contacts from other processors
6615       do ii=1,ntask_cont_from
6616         iproc=itask_cont_from(ii)
6617         ireq=ireq+1
6618         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6619      &    FG_COMM,req(ireq),IERR)
6620       enddo
6621 c      write (iout,*) "IRECV ended"
6622 c      call flush(iout)
6623 C Send the number of contacts needed by other processors
6624       do ii=1,ntask_cont_to
6625         iproc=itask_cont_to(ii)
6626         ireq=ireq+1
6627         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6628      &    FG_COMM,req(ireq),IERR)
6629       enddo
6630 c      write (iout,*) "ISEND ended"
6631 c      write (iout,*) "number of requests (nn)",ireq
6632       call flush(iout)
6633       if (ireq.gt.0)
6634      &  call MPI_Waitall(ireq,req,status_array,ierr)
6635 c      write (iout,*)
6636 c     &  "Numbers of contacts to be received from other processors",
6637 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6638 c      call flush(iout)
6639 C Receive contacts
6640       ireq=0
6641       do ii=1,ntask_cont_from
6642         iproc=itask_cont_from(ii)
6643         nn=ncont_recv(ii)
6644 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6645 c     &   " of CONT_TO_COMM group"
6646         call flush(iout)
6647         if (nn.gt.0) then
6648           ireq=ireq+1
6649           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6650      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6651 c          write (iout,*) "ireq,req",ireq,req(ireq)
6652         endif
6653       enddo
6654 C Send the contacts to processors that need them
6655       do ii=1,ntask_cont_to
6656         iproc=itask_cont_to(ii)
6657         nn=ncont_sent(ii)
6658 c        write (iout,*) nn," contacts to processor",iproc,
6659 c     &   " of CONT_TO_COMM group"
6660         if (nn.gt.0) then
6661           ireq=ireq+1
6662           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6663      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6664 c          write (iout,*) "ireq,req",ireq,req(ireq)
6665 c          do i=1,nn
6666 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6667 c          enddo
6668         endif
6669       enddo
6670 c      write (iout,*) "number of requests (contacts)",ireq
6671 c      write (iout,*) "req",(req(i),i=1,4)
6672 c      call flush(iout)
6673       if (ireq.gt.0)
6674      & call MPI_Waitall(ireq,req,status_array,ierr)
6675       do iii=1,ntask_cont_from
6676         iproc=itask_cont_from(iii)
6677         nn=ncont_recv(iii)
6678         if (lprn) then
6679         write (iout,*) "Received",nn," contacts from processor",iproc,
6680      &   " of CONT_FROM_COMM group"
6681         call flush(iout)
6682         do i=1,nn
6683           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6684         enddo
6685         call flush(iout)
6686         endif
6687         do i=1,nn
6688           ii=zapas_recv(1,i,iii)
6689 c Flag the received contacts to prevent double-counting
6690           jj=-zapas_recv(2,i,iii)
6691 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6692 c          call flush(iout)
6693           nnn=num_cont_hb(ii)+1
6694           num_cont_hb(ii)=nnn
6695           jcont_hb(nnn,ii)=jj
6696           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6697           ind=3
6698           do kk=1,3
6699             ind=ind+1
6700             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6701           enddo
6702           do kk=1,2
6703             do ll=1,2
6704               ind=ind+1
6705               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6706             enddo
6707           enddo
6708           do jj=1,5
6709             do kk=1,3
6710               do ll=1,2
6711                 do mm=1,2
6712                   ind=ind+1
6713                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6714                 enddo
6715               enddo
6716             enddo
6717           enddo
6718         enddo
6719       enddo
6720       call flush(iout)
6721       if (lprn) then
6722         write (iout,'(a)') 'Contact function values after receive:'
6723         do i=nnt,nct-2
6724           write (iout,'(2i3,50(1x,i3,5f6.3))')
6725      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6726      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6727         enddo
6728         call flush(iout)
6729       endif
6730    30 continue
6731 #endif
6732       if (lprn) then
6733         write (iout,'(a)') 'Contact function values:'
6734         do i=nnt,nct-2
6735           write (iout,'(2i3,50(1x,i2,5f6.3))')
6736      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6737      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6738         enddo
6739       endif
6740       ecorr=0.0D0
6741       ecorr5=0.0d0
6742       ecorr6=0.0d0
6743 C Remove the loop below after debugging !!!
6744       do i=nnt,nct
6745         do j=1,3
6746           gradcorr(j,i)=0.0D0
6747           gradxorr(j,i)=0.0D0
6748         enddo
6749       enddo
6750 C Calculate the dipole-dipole interaction energies
6751       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6752       do i=iatel_s,iatel_e+1
6753         num_conti=num_cont_hb(i)
6754         do jj=1,num_conti
6755           j=jcont_hb(jj,i)
6756 #ifdef MOMENT
6757           call dipole(i,j,jj)
6758 #endif
6759         enddo
6760       enddo
6761       endif
6762 C Calculate the local-electrostatic correlation terms
6763 c                write (iout,*) "gradcorr5 in eello5 before loop"
6764 c                do iii=1,nres
6765 c                  write (iout,'(i5,3f10.5)')
6766 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6767 c                enddo
6768       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6769 c        write (iout,*) "corr loop i",i
6770         i1=i+1
6771         num_conti=num_cont_hb(i)
6772         num_conti1=num_cont_hb(i+1)
6773         do jj=1,num_conti
6774           j=jcont_hb(jj,i)
6775           jp=iabs(j)
6776           do kk=1,num_conti1
6777             j1=jcont_hb(kk,i1)
6778             jp1=iabs(j1)
6779 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6780 c     &         ' jj=',jj,' kk=',kk
6781 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6782             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6783      &          .or. j.lt.0 .and. j1.gt.0) .and.
6784      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6785 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6786 C The system gains extra energy.
6787               n_corr=n_corr+1
6788               sqd1=dsqrt(d_cont(jj,i))
6789               sqd2=dsqrt(d_cont(kk,i1))
6790               sred_geom = sqd1*sqd2
6791               IF (sred_geom.lt.cutoff_corr) THEN
6792                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6793      &            ekont,fprimcont)
6794 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6795 cd     &         ' jj=',jj,' kk=',kk
6796                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6797                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6798                 do l=1,3
6799                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6800                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6801                 enddo
6802                 n_corr1=n_corr1+1
6803 cd               write (iout,*) 'sred_geom=',sred_geom,
6804 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6805 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6806 cd               write (iout,*) "g_contij",g_contij
6807 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6808 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6809                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6810                 if (wcorr4.gt.0.0d0)
6811      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6812                   if (energy_dec.and.wcorr4.gt.0.0d0)
6813      1                 write (iout,'(a6,4i5,0pf7.3)')
6814      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6815 c                write (iout,*) "gradcorr5 before eello5"
6816 c                do iii=1,nres
6817 c                  write (iout,'(i5,3f10.5)')
6818 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6819 c                enddo
6820                 if (wcorr5.gt.0.0d0)
6821      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6822 c                write (iout,*) "gradcorr5 after eello5"
6823 c                do iii=1,nres
6824 c                  write (iout,'(i5,3f10.5)')
6825 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6826 c                enddo
6827                   if (energy_dec.and.wcorr5.gt.0.0d0)
6828      1                 write (iout,'(a6,4i5,0pf7.3)')
6829      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6830 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6831 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6832                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6833      &               .or. wturn6.eq.0.0d0))then
6834 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6835                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6836                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6837      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6838 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6839 cd     &            'ecorr6=',ecorr6
6840 cd                write (iout,'(4e15.5)') sred_geom,
6841 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6842 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6843 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6844                 else if (wturn6.gt.0.0d0
6845      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6846 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6847                   eturn6=eturn6+eello_turn6(i,jj,kk)
6848                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6849      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6850 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6851                 endif
6852               ENDIF
6853 1111          continue
6854             endif
6855           enddo ! kk
6856         enddo ! jj
6857       enddo ! i
6858       do i=1,nres
6859         num_cont_hb(i)=num_cont_hb_old(i)
6860       enddo
6861 c                write (iout,*) "gradcorr5 in eello5"
6862 c                do iii=1,nres
6863 c                  write (iout,'(i5,3f10.5)')
6864 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6865 c                enddo
6866       return
6867       end
6868 c------------------------------------------------------------------------------
6869       subroutine add_hb_contact_eello(ii,jj,itask)
6870       implicit real*8 (a-h,o-z)
6871       include "DIMENSIONS"
6872       include "COMMON.IOUNITS"
6873       integer max_cont
6874       integer max_dim
6875       parameter (max_cont=maxconts)
6876       parameter (max_dim=70)
6877       include "COMMON.CONTACTS"
6878       double precision zapas(max_dim,maxconts,max_fg_procs),
6879      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6880       common /przechowalnia/ zapas
6881       integer i,j,ii,jj,iproc,itask(4),nn
6882 c      write (iout,*) "itask",itask
6883       do i=1,2
6884         iproc=itask(i)
6885         if (iproc.gt.0) then
6886           do j=1,num_cont_hb(ii)
6887             jjc=jcont_hb(j,ii)
6888 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6889             if (jjc.eq.jj) then
6890               ncont_sent(iproc)=ncont_sent(iproc)+1
6891               nn=ncont_sent(iproc)
6892               zapas(1,nn,iproc)=ii
6893               zapas(2,nn,iproc)=jjc
6894               zapas(3,nn,iproc)=d_cont(j,ii)
6895               ind=3
6896               do kk=1,3
6897                 ind=ind+1
6898                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6899               enddo
6900               do kk=1,2
6901                 do ll=1,2
6902                   ind=ind+1
6903                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6904                 enddo
6905               enddo
6906               do jj=1,5
6907                 do kk=1,3
6908                   do ll=1,2
6909                     do mm=1,2
6910                       ind=ind+1
6911                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6912                     enddo
6913                   enddo
6914                 enddo
6915               enddo
6916               exit
6917             endif
6918           enddo
6919         endif
6920       enddo
6921       return
6922       end
6923 c------------------------------------------------------------------------------
6924       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6925       implicit real*8 (a-h,o-z)
6926       include 'DIMENSIONS'
6927       include 'COMMON.IOUNITS'
6928       include 'COMMON.DERIV'
6929       include 'COMMON.INTERACT'
6930       include 'COMMON.CONTACTS'
6931       double precision gx(3),gx1(3)
6932       logical lprn
6933       lprn=.false.
6934       eij=facont_hb(jj,i)
6935       ekl=facont_hb(kk,k)
6936       ees0pij=ees0p(jj,i)
6937       ees0pkl=ees0p(kk,k)
6938       ees0mij=ees0m(jj,i)
6939       ees0mkl=ees0m(kk,k)
6940       ekont=eij*ekl
6941       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6942 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6943 C Following 4 lines for diagnostics.
6944 cd    ees0pkl=0.0D0
6945 cd    ees0pij=1.0D0
6946 cd    ees0mkl=0.0D0
6947 cd    ees0mij=1.0D0
6948 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6949 c     & 'Contacts ',i,j,
6950 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6951 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6952 c     & 'gradcorr_long'
6953 C Calculate the multi-body contribution to energy.
6954 c      ecorr=ecorr+ekont*ees
6955 C Calculate multi-body contributions to the gradient.
6956       coeffpees0pij=coeffp*ees0pij
6957       coeffmees0mij=coeffm*ees0mij
6958       coeffpees0pkl=coeffp*ees0pkl
6959       coeffmees0mkl=coeffm*ees0mkl
6960       do ll=1,3
6961 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6962         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6963      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6964      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6965         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6966      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6967      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6968 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6969         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6970      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6971      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6972         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6973      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6974      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6975         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6976      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6977      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6978         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6979         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6980         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6981      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6982      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6983         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6984         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6985 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6986       enddo
6987 c      write (iout,*)
6988 cgrad      do m=i+1,j-1
6989 cgrad        do ll=1,3
6990 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6991 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6992 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6993 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6994 cgrad        enddo
6995 cgrad      enddo
6996 cgrad      do m=k+1,l-1
6997 cgrad        do ll=1,3
6998 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6999 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7000 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7001 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7002 cgrad        enddo
7003 cgrad      enddo
7004 c      write (iout,*) "ehbcorr",ekont*ees
7005       ehbcorr=ekont*ees
7006       return
7007       end
7008 #ifdef MOMENT
7009 C---------------------------------------------------------------------------
7010       subroutine dipole(i,j,jj)
7011       implicit real*8 (a-h,o-z)
7012       include 'DIMENSIONS'
7013       include 'COMMON.IOUNITS'
7014       include 'COMMON.CHAIN'
7015       include 'COMMON.FFIELD'
7016       include 'COMMON.DERIV'
7017       include 'COMMON.INTERACT'
7018       include 'COMMON.CONTACTS'
7019       include 'COMMON.TORSION'
7020       include 'COMMON.VAR'
7021       include 'COMMON.GEO'
7022       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7023      &  auxmat(2,2)
7024       iti1 = itortyp(itype(i+1))
7025       if (j.lt.nres-1) then
7026         itj1 = itortyp(itype(j+1))
7027       else
7028         itj1=ntortyp+1
7029       endif
7030       do iii=1,2
7031         dipi(iii,1)=Ub2(iii,i)
7032         dipderi(iii)=Ub2der(iii,i)
7033         dipi(iii,2)=b1(iii,iti1)
7034         dipj(iii,1)=Ub2(iii,j)
7035         dipderj(iii)=Ub2der(iii,j)
7036         dipj(iii,2)=b1(iii,itj1)
7037       enddo
7038       kkk=0
7039       do iii=1,2
7040         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7041         do jjj=1,2
7042           kkk=kkk+1
7043           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7044         enddo
7045       enddo
7046       do kkk=1,5
7047         do lll=1,3
7048           mmm=0
7049           do iii=1,2
7050             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7051      &        auxvec(1))
7052             do jjj=1,2
7053               mmm=mmm+1
7054               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7055             enddo
7056           enddo
7057         enddo
7058       enddo
7059       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7060       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7061       do iii=1,2
7062         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7063       enddo
7064       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7065       do iii=1,2
7066         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7067       enddo
7068       return
7069       end
7070 #endif
7071 C---------------------------------------------------------------------------
7072       subroutine calc_eello(i,j,k,l,jj,kk)
7073 C
7074 C This subroutine computes matrices and vectors needed to calculate
7075 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7076 C
7077       implicit real*8 (a-h,o-z)
7078       include 'DIMENSIONS'
7079       include 'COMMON.IOUNITS'
7080       include 'COMMON.CHAIN'
7081       include 'COMMON.DERIV'
7082       include 'COMMON.INTERACT'
7083       include 'COMMON.CONTACTS'
7084       include 'COMMON.TORSION'
7085       include 'COMMON.VAR'
7086       include 'COMMON.GEO'
7087       include 'COMMON.FFIELD'
7088       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7089      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7090       logical lprn
7091       common /kutas/ lprn
7092 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7093 cd     & ' jj=',jj,' kk=',kk
7094 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7095 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7096 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7097       do iii=1,2
7098         do jjj=1,2
7099           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7100           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7101         enddo
7102       enddo
7103       call transpose2(aa1(1,1),aa1t(1,1))
7104       call transpose2(aa2(1,1),aa2t(1,1))
7105       do kkk=1,5
7106         do lll=1,3
7107           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7108      &      aa1tder(1,1,lll,kkk))
7109           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7110      &      aa2tder(1,1,lll,kkk))
7111         enddo
7112       enddo
7113       if (l.eq.j+1) then
7114 C parallel orientation of the two CA-CA-CA frames.
7115         if (i.gt.1) then
7116           iti=itortyp(itype(i))
7117         else
7118           iti=ntortyp+1
7119         endif
7120         itk1=itortyp(itype(k+1))
7121         itj=itortyp(itype(j))
7122         if (l.lt.nres-1) then
7123           itl1=itortyp(itype(l+1))
7124         else
7125           itl1=ntortyp+1
7126         endif
7127 C A1 kernel(j+1) A2T
7128 cd        do iii=1,2
7129 cd          write (iout,'(3f10.5,5x,3f10.5)')
7130 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7131 cd        enddo
7132         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7133      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7134      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7135 C Following matrices are needed only for 6-th order cumulants
7136         IF (wcorr6.gt.0.0d0) THEN
7137         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7138      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7139      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7140         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7141      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7142      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7143      &   ADtEAderx(1,1,1,1,1,1))
7144         lprn=.false.
7145         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7146      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7147      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7148      &   ADtEA1derx(1,1,1,1,1,1))
7149         ENDIF
7150 C End 6-th order cumulants
7151 cd        lprn=.false.
7152 cd        if (lprn) then
7153 cd        write (2,*) 'In calc_eello6'
7154 cd        do iii=1,2
7155 cd          write (2,*) 'iii=',iii
7156 cd          do kkk=1,5
7157 cd            write (2,*) 'kkk=',kkk
7158 cd            do jjj=1,2
7159 cd              write (2,'(3(2f10.5),5x)')
7160 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7161 cd            enddo
7162 cd          enddo
7163 cd        enddo
7164 cd        endif
7165         call transpose2(EUgder(1,1,k),auxmat(1,1))
7166         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7167         call transpose2(EUg(1,1,k),auxmat(1,1))
7168         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7169         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7170         do iii=1,2
7171           do kkk=1,5
7172             do lll=1,3
7173               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7174      &          EAEAderx(1,1,lll,kkk,iii,1))
7175             enddo
7176           enddo
7177         enddo
7178 C A1T kernel(i+1) A2
7179         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7180      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7181      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7182 C Following matrices are needed only for 6-th order cumulants
7183         IF (wcorr6.gt.0.0d0) THEN
7184         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7185      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7186      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7187         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7188      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7189      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7190      &   ADtEAderx(1,1,1,1,1,2))
7191         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7192      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7193      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7194      &   ADtEA1derx(1,1,1,1,1,2))
7195         ENDIF
7196 C End 6-th order cumulants
7197         call transpose2(EUgder(1,1,l),auxmat(1,1))
7198         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7199         call transpose2(EUg(1,1,l),auxmat(1,1))
7200         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7201         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7202         do iii=1,2
7203           do kkk=1,5
7204             do lll=1,3
7205               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7206      &          EAEAderx(1,1,lll,kkk,iii,2))
7207             enddo
7208           enddo
7209         enddo
7210 C AEAb1 and AEAb2
7211 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7212 C They are needed only when the fifth- or the sixth-order cumulants are
7213 C indluded.
7214         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7215         call transpose2(AEA(1,1,1),auxmat(1,1))
7216         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7217         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7218         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7219         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7220         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7221         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7222         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7223         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7224         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7225         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7226         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7227         call transpose2(AEA(1,1,2),auxmat(1,1))
7228         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7229         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7230         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7231         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7232         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7233         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7234         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7235         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7236         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7237         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7238         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7239 C Calculate the Cartesian derivatives of the vectors.
7240         do iii=1,2
7241           do kkk=1,5
7242             do lll=1,3
7243               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7244               call matvec2(auxmat(1,1),b1(1,iti),
7245      &          AEAb1derx(1,lll,kkk,iii,1,1))
7246               call matvec2(auxmat(1,1),Ub2(1,i),
7247      &          AEAb2derx(1,lll,kkk,iii,1,1))
7248               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7249      &          AEAb1derx(1,lll,kkk,iii,2,1))
7250               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7251      &          AEAb2derx(1,lll,kkk,iii,2,1))
7252               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7253               call matvec2(auxmat(1,1),b1(1,itj),
7254      &          AEAb1derx(1,lll,kkk,iii,1,2))
7255               call matvec2(auxmat(1,1),Ub2(1,j),
7256      &          AEAb2derx(1,lll,kkk,iii,1,2))
7257               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7258      &          AEAb1derx(1,lll,kkk,iii,2,2))
7259               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7260      &          AEAb2derx(1,lll,kkk,iii,2,2))
7261             enddo
7262           enddo
7263         enddo
7264         ENDIF
7265 C End vectors
7266       else
7267 C Antiparallel orientation of the two CA-CA-CA frames.
7268         if (i.gt.1) then
7269           iti=itortyp(itype(i))
7270         else
7271           iti=ntortyp+1
7272         endif
7273         itk1=itortyp(itype(k+1))
7274         itl=itortyp(itype(l))
7275         itj=itortyp(itype(j))
7276         if (j.lt.nres-1) then
7277           itj1=itortyp(itype(j+1))
7278         else
7279           itj1=ntortyp+1
7280         endif
7281 C A2 kernel(j-1)T A1T
7282         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7283      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7284      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7285 C Following matrices are needed only for 6-th order cumulants
7286         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7287      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7288         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7289      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7290      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7291         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7292      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7293      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7294      &   ADtEAderx(1,1,1,1,1,1))
7295         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7296      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7297      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7298      &   ADtEA1derx(1,1,1,1,1,1))
7299         ENDIF
7300 C End 6-th order cumulants
7301         call transpose2(EUgder(1,1,k),auxmat(1,1))
7302         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7303         call transpose2(EUg(1,1,k),auxmat(1,1))
7304         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7305         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7306         do iii=1,2
7307           do kkk=1,5
7308             do lll=1,3
7309               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7310      &          EAEAderx(1,1,lll,kkk,iii,1))
7311             enddo
7312           enddo
7313         enddo
7314 C A2T kernel(i+1)T A1
7315         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7316      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7317      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7318 C Following matrices are needed only for 6-th order cumulants
7319         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7320      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7321         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7322      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7323      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7324         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7325      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7326      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7327      &   ADtEAderx(1,1,1,1,1,2))
7328         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7329      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7330      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7331      &   ADtEA1derx(1,1,1,1,1,2))
7332         ENDIF
7333 C End 6-th order cumulants
7334         call transpose2(EUgder(1,1,j),auxmat(1,1))
7335         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7336         call transpose2(EUg(1,1,j),auxmat(1,1))
7337         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7338         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7339         do iii=1,2
7340           do kkk=1,5
7341             do lll=1,3
7342               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7343      &          EAEAderx(1,1,lll,kkk,iii,2))
7344             enddo
7345           enddo
7346         enddo
7347 C AEAb1 and AEAb2
7348 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7349 C They are needed only when the fifth- or the sixth-order cumulants are
7350 C indluded.
7351         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7352      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7353         call transpose2(AEA(1,1,1),auxmat(1,1))
7354         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7355         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7356         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7357         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7358         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7359         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7360         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7361         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7362         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7363         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7364         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7365         call transpose2(AEA(1,1,2),auxmat(1,1))
7366         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7367         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7368         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7369         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7370         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7371         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7372         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7373         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7374         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7375         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7376         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7377 C Calculate the Cartesian derivatives of the vectors.
7378         do iii=1,2
7379           do kkk=1,5
7380             do lll=1,3
7381               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7382               call matvec2(auxmat(1,1),b1(1,iti),
7383      &          AEAb1derx(1,lll,kkk,iii,1,1))
7384               call matvec2(auxmat(1,1),Ub2(1,i),
7385      &          AEAb2derx(1,lll,kkk,iii,1,1))
7386               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7387      &          AEAb1derx(1,lll,kkk,iii,2,1))
7388               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7389      &          AEAb2derx(1,lll,kkk,iii,2,1))
7390               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7391               call matvec2(auxmat(1,1),b1(1,itl),
7392      &          AEAb1derx(1,lll,kkk,iii,1,2))
7393               call matvec2(auxmat(1,1),Ub2(1,l),
7394      &          AEAb2derx(1,lll,kkk,iii,1,2))
7395               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7396      &          AEAb1derx(1,lll,kkk,iii,2,2))
7397               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7398      &          AEAb2derx(1,lll,kkk,iii,2,2))
7399             enddo
7400           enddo
7401         enddo
7402         ENDIF
7403 C End vectors
7404       endif
7405       return
7406       end
7407 C---------------------------------------------------------------------------
7408       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7409      &  KK,KKderg,AKA,AKAderg,AKAderx)
7410       implicit none
7411       integer nderg
7412       logical transp
7413       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7414      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7415      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7416       integer iii,kkk,lll
7417       integer jjj,mmm
7418       logical lprn
7419       common /kutas/ lprn
7420       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7421       do iii=1,nderg
7422         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7423      &    AKAderg(1,1,iii))
7424       enddo
7425 cd      if (lprn) write (2,*) 'In kernel'
7426       do kkk=1,5
7427 cd        if (lprn) write (2,*) 'kkk=',kkk
7428         do lll=1,3
7429           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7430      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7431 cd          if (lprn) then
7432 cd            write (2,*) 'lll=',lll
7433 cd            write (2,*) 'iii=1'
7434 cd            do jjj=1,2
7435 cd              write (2,'(3(2f10.5),5x)')
7436 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7437 cd            enddo
7438 cd          endif
7439           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7440      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7441 cd          if (lprn) then
7442 cd            write (2,*) 'lll=',lll
7443 cd            write (2,*) 'iii=2'
7444 cd            do jjj=1,2
7445 cd              write (2,'(3(2f10.5),5x)')
7446 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7447 cd            enddo
7448 cd          endif
7449         enddo
7450       enddo
7451       return
7452       end
7453 C---------------------------------------------------------------------------
7454       double precision function eello4(i,j,k,l,jj,kk)
7455       implicit real*8 (a-h,o-z)
7456       include 'DIMENSIONS'
7457       include 'COMMON.IOUNITS'
7458       include 'COMMON.CHAIN'
7459       include 'COMMON.DERIV'
7460       include 'COMMON.INTERACT'
7461       include 'COMMON.CONTACTS'
7462       include 'COMMON.TORSION'
7463       include 'COMMON.VAR'
7464       include 'COMMON.GEO'
7465       double precision pizda(2,2),ggg1(3),ggg2(3)
7466 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7467 cd        eello4=0.0d0
7468 cd        return
7469 cd      endif
7470 cd      print *,'eello4:',i,j,k,l,jj,kk
7471 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7472 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7473 cold      eij=facont_hb(jj,i)
7474 cold      ekl=facont_hb(kk,k)
7475 cold      ekont=eij*ekl
7476       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7477 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7478       gcorr_loc(k-1)=gcorr_loc(k-1)
7479      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7480       if (l.eq.j+1) then
7481         gcorr_loc(l-1)=gcorr_loc(l-1)
7482      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7483       else
7484         gcorr_loc(j-1)=gcorr_loc(j-1)
7485      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7486       endif
7487       do iii=1,2
7488         do kkk=1,5
7489           do lll=1,3
7490             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7491      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7492 cd            derx(lll,kkk,iii)=0.0d0
7493           enddo
7494         enddo
7495       enddo
7496 cd      gcorr_loc(l-1)=0.0d0
7497 cd      gcorr_loc(j-1)=0.0d0
7498 cd      gcorr_loc(k-1)=0.0d0
7499 cd      eel4=1.0d0
7500 cd      write (iout,*)'Contacts have occurred for peptide groups',
7501 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7502 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7503       if (j.lt.nres-1) then
7504         j1=j+1
7505         j2=j-1
7506       else
7507         j1=j-1
7508         j2=j-2
7509       endif
7510       if (l.lt.nres-1) then
7511         l1=l+1
7512         l2=l-1
7513       else
7514         l1=l-1
7515         l2=l-2
7516       endif
7517       do ll=1,3
7518 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7519 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7520         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7521         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7522 cgrad        ghalf=0.5d0*ggg1(ll)
7523         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7524         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7525         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7526         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7527         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7528         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7529 cgrad        ghalf=0.5d0*ggg2(ll)
7530         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7531         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7532         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7533         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7534         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7535         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7536       enddo
7537 cgrad      do m=i+1,j-1
7538 cgrad        do ll=1,3
7539 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7540 cgrad        enddo
7541 cgrad      enddo
7542 cgrad      do m=k+1,l-1
7543 cgrad        do ll=1,3
7544 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7545 cgrad        enddo
7546 cgrad      enddo
7547 cgrad      do m=i+2,j2
7548 cgrad        do ll=1,3
7549 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7550 cgrad        enddo
7551 cgrad      enddo
7552 cgrad      do m=k+2,l2
7553 cgrad        do ll=1,3
7554 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7555 cgrad        enddo
7556 cgrad      enddo
7557 cd      do iii=1,nres-3
7558 cd        write (2,*) iii,gcorr_loc(iii)
7559 cd      enddo
7560       eello4=ekont*eel4
7561 cd      write (2,*) 'ekont',ekont
7562 cd      write (iout,*) 'eello4',ekont*eel4
7563       return
7564       end
7565 C---------------------------------------------------------------------------
7566       double precision function eello5(i,j,k,l,jj,kk)
7567       implicit real*8 (a-h,o-z)
7568       include 'DIMENSIONS'
7569       include 'COMMON.IOUNITS'
7570       include 'COMMON.CHAIN'
7571       include 'COMMON.DERIV'
7572       include 'COMMON.INTERACT'
7573       include 'COMMON.CONTACTS'
7574       include 'COMMON.TORSION'
7575       include 'COMMON.VAR'
7576       include 'COMMON.GEO'
7577       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7578       double precision ggg1(3),ggg2(3)
7579 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7580 C                                                                              C
7581 C                            Parallel chains                                   C
7582 C                                                                              C
7583 C          o             o                   o             o                   C
7584 C         /l\           / \             \   / \           / \   /              C
7585 C        /   \         /   \             \ /   \         /   \ /               C
7586 C       j| o |l1       | o |              o| o |         | o |o                C
7587 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7588 C      \i/   \         /   \ /             /   \         /   \                 C
7589 C       o    k1             o                                                  C
7590 C         (I)          (II)                (III)          (IV)                 C
7591 C                                                                              C
7592 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7593 C                                                                              C
7594 C                            Antiparallel chains                               C
7595 C                                                                              C
7596 C          o             o                   o             o                   C
7597 C         /j\           / \             \   / \           / \   /              C
7598 C        /   \         /   \             \ /   \         /   \ /               C
7599 C      j1| o |l        | o |              o| o |         | o |o                C
7600 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7601 C      \i/   \         /   \ /             /   \         /   \                 C
7602 C       o     k1            o                                                  C
7603 C         (I)          (II)                (III)          (IV)                 C
7604 C                                                                              C
7605 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7606 C                                                                              C
7607 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7608 C                                                                              C
7609 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7610 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7611 cd        eello5=0.0d0
7612 cd        return
7613 cd      endif
7614 cd      write (iout,*)
7615 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7616 cd     &   ' and',k,l
7617       itk=itortyp(itype(k))
7618       itl=itortyp(itype(l))
7619       itj=itortyp(itype(j))
7620       eello5_1=0.0d0
7621       eello5_2=0.0d0
7622       eello5_3=0.0d0
7623       eello5_4=0.0d0
7624 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7625 cd     &   eel5_3_num,eel5_4_num)
7626       do iii=1,2
7627         do kkk=1,5
7628           do lll=1,3
7629             derx(lll,kkk,iii)=0.0d0
7630           enddo
7631         enddo
7632       enddo
7633 cd      eij=facont_hb(jj,i)
7634 cd      ekl=facont_hb(kk,k)
7635 cd      ekont=eij*ekl
7636 cd      write (iout,*)'Contacts have occurred for peptide groups',
7637 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7638 cd      goto 1111
7639 C Contribution from the graph I.
7640 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7641 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7642       call transpose2(EUg(1,1,k),auxmat(1,1))
7643       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7644       vv(1)=pizda(1,1)-pizda(2,2)
7645       vv(2)=pizda(1,2)+pizda(2,1)
7646       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7647      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7648 C Explicit gradient in virtual-dihedral angles.
7649       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7650      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7651      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7652       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7653       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7654       vv(1)=pizda(1,1)-pizda(2,2)
7655       vv(2)=pizda(1,2)+pizda(2,1)
7656       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7657      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7658      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7659       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7660       vv(1)=pizda(1,1)-pizda(2,2)
7661       vv(2)=pizda(1,2)+pizda(2,1)
7662       if (l.eq.j+1) then
7663         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7664      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7665      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7666       else
7667         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7668      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7669      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7670       endif
7671 C Cartesian gradient
7672       do iii=1,2
7673         do kkk=1,5
7674           do lll=1,3
7675             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7676      &        pizda(1,1))
7677             vv(1)=pizda(1,1)-pizda(2,2)
7678             vv(2)=pizda(1,2)+pizda(2,1)
7679             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7680      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7681      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7682           enddo
7683         enddo
7684       enddo
7685 c      goto 1112
7686 c1111  continue
7687 C Contribution from graph II
7688       call transpose2(EE(1,1,itk),auxmat(1,1))
7689       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7690       vv(1)=pizda(1,1)+pizda(2,2)
7691       vv(2)=pizda(2,1)-pizda(1,2)
7692       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7693      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7694 C Explicit gradient in virtual-dihedral angles.
7695       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7696      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7697       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7698       vv(1)=pizda(1,1)+pizda(2,2)
7699       vv(2)=pizda(2,1)-pizda(1,2)
7700       if (l.eq.j+1) then
7701         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7702      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7703      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7704       else
7705         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7706      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7707      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7708       endif
7709 C Cartesian gradient
7710       do iii=1,2
7711         do kkk=1,5
7712           do lll=1,3
7713             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7714      &        pizda(1,1))
7715             vv(1)=pizda(1,1)+pizda(2,2)
7716             vv(2)=pizda(2,1)-pizda(1,2)
7717             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7718      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7719      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7720           enddo
7721         enddo
7722       enddo
7723 cd      goto 1112
7724 cd1111  continue
7725       if (l.eq.j+1) then
7726 cd        goto 1110
7727 C Parallel orientation
7728 C Contribution from graph III
7729         call transpose2(EUg(1,1,l),auxmat(1,1))
7730         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7731         vv(1)=pizda(1,1)-pizda(2,2)
7732         vv(2)=pizda(1,2)+pizda(2,1)
7733         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7734      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7735 C Explicit gradient in virtual-dihedral angles.
7736         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7737      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7738      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7739         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7740         vv(1)=pizda(1,1)-pizda(2,2)
7741         vv(2)=pizda(1,2)+pizda(2,1)
7742         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7743      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7744      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7745         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7746         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7747         vv(1)=pizda(1,1)-pizda(2,2)
7748         vv(2)=pizda(1,2)+pizda(2,1)
7749         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7750      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7751      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7752 C Cartesian gradient
7753         do iii=1,2
7754           do kkk=1,5
7755             do lll=1,3
7756               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7757      &          pizda(1,1))
7758               vv(1)=pizda(1,1)-pizda(2,2)
7759               vv(2)=pizda(1,2)+pizda(2,1)
7760               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7761      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7762      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7763             enddo
7764           enddo
7765         enddo
7766 cd        goto 1112
7767 C Contribution from graph IV
7768 cd1110    continue
7769         call transpose2(EE(1,1,itl),auxmat(1,1))
7770         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7771         vv(1)=pizda(1,1)+pizda(2,2)
7772         vv(2)=pizda(2,1)-pizda(1,2)
7773         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7774      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7775 C Explicit gradient in virtual-dihedral angles.
7776         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7777      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7778         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7779         vv(1)=pizda(1,1)+pizda(2,2)
7780         vv(2)=pizda(2,1)-pizda(1,2)
7781         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7782      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7783      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7784 C Cartesian gradient
7785         do iii=1,2
7786           do kkk=1,5
7787             do lll=1,3
7788               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7789      &          pizda(1,1))
7790               vv(1)=pizda(1,1)+pizda(2,2)
7791               vv(2)=pizda(2,1)-pizda(1,2)
7792               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7793      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7794      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7795             enddo
7796           enddo
7797         enddo
7798       else
7799 C Antiparallel orientation
7800 C Contribution from graph III
7801 c        goto 1110
7802         call transpose2(EUg(1,1,j),auxmat(1,1))
7803         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7804         vv(1)=pizda(1,1)-pizda(2,2)
7805         vv(2)=pizda(1,2)+pizda(2,1)
7806         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7807      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7808 C Explicit gradient in virtual-dihedral angles.
7809         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7810      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7811      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7812         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7813         vv(1)=pizda(1,1)-pizda(2,2)
7814         vv(2)=pizda(1,2)+pizda(2,1)
7815         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7816      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7817      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7818         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7819         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7820         vv(1)=pizda(1,1)-pizda(2,2)
7821         vv(2)=pizda(1,2)+pizda(2,1)
7822         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7823      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7824      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7825 C Cartesian gradient
7826         do iii=1,2
7827           do kkk=1,5
7828             do lll=1,3
7829               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7830      &          pizda(1,1))
7831               vv(1)=pizda(1,1)-pizda(2,2)
7832               vv(2)=pizda(1,2)+pizda(2,1)
7833               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7834      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7835      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7836             enddo
7837           enddo
7838         enddo
7839 cd        goto 1112
7840 C Contribution from graph IV
7841 1110    continue
7842         call transpose2(EE(1,1,itj),auxmat(1,1))
7843         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7844         vv(1)=pizda(1,1)+pizda(2,2)
7845         vv(2)=pizda(2,1)-pizda(1,2)
7846         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7847      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7848 C Explicit gradient in virtual-dihedral angles.
7849         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7850      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7851         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7852         vv(1)=pizda(1,1)+pizda(2,2)
7853         vv(2)=pizda(2,1)-pizda(1,2)
7854         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7855      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7856      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7857 C Cartesian gradient
7858         do iii=1,2
7859           do kkk=1,5
7860             do lll=1,3
7861               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7862      &          pizda(1,1))
7863               vv(1)=pizda(1,1)+pizda(2,2)
7864               vv(2)=pizda(2,1)-pizda(1,2)
7865               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7866      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7867      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7868             enddo
7869           enddo
7870         enddo
7871       endif
7872 1112  continue
7873       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7874 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7875 cd        write (2,*) 'ijkl',i,j,k,l
7876 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7877 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7878 cd      endif
7879 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7880 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7881 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7882 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7883       if (j.lt.nres-1) then
7884         j1=j+1
7885         j2=j-1
7886       else
7887         j1=j-1
7888         j2=j-2
7889       endif
7890       if (l.lt.nres-1) then
7891         l1=l+1
7892         l2=l-1
7893       else
7894         l1=l-1
7895         l2=l-2
7896       endif
7897 cd      eij=1.0d0
7898 cd      ekl=1.0d0
7899 cd      ekont=1.0d0
7900 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7901 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7902 C        summed up outside the subrouine as for the other subroutines
7903 C        handling long-range interactions. The old code is commented out
7904 C        with "cgrad" to keep track of changes.
7905       do ll=1,3
7906 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7907 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7908         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7909         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7910 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7911 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7912 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7913 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7914 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7915 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7916 c     &   gradcorr5ij,
7917 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7918 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7919 cgrad        ghalf=0.5d0*ggg1(ll)
7920 cd        ghalf=0.0d0
7921         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7922         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7923         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7924         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7925         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7926         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7927 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7928 cgrad        ghalf=0.5d0*ggg2(ll)
7929 cd        ghalf=0.0d0
7930         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7931         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7932         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7933         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7934         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7935         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7936       enddo
7937 cd      goto 1112
7938 cgrad      do m=i+1,j-1
7939 cgrad        do ll=1,3
7940 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7941 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7942 cgrad        enddo
7943 cgrad      enddo
7944 cgrad      do m=k+1,l-1
7945 cgrad        do ll=1,3
7946 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7947 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7948 cgrad        enddo
7949 cgrad      enddo
7950 c1112  continue
7951 cgrad      do m=i+2,j2
7952 cgrad        do ll=1,3
7953 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7954 cgrad        enddo
7955 cgrad      enddo
7956 cgrad      do m=k+2,l2
7957 cgrad        do ll=1,3
7958 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7959 cgrad        enddo
7960 cgrad      enddo
7961 cd      do iii=1,nres-3
7962 cd        write (2,*) iii,g_corr5_loc(iii)
7963 cd      enddo
7964       eello5=ekont*eel5
7965 cd      write (2,*) 'ekont',ekont
7966 cd      write (iout,*) 'eello5',ekont*eel5
7967       return
7968       end
7969 c--------------------------------------------------------------------------
7970       double precision function eello6(i,j,k,l,jj,kk)
7971       implicit real*8 (a-h,o-z)
7972       include 'DIMENSIONS'
7973       include 'COMMON.IOUNITS'
7974       include 'COMMON.CHAIN'
7975       include 'COMMON.DERIV'
7976       include 'COMMON.INTERACT'
7977       include 'COMMON.CONTACTS'
7978       include 'COMMON.TORSION'
7979       include 'COMMON.VAR'
7980       include 'COMMON.GEO'
7981       include 'COMMON.FFIELD'
7982       double precision ggg1(3),ggg2(3)
7983 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7984 cd        eello6=0.0d0
7985 cd        return
7986 cd      endif
7987 cd      write (iout,*)
7988 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7989 cd     &   ' and',k,l
7990       eello6_1=0.0d0
7991       eello6_2=0.0d0
7992       eello6_3=0.0d0
7993       eello6_4=0.0d0
7994       eello6_5=0.0d0
7995       eello6_6=0.0d0
7996 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7997 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7998       do iii=1,2
7999         do kkk=1,5
8000           do lll=1,3
8001             derx(lll,kkk,iii)=0.0d0
8002           enddo
8003         enddo
8004       enddo
8005 cd      eij=facont_hb(jj,i)
8006 cd      ekl=facont_hb(kk,k)
8007 cd      ekont=eij*ekl
8008 cd      eij=1.0d0
8009 cd      ekl=1.0d0
8010 cd      ekont=1.0d0
8011       if (l.eq.j+1) then
8012         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8013         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8014         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8015         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8016         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8017         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8018       else
8019         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8020         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8021         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8022         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8023         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8024           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8025         else
8026           eello6_5=0.0d0
8027         endif
8028         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8029       endif
8030 C If turn contributions are considered, they will be handled separately.
8031       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8032 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8033 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8034 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8035 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8036 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8037 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8038 cd      goto 1112
8039       if (j.lt.nres-1) then
8040         j1=j+1
8041         j2=j-1
8042       else
8043         j1=j-1
8044         j2=j-2
8045       endif
8046       if (l.lt.nres-1) then
8047         l1=l+1
8048         l2=l-1
8049       else
8050         l1=l-1
8051         l2=l-2
8052       endif
8053       do ll=1,3
8054 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8055 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8056 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8057 cgrad        ghalf=0.5d0*ggg1(ll)
8058 cd        ghalf=0.0d0
8059         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8060         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8061         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8062         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8063         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8064         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8065         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8066         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8067 cgrad        ghalf=0.5d0*ggg2(ll)
8068 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8069 cd        ghalf=0.0d0
8070         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8071         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8072         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8073         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8074         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8075         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8076       enddo
8077 cd      goto 1112
8078 cgrad      do m=i+1,j-1
8079 cgrad        do ll=1,3
8080 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8081 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8082 cgrad        enddo
8083 cgrad      enddo
8084 cgrad      do m=k+1,l-1
8085 cgrad        do ll=1,3
8086 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8087 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8088 cgrad        enddo
8089 cgrad      enddo
8090 cgrad1112  continue
8091 cgrad      do m=i+2,j2
8092 cgrad        do ll=1,3
8093 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8094 cgrad        enddo
8095 cgrad      enddo
8096 cgrad      do m=k+2,l2
8097 cgrad        do ll=1,3
8098 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8099 cgrad        enddo
8100 cgrad      enddo
8101 cd      do iii=1,nres-3
8102 cd        write (2,*) iii,g_corr6_loc(iii)
8103 cd      enddo
8104       eello6=ekont*eel6
8105 cd      write (2,*) 'ekont',ekont
8106 cd      write (iout,*) 'eello6',ekont*eel6
8107       return
8108       end
8109 c--------------------------------------------------------------------------
8110       double precision function eello6_graph1(i,j,k,l,imat,swap)
8111       implicit real*8 (a-h,o-z)
8112       include 'DIMENSIONS'
8113       include 'COMMON.IOUNITS'
8114       include 'COMMON.CHAIN'
8115       include 'COMMON.DERIV'
8116       include 'COMMON.INTERACT'
8117       include 'COMMON.CONTACTS'
8118       include 'COMMON.TORSION'
8119       include 'COMMON.VAR'
8120       include 'COMMON.GEO'
8121       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8122       logical swap
8123       logical lprn
8124       common /kutas/ lprn
8125 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8126 C
8127 C      Parallel       Antiparallel
8128 C
8129 C          o             o
8130 C         /l\           /j\
8131 C        /   \         /   \
8132 C       /| o |         | o |\
8133 C     \ j|/k\|  /   \  |/k\|l /
8134 C      \ /   \ /     \ /   \ /
8135 C       o     o       o     o
8136 C       i             i
8137 C
8138 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8139       itk=itortyp(itype(k))
8140       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8141       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8142       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8143       call transpose2(EUgC(1,1,k),auxmat(1,1))
8144       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8145       vv1(1)=pizda1(1,1)-pizda1(2,2)
8146       vv1(2)=pizda1(1,2)+pizda1(2,1)
8147       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8148       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8149       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8150       s5=scalar2(vv(1),Dtobr2(1,i))
8151 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8152       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8153       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8154      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8155      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8156      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8157      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8158      & +scalar2(vv(1),Dtobr2der(1,i)))
8159       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8160       vv1(1)=pizda1(1,1)-pizda1(2,2)
8161       vv1(2)=pizda1(1,2)+pizda1(2,1)
8162       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8163       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8164       if (l.eq.j+1) then
8165         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8166      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8167      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8168      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8169      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8170       else
8171         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8172      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8173      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8174      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8175      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8176       endif
8177       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8178       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8179       vv1(1)=pizda1(1,1)-pizda1(2,2)
8180       vv1(2)=pizda1(1,2)+pizda1(2,1)
8181       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8182      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8183      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8184      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8185       do iii=1,2
8186         if (swap) then
8187           ind=3-iii
8188         else
8189           ind=iii
8190         endif
8191         do kkk=1,5
8192           do lll=1,3
8193             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8194             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8195             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8196             call transpose2(EUgC(1,1,k),auxmat(1,1))
8197             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8198      &        pizda1(1,1))
8199             vv1(1)=pizda1(1,1)-pizda1(2,2)
8200             vv1(2)=pizda1(1,2)+pizda1(2,1)
8201             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8202             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8203      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8204             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8205      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8206             s5=scalar2(vv(1),Dtobr2(1,i))
8207             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8208           enddo
8209         enddo
8210       enddo
8211       return
8212       end
8213 c----------------------------------------------------------------------------
8214       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8215       implicit real*8 (a-h,o-z)
8216       include 'DIMENSIONS'
8217       include 'COMMON.IOUNITS'
8218       include 'COMMON.CHAIN'
8219       include 'COMMON.DERIV'
8220       include 'COMMON.INTERACT'
8221       include 'COMMON.CONTACTS'
8222       include 'COMMON.TORSION'
8223       include 'COMMON.VAR'
8224       include 'COMMON.GEO'
8225       logical swap
8226       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8227      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8228       logical lprn
8229       common /kutas/ lprn
8230 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8231 C                                                                              C
8232 C      Parallel       Antiparallel                                             C
8233 C                                                                              C
8234 C          o             o                                                     C
8235 C     \   /l\           /j\   /                                                C
8236 C      \ /   \         /   \ /                                                 C
8237 C       o| o |         | o |o                                                  C
8238 C     \ j|/k\|      \  |/k\|l                                                  C
8239 C      \ /   \       \ /   \                                                   C
8240 C       o             o                                                        C
8241 C       i             i                                                        C
8242 C                                                                              C
8243 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8244 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8245 C AL 7/4/01 s1 would occur in the sixth-order moment,
8246 C           but not in a cluster cumulant
8247 #ifdef MOMENT
8248       s1=dip(1,jj,i)*dip(1,kk,k)
8249 #endif
8250       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8251       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8252       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8253       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8254       call transpose2(EUg(1,1,k),auxmat(1,1))
8255       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8256       vv(1)=pizda(1,1)-pizda(2,2)
8257       vv(2)=pizda(1,2)+pizda(2,1)
8258       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8259 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8260 #ifdef MOMENT
8261       eello6_graph2=-(s1+s2+s3+s4)
8262 #else
8263       eello6_graph2=-(s2+s3+s4)
8264 #endif
8265 c      eello6_graph2=-s3
8266 C Derivatives in gamma(i-1)
8267       if (i.gt.1) then
8268 #ifdef MOMENT
8269         s1=dipderg(1,jj,i)*dip(1,kk,k)
8270 #endif
8271         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8272         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8273         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8274         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8275 #ifdef MOMENT
8276         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8277 #else
8278         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8279 #endif
8280 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8281       endif
8282 C Derivatives in gamma(k-1)
8283 #ifdef MOMENT
8284       s1=dip(1,jj,i)*dipderg(1,kk,k)
8285 #endif
8286       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8287       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8288       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8289       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8290       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8291       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8292       vv(1)=pizda(1,1)-pizda(2,2)
8293       vv(2)=pizda(1,2)+pizda(2,1)
8294       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8295 #ifdef MOMENT
8296       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8297 #else
8298       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8299 #endif
8300 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8301 C Derivatives in gamma(j-1) or gamma(l-1)
8302       if (j.gt.1) then
8303 #ifdef MOMENT
8304         s1=dipderg(3,jj,i)*dip(1,kk,k)
8305 #endif
8306         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8307         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8308         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8309         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8310         vv(1)=pizda(1,1)-pizda(2,2)
8311         vv(2)=pizda(1,2)+pizda(2,1)
8312         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8313 #ifdef MOMENT
8314         if (swap) then
8315           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8316         else
8317           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8318         endif
8319 #endif
8320         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8321 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8322       endif
8323 C Derivatives in gamma(l-1) or gamma(j-1)
8324       if (l.gt.1) then
8325 #ifdef MOMENT
8326         s1=dip(1,jj,i)*dipderg(3,kk,k)
8327 #endif
8328         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8329         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8330         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8331         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8332         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8333         vv(1)=pizda(1,1)-pizda(2,2)
8334         vv(2)=pizda(1,2)+pizda(2,1)
8335         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8336 #ifdef MOMENT
8337         if (swap) then
8338           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8339         else
8340           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8341         endif
8342 #endif
8343         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8344 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8345       endif
8346 C Cartesian derivatives.
8347       if (lprn) then
8348         write (2,*) 'In eello6_graph2'
8349         do iii=1,2
8350           write (2,*) 'iii=',iii
8351           do kkk=1,5
8352             write (2,*) 'kkk=',kkk
8353             do jjj=1,2
8354               write (2,'(3(2f10.5),5x)')
8355      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8356             enddo
8357           enddo
8358         enddo
8359       endif
8360       do iii=1,2
8361         do kkk=1,5
8362           do lll=1,3
8363 #ifdef MOMENT
8364             if (iii.eq.1) then
8365               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8366             else
8367               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8368             endif
8369 #endif
8370             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8371      &        auxvec(1))
8372             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8373             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8374      &        auxvec(1))
8375             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8376             call transpose2(EUg(1,1,k),auxmat(1,1))
8377             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8378      &        pizda(1,1))
8379             vv(1)=pizda(1,1)-pizda(2,2)
8380             vv(2)=pizda(1,2)+pizda(2,1)
8381             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8382 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8383 #ifdef MOMENT
8384             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8385 #else
8386             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8387 #endif
8388             if (swap) then
8389               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8390             else
8391               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8392             endif
8393           enddo
8394         enddo
8395       enddo
8396       return
8397       end
8398 c----------------------------------------------------------------------------
8399       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8400       implicit real*8 (a-h,o-z)
8401       include 'DIMENSIONS'
8402       include 'COMMON.IOUNITS'
8403       include 'COMMON.CHAIN'
8404       include 'COMMON.DERIV'
8405       include 'COMMON.INTERACT'
8406       include 'COMMON.CONTACTS'
8407       include 'COMMON.TORSION'
8408       include 'COMMON.VAR'
8409       include 'COMMON.GEO'
8410       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8411       logical swap
8412 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8413 C                                                                              C
8414 C      Parallel       Antiparallel                                             C
8415 C                                                                              C
8416 C          o             o                                                     C
8417 C         /l\   /   \   /j\                                                    C
8418 C        /   \ /     \ /   \                                                   C
8419 C       /| o |o       o| o |\                                                  C
8420 C       j|/k\|  /      |/k\|l /                                                C
8421 C        /   \ /       /   \ /                                                 C
8422 C       /     o       /     o                                                  C
8423 C       i             i                                                        C
8424 C                                                                              C
8425 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8426 C
8427 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8428 C           energy moment and not to the cluster cumulant.
8429       iti=itortyp(itype(i))
8430       if (j.lt.nres-1) then
8431         itj1=itortyp(itype(j+1))
8432       else
8433         itj1=ntortyp+1
8434       endif
8435       itk=itortyp(itype(k))
8436       itk1=itortyp(itype(k+1))
8437       if (l.lt.nres-1) then
8438         itl1=itortyp(itype(l+1))
8439       else
8440         itl1=ntortyp+1
8441       endif
8442 #ifdef MOMENT
8443       s1=dip(4,jj,i)*dip(4,kk,k)
8444 #endif
8445       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8446       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8447       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8448       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8449       call transpose2(EE(1,1,itk),auxmat(1,1))
8450       call matmat2(auxmat(1,1),AECA(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 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8455 cd     & "sum",-(s2+s3+s4)
8456 #ifdef MOMENT
8457       eello6_graph3=-(s1+s2+s3+s4)
8458 #else
8459       eello6_graph3=-(s2+s3+s4)
8460 #endif
8461 c      eello6_graph3=-s4
8462 C Derivatives in gamma(k-1)
8463       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8464       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8465       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8466       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8467 C Derivatives in gamma(l-1)
8468       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8469       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8470       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8471       vv(1)=pizda(1,1)+pizda(2,2)
8472       vv(2)=pizda(2,1)-pizda(1,2)
8473       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8474       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8475 C Cartesian derivatives.
8476       do iii=1,2
8477         do kkk=1,5
8478           do lll=1,3
8479 #ifdef MOMENT
8480             if (iii.eq.1) then
8481               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8482             else
8483               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8484             endif
8485 #endif
8486             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8487      &        auxvec(1))
8488             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8489             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8490      &        auxvec(1))
8491             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8492             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8493      &        pizda(1,1))
8494             vv(1)=pizda(1,1)+pizda(2,2)
8495             vv(2)=pizda(2,1)-pizda(1,2)
8496             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8497 #ifdef MOMENT
8498             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8499 #else
8500             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8501 #endif
8502             if (swap) then
8503               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8504             else
8505               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8506             endif
8507 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8508           enddo
8509         enddo
8510       enddo
8511       return
8512       end
8513 c----------------------------------------------------------------------------
8514       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8515       implicit real*8 (a-h,o-z)
8516       include 'DIMENSIONS'
8517       include 'COMMON.IOUNITS'
8518       include 'COMMON.CHAIN'
8519       include 'COMMON.DERIV'
8520       include 'COMMON.INTERACT'
8521       include 'COMMON.CONTACTS'
8522       include 'COMMON.TORSION'
8523       include 'COMMON.VAR'
8524       include 'COMMON.GEO'
8525       include 'COMMON.FFIELD'
8526       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8527      & auxvec1(2),auxmat1(2,2)
8528       logical swap
8529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8530 C                                                                              C
8531 C      Parallel       Antiparallel                                             C
8532 C                                                                              C
8533 C          o             o                                                     C
8534 C         /l\   /   \   /j\                                                    C
8535 C        /   \ /     \ /   \                                                   C
8536 C       /| o |o       o| o |\                                                  C
8537 C     \ j|/k\|      \  |/k\|l                                                  C
8538 C      \ /   \       \ /   \                                                   C
8539 C       o     \       o     \                                                  C
8540 C       i             i                                                        C
8541 C                                                                              C
8542 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8543 C
8544 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8545 C           energy moment and not to the cluster cumulant.
8546 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8547       iti=itortyp(itype(i))
8548       itj=itortyp(itype(j))
8549       if (j.lt.nres-1) then
8550         itj1=itortyp(itype(j+1))
8551       else
8552         itj1=ntortyp+1
8553       endif
8554       itk=itortyp(itype(k))
8555       if (k.lt.nres-1) then
8556         itk1=itortyp(itype(k+1))
8557       else
8558         itk1=ntortyp+1
8559       endif
8560       itl=itortyp(itype(l))
8561       if (l.lt.nres-1) then
8562         itl1=itortyp(itype(l+1))
8563       else
8564         itl1=ntortyp+1
8565       endif
8566 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8567 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8568 cd     & ' itl',itl,' itl1',itl1
8569 #ifdef MOMENT
8570       if (imat.eq.1) then
8571         s1=dip(3,jj,i)*dip(3,kk,k)
8572       else
8573         s1=dip(2,jj,j)*dip(2,kk,l)
8574       endif
8575 #endif
8576       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8577       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8578       if (j.eq.l+1) then
8579         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8580         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8581       else
8582         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8583         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8584       endif
8585       call transpose2(EUg(1,1,k),auxmat(1,1))
8586       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8587       vv(1)=pizda(1,1)-pizda(2,2)
8588       vv(2)=pizda(2,1)+pizda(1,2)
8589       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8590 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8591 #ifdef MOMENT
8592       eello6_graph4=-(s1+s2+s3+s4)
8593 #else
8594       eello6_graph4=-(s2+s3+s4)
8595 #endif
8596 C Derivatives in gamma(i-1)
8597       if (i.gt.1) then
8598 #ifdef MOMENT
8599         if (imat.eq.1) then
8600           s1=dipderg(2,jj,i)*dip(3,kk,k)
8601         else
8602           s1=dipderg(4,jj,j)*dip(2,kk,l)
8603         endif
8604 #endif
8605         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8606         if (j.eq.l+1) then
8607           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8608           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8609         else
8610           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8611           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8612         endif
8613         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8614         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8615 cd          write (2,*) 'turn6 derivatives'
8616 #ifdef MOMENT
8617           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8618 #else
8619           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8620 #endif
8621         else
8622 #ifdef MOMENT
8623           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8624 #else
8625           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8626 #endif
8627         endif
8628       endif
8629 C Derivatives in gamma(k-1)
8630 #ifdef MOMENT
8631       if (imat.eq.1) then
8632         s1=dip(3,jj,i)*dipderg(2,kk,k)
8633       else
8634         s1=dip(2,jj,j)*dipderg(4,kk,l)
8635       endif
8636 #endif
8637       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8638       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8639       if (j.eq.l+1) then
8640         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8641         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8642       else
8643         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8644         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8645       endif
8646       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8647       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8648       vv(1)=pizda(1,1)-pizda(2,2)
8649       vv(2)=pizda(2,1)+pizda(1,2)
8650       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8651       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8652 #ifdef MOMENT
8653         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8654 #else
8655         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8656 #endif
8657       else
8658 #ifdef MOMENT
8659         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8660 #else
8661         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8662 #endif
8663       endif
8664 C Derivatives in gamma(j-1) or gamma(l-1)
8665       if (l.eq.j+1 .and. l.gt.1) then
8666         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8667         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8668         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8669         vv(1)=pizda(1,1)-pizda(2,2)
8670         vv(2)=pizda(2,1)+pizda(1,2)
8671         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8672         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8673       else if (j.gt.1) then
8674         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8675         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8676         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8677         vv(1)=pizda(1,1)-pizda(2,2)
8678         vv(2)=pizda(2,1)+pizda(1,2)
8679         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8680         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8681           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8682         else
8683           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8684         endif
8685       endif
8686 C Cartesian derivatives.
8687       do iii=1,2
8688         do kkk=1,5
8689           do lll=1,3
8690 #ifdef MOMENT
8691             if (iii.eq.1) then
8692               if (imat.eq.1) then
8693                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8694               else
8695                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8696               endif
8697             else
8698               if (imat.eq.1) then
8699                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8700               else
8701                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8702               endif
8703             endif
8704 #endif
8705             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8706      &        auxvec(1))
8707             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8708             if (j.eq.l+1) then
8709               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8710      &          b1(1,itj1),auxvec(1))
8711               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8712             else
8713               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8714      &          b1(1,itl1),auxvec(1))
8715               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8716             endif
8717             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8718      &        pizda(1,1))
8719             vv(1)=pizda(1,1)-pizda(2,2)
8720             vv(2)=pizda(2,1)+pizda(1,2)
8721             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8722             if (swap) then
8723               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8724 #ifdef MOMENT
8725                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8726      &             -(s1+s2+s4)
8727 #else
8728                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8729      &             -(s2+s4)
8730 #endif
8731                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8732               else
8733 #ifdef MOMENT
8734                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8735 #else
8736                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8737 #endif
8738                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8739               endif
8740             else
8741 #ifdef MOMENT
8742               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8743 #else
8744               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8745 #endif
8746               if (l.eq.j+1) then
8747                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8748               else
8749                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8750               endif
8751             endif
8752           enddo
8753         enddo
8754       enddo
8755       return
8756       end
8757 c----------------------------------------------------------------------------
8758       double precision function eello_turn6(i,jj,kk)
8759       implicit real*8 (a-h,o-z)
8760       include 'DIMENSIONS'
8761       include 'COMMON.IOUNITS'
8762       include 'COMMON.CHAIN'
8763       include 'COMMON.DERIV'
8764       include 'COMMON.INTERACT'
8765       include 'COMMON.CONTACTS'
8766       include 'COMMON.TORSION'
8767       include 'COMMON.VAR'
8768       include 'COMMON.GEO'
8769       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8770      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8771      &  ggg1(3),ggg2(3)
8772       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8773      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8774 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8775 C           the respective energy moment and not to the cluster cumulant.
8776       s1=0.0d0
8777       s8=0.0d0
8778       s13=0.0d0
8779 c
8780       eello_turn6=0.0d0
8781       j=i+4
8782       k=i+1
8783       l=i+3
8784       iti=itortyp(itype(i))
8785       itk=itortyp(itype(k))
8786       itk1=itortyp(itype(k+1))
8787       itl=itortyp(itype(l))
8788       itj=itortyp(itype(j))
8789 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8790 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8791 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8792 cd        eello6=0.0d0
8793 cd        return
8794 cd      endif
8795 cd      write (iout,*)
8796 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8797 cd     &   ' and',k,l
8798 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8799       do iii=1,2
8800         do kkk=1,5
8801           do lll=1,3
8802             derx_turn(lll,kkk,iii)=0.0d0
8803           enddo
8804         enddo
8805       enddo
8806 cd      eij=1.0d0
8807 cd      ekl=1.0d0
8808 cd      ekont=1.0d0
8809       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8810 cd      eello6_5=0.0d0
8811 cd      write (2,*) 'eello6_5',eello6_5
8812 #ifdef MOMENT
8813       call transpose2(AEA(1,1,1),auxmat(1,1))
8814       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8815       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8816       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8817 #endif
8818       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8819       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8820       s2 = scalar2(b1(1,itk),vtemp1(1))
8821 #ifdef MOMENT
8822       call transpose2(AEA(1,1,2),atemp(1,1))
8823       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8824       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8825       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8826 #endif
8827       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8828       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8829       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8830 #ifdef MOMENT
8831       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8832       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8833       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8834       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8835       ss13 = scalar2(b1(1,itk),vtemp4(1))
8836       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8837 #endif
8838 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8839 c      s1=0.0d0
8840 c      s2=0.0d0
8841 c      s8=0.0d0
8842 c      s12=0.0d0
8843 c      s13=0.0d0
8844       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8845 C Derivatives in gamma(i+2)
8846       s1d =0.0d0
8847       s8d =0.0d0
8848 #ifdef MOMENT
8849       call transpose2(AEA(1,1,1),auxmatd(1,1))
8850       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8851       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8852       call transpose2(AEAderg(1,1,2),atempd(1,1))
8853       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8854       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8855 #endif
8856       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8857       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8858       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8859 c      s1d=0.0d0
8860 c      s2d=0.0d0
8861 c      s8d=0.0d0
8862 c      s12d=0.0d0
8863 c      s13d=0.0d0
8864       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8865 C Derivatives in gamma(i+3)
8866 #ifdef MOMENT
8867       call transpose2(AEA(1,1,1),auxmatd(1,1))
8868       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8869       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8870       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8871 #endif
8872       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8873       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8874       s2d = scalar2(b1(1,itk),vtemp1d(1))
8875 #ifdef MOMENT
8876       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8877       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8878 #endif
8879       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8880 #ifdef MOMENT
8881       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8882       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8883       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8884 #endif
8885 c      s1d=0.0d0
8886 c      s2d=0.0d0
8887 c      s8d=0.0d0
8888 c      s12d=0.0d0
8889 c      s13d=0.0d0
8890 #ifdef MOMENT
8891       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8892      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8893 #else
8894       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8895      &               -0.5d0*ekont*(s2d+s12d)
8896 #endif
8897 C Derivatives in gamma(i+4)
8898       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8899       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8900       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8901 #ifdef MOMENT
8902       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8903       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8904       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8905 #endif
8906 c      s1d=0.0d0
8907 c      s2d=0.0d0
8908 c      s8d=0.0d0
8909 C      s12d=0.0d0
8910 c      s13d=0.0d0
8911 #ifdef MOMENT
8912       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8913 #else
8914       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8915 #endif
8916 C Derivatives in gamma(i+5)
8917 #ifdef MOMENT
8918       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8919       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8920       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8921 #endif
8922       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8923       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8924       s2d = scalar2(b1(1,itk),vtemp1d(1))
8925 #ifdef MOMENT
8926       call transpose2(AEA(1,1,2),atempd(1,1))
8927       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8928       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8929 #endif
8930       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8931       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8932 #ifdef MOMENT
8933       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8934       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8935       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8936 #endif
8937 c      s1d=0.0d0
8938 c      s2d=0.0d0
8939 c      s8d=0.0d0
8940 c      s12d=0.0d0
8941 c      s13d=0.0d0
8942 #ifdef MOMENT
8943       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8944      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8945 #else
8946       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8947      &               -0.5d0*ekont*(s2d+s12d)
8948 #endif
8949 C Cartesian derivatives
8950       do iii=1,2
8951         do kkk=1,5
8952           do lll=1,3
8953 #ifdef MOMENT
8954             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8955             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8956             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8957 #endif
8958             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8959             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8960      &          vtemp1d(1))
8961             s2d = scalar2(b1(1,itk),vtemp1d(1))
8962 #ifdef MOMENT
8963             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8964             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8965             s8d = -(atempd(1,1)+atempd(2,2))*
8966      &           scalar2(cc(1,1,itl),vtemp2(1))
8967 #endif
8968             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8969      &           auxmatd(1,1))
8970             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8971             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8972 c      s1d=0.0d0
8973 c      s2d=0.0d0
8974 c      s8d=0.0d0
8975 c      s12d=0.0d0
8976 c      s13d=0.0d0
8977 #ifdef MOMENT
8978             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8979      &        - 0.5d0*(s1d+s2d)
8980 #else
8981             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8982      &        - 0.5d0*s2d
8983 #endif
8984 #ifdef MOMENT
8985             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8986      &        - 0.5d0*(s8d+s12d)
8987 #else
8988             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8989      &        - 0.5d0*s12d
8990 #endif
8991           enddo
8992         enddo
8993       enddo
8994 #ifdef MOMENT
8995       do kkk=1,5
8996         do lll=1,3
8997           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8998      &      achuj_tempd(1,1))
8999           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9000           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9001           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9002           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9003           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9004      &      vtemp4d(1))
9005           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9006           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9007           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9008         enddo
9009       enddo
9010 #endif
9011 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9012 cd     &  16*eel_turn6_num
9013 cd      goto 1112
9014       if (j.lt.nres-1) then
9015         j1=j+1
9016         j2=j-1
9017       else
9018         j1=j-1
9019         j2=j-2
9020       endif
9021       if (l.lt.nres-1) then
9022         l1=l+1
9023         l2=l-1
9024       else
9025         l1=l-1
9026         l2=l-2
9027       endif
9028       do ll=1,3
9029 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9030 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9031 cgrad        ghalf=0.5d0*ggg1(ll)
9032 cd        ghalf=0.0d0
9033         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9034         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9035         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9036      &    +ekont*derx_turn(ll,2,1)
9037         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9038         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9039      &    +ekont*derx_turn(ll,4,1)
9040         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9041         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9042         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9043 cgrad        ghalf=0.5d0*ggg2(ll)
9044 cd        ghalf=0.0d0
9045         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9046      &    +ekont*derx_turn(ll,2,2)
9047         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9048         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9049      &    +ekont*derx_turn(ll,4,2)
9050         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9051         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9052         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9053       enddo
9054 cd      goto 1112
9055 cgrad      do m=i+1,j-1
9056 cgrad        do ll=1,3
9057 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9058 cgrad        enddo
9059 cgrad      enddo
9060 cgrad      do m=k+1,l-1
9061 cgrad        do ll=1,3
9062 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9063 cgrad        enddo
9064 cgrad      enddo
9065 cgrad1112  continue
9066 cgrad      do m=i+2,j2
9067 cgrad        do ll=1,3
9068 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9069 cgrad        enddo
9070 cgrad      enddo
9071 cgrad      do m=k+2,l2
9072 cgrad        do ll=1,3
9073 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9074 cgrad        enddo
9075 cgrad      enddo
9076 cd      do iii=1,nres-3
9077 cd        write (2,*) iii,g_corr6_loc(iii)
9078 cd      enddo
9079       eello_turn6=ekont*eel_turn6
9080 cd      write (2,*) 'ekont',ekont
9081 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9082       return
9083       end
9084
9085 C-----------------------------------------------------------------------------
9086       double precision function scalar(u,v)
9087 !DIR$ INLINEALWAYS scalar
9088 #ifndef OSF
9089 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9090 #endif
9091       implicit none
9092       double precision u(3),v(3)
9093 cd      double precision sc
9094 cd      integer i
9095 cd      sc=0.0d0
9096 cd      do i=1,3
9097 cd        sc=sc+u(i)*v(i)
9098 cd      enddo
9099 cd      scalar=sc
9100
9101       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9102       return
9103       end
9104 crc-------------------------------------------------
9105       SUBROUTINE MATVEC2(A1,V1,V2)
9106 !DIR$ INLINEALWAYS MATVEC2
9107 #ifndef OSF
9108 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9109 #endif
9110       implicit real*8 (a-h,o-z)
9111       include 'DIMENSIONS'
9112       DIMENSION A1(2,2),V1(2),V2(2)
9113 c      DO 1 I=1,2
9114 c        VI=0.0
9115 c        DO 3 K=1,2
9116 c    3     VI=VI+A1(I,K)*V1(K)
9117 c        Vaux(I)=VI
9118 c    1 CONTINUE
9119
9120       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9121       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9122
9123       v2(1)=vaux1
9124       v2(2)=vaux2
9125       END
9126 C---------------------------------------
9127       SUBROUTINE MATMAT2(A1,A2,A3)
9128 #ifndef OSF
9129 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9130 #endif
9131       implicit real*8 (a-h,o-z)
9132       include 'DIMENSIONS'
9133       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9134 c      DIMENSION AI3(2,2)
9135 c        DO  J=1,2
9136 c          A3IJ=0.0
9137 c          DO K=1,2
9138 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9139 c          enddo
9140 c          A3(I,J)=A3IJ
9141 c       enddo
9142 c      enddo
9143
9144       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9145       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9146       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9147       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9148
9149       A3(1,1)=AI3_11
9150       A3(2,1)=AI3_21
9151       A3(1,2)=AI3_12
9152       A3(2,2)=AI3_22
9153       END
9154
9155 c-------------------------------------------------------------------------
9156       double precision function scalar2(u,v)
9157 !DIR$ INLINEALWAYS scalar2
9158       implicit none
9159       double precision u(2),v(2)
9160       double precision sc
9161       integer i
9162       scalar2=u(1)*v(1)+u(2)*v(2)
9163       return
9164       end
9165
9166 C-----------------------------------------------------------------------------
9167
9168       subroutine transpose2(a,at)
9169 !DIR$ INLINEALWAYS transpose2
9170 #ifndef OSF
9171 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9172 #endif
9173       implicit none
9174       double precision a(2,2),at(2,2)
9175       at(1,1)=a(1,1)
9176       at(1,2)=a(2,1)
9177       at(2,1)=a(1,2)
9178       at(2,2)=a(2,2)
9179       return
9180       end
9181 c--------------------------------------------------------------------------
9182       subroutine transpose(n,a,at)
9183       implicit none
9184       integer n,i,j
9185       double precision a(n,n),at(n,n)
9186       do i=1,n
9187         do j=1,n
9188           at(j,i)=a(i,j)
9189         enddo
9190       enddo
9191       return
9192       end
9193 C---------------------------------------------------------------------------
9194       subroutine prodmat3(a1,a2,kk,transp,prod)
9195 !DIR$ INLINEALWAYS prodmat3
9196 #ifndef OSF
9197 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9198 #endif
9199       implicit none
9200       integer i,j
9201       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9202       logical transp
9203 crc      double precision auxmat(2,2),prod_(2,2)
9204
9205       if (transp) then
9206 crc        call transpose2(kk(1,1),auxmat(1,1))
9207 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9208 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9209
9210            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9211      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9212            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9213      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9214            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9215      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9216            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9217      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9218
9219       else
9220 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9221 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9222
9223            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9224      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9225            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9226      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9227            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9228      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9229            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9230      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9231
9232       endif
9233 c      call transpose2(a2(1,1),a2t(1,1))
9234
9235 crc      print *,transp
9236 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9237 crc      print *,((prod(i,j),i=1,2),j=1,2)
9238
9239       return
9240       end
9241