source/unres/src_MD_DFA/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
 135 C     BARTEK for dfa test!
 136       if (wdfa_dist.gt.0) call edfad(edfadis)
 137 c      print*, 'edfad is finished!', edfadis
 138       if (wdfa_tor.gt.0) call edfat(edfator)
 139 c      print*, 'edfat is finished!', edfator
 140       if (wdfa_nei.gt.0) call edfan(edfanei)
 141 c      print*, 'edfan is finished!', edfanei
 142       if (wdfa_beta.gt.0) call edfab(edfabet)
 143 c      print*, 'edfab is finished!', edfabet
 144 c      print *,"Processor",myrank," computed USCSC"
 145 #ifdef TIMING
 146 #ifdef MPI
 147       time01=MPI_Wtime()
 148 #else
 149       time00=tcpu()
 150 #endif
 151 #endif
 152       call vec_and_deriv
 153 #ifdef TIMING
 154 #ifdef MPI
 155       time_vec=time_vec+MPI_Wtime()-time01
 156 #else
 157       time_vec=time_vec+tcpu()-time01
 158 #endif
 159 #endif
 160 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 161       if (ipot.lt.6) then
 162 #ifdef SPLITELE
 163          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #else
 168          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 169      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 170      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 171      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 172 #endif
 173             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 174          else
 175             ees=0.0d0
 176             evdw1=0.0d0
 177             eel_loc=0.0d0
 178             eello_turn3=0.0d0
 179             eello_turn4=0.0d0
 180          endif
 181       else
 182 c        write (iout,*) "Soft-spheer ELEC potential"
 183         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 184      &   eello_turn4)
 185       endif
 186 c      print *,"Processor",myrank," computed UELEC"
 187 C
 188 C Calculate excluded-volume interaction energy between peptide groups
 189 C and side chains.
 190 C
 191       if (ipot.lt.6) then
 192        if(wscp.gt.0d0) then
 193         call escp(evdw2,evdw2_14)
 194        else
 195         evdw2=0
 196         evdw2_14=0
 197        endif
 198       else
 199 c        write (iout,*) "Soft-sphere SCP potential"
 200         call escp_soft_sphere(evdw2,evdw2_14)
 201       endif
 202 c
 203 c Calculate the bond-stretching energy
 204 c
 205       call ebond(estr)
 206 C
 207 C Calculate the disulfide-bridge and other energy and the contributions
 208 C from other distance constraints.
 209 cd    print *,'Calling EHPB'
 210       call edis(ehpb)
 211 cd    print *,'EHPB exitted succesfully.'
 212 C
 213 C Calculate the virtual-bond-angle energy.
 214 C
 215       if (wang.gt.0d0) then
 216         call ebend(ebe)
 217       else
 218         ebe=0
 219       endif
 220 c      print *,"Processor",myrank," computed UB"
 221 C
 222 C Calculate the SC local energy.
 223 C
 224       call esc(escloc)
 225 c      print *,"Processor",myrank," computed USC"
 226 C
 227 C Calculate the virtual-bond torsional energy.
 228 C
 229 cd    print *,'nterm=',nterm
 230       if (wtor.gt.0) then
 231        call etor(etors,edihcnstr)
 232       else
 233        etors=0
 234        edihcnstr=0
 235       endif
 236 c      print *,"Processor",myrank," computed Utor"
 237 C
 238 C 6/23/01 Calculate double-torsional energy
 239 C
 240       if (wtor_d.gt.0) then
 241        call etor_d(etors_d)
 242       else
 243        etors_d=0
 244       endif
 245 c      print *,"Processor",myrank," computed Utord"
 246 C
 247 C 21/5/07 Calculate local sicdechain correlation energy
 248 C
 249       if (wsccor.gt.0.0d0) then
 250         call eback_sc_corr(esccor)
 251       else
 252         esccor=0.0d0
 253       endif
 254 c      print *,"Processor",myrank," computed Usccorr"
 255 C
 256 C 12/1/95 Multi-body terms
 257 C
 258       n_corr=0
 259       n_corr1=0
 260       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 261      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 262          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 263 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 264 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 265       else
 266          ecorr=0.0d0
 267          ecorr5=0.0d0
 268          ecorr6=0.0d0
 269          eturn6=0.0d0
 270       endif
 271       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 272          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 273 cd         write (iout,*) "multibody_hb ecorr",ecorr
 274       endif
 275 c      print *,"Processor",myrank," computed Ucorr"
 276 C
 277 C If performing constraint dynamics, call the constraint energy
 278 C  after the equilibration time
 279       if(usampl.and.totT.gt.eq_time) then
 280          call EconstrQ
 281          call Econstr_back
 282       else
 283          Uconst=0.0d0
 284          Uconst_back=0.0d0
 285       endif
 286 #ifdef TIMING
 287 #ifdef MPI
 288       time_enecalc=time_enecalc+MPI_Wtime()-time00
 289 #else
 290       time_enecalc=time_enecalc+tcpu()-time00
 291 #endif
 292 #endif
 293 c      print *,"Processor",myrank," computed Uconstr"
 294 #ifdef TIMING
 295 #ifdef MPI
 296       time00=MPI_Wtime()
 297 #else
 298       time00=tcpu()
 299 #endif
 300 #endif
 301 c
 302 C Sum the energies
 303 C
 304       energia(1)=evdw
 305 #ifdef SCP14
 306       energia(2)=evdw2-evdw2_14
 307       energia(18)=evdw2_14
 308 #else
 309       energia(2)=evdw2
 310       energia(18)=0.0d0
 311 #endif
 312 #ifdef SPLITELE
 313       energia(3)=ees
 314       energia(16)=evdw1
 315 #else
 316       energia(3)=ees+evdw1
 317       energia(16)=0.0d0
 318 #endif
 319       energia(4)=ecorr
 320       energia(5)=ecorr5
 321       energia(6)=ecorr6
 322       energia(7)=eel_loc
 323       energia(8)=eello_turn3
 324       energia(9)=eello_turn4
 325       energia(10)=eturn6
 326       energia(11)=ebe
 327       energia(12)=escloc
 328       energia(13)=etors
 329       energia(14)=etors_d
 330       energia(15)=ehpb
 331       energia(19)=edihcnstr
 332       energia(17)=estr
 333       energia(20)=Uconst+Uconst_back
 334       energia(21)=esccor
 335       energia(22)=evdw_p
 336       energia(23)=evdw_m
 337       energia(24)=edfadis
 338       energia(25)=edfator
 339       energia(26)=edfanei
 340       energia(27)=edfabet
 341 c      print *," Processor",myrank," calls SUM_ENERGY"
 342       call sum_energy(energia,.true.)
 343 c      print *," Processor",myrank," left SUM_ENERGY"
 344 #ifdef TIMING
 345 #ifdef MPI
 346       time_sumene=time_sumene+MPI_Wtime()-time00
 347 #else
 348       time_sumene=time_sumene+tcpu()-time00
 349 #endif
 350 #endif
 351       return
 352       end
 353 c-------------------------------------------------------------------------------
 354       subroutine sum_energy(energia,reduce)
 355       implicit real*8 (a-h,o-z)
 356       include 'DIMENSIONS'
 357 #ifndef ISNAN
 358       external proc_proc
 359 #ifdef WINPGI
 360 cMS$ATTRIBUTES C ::  proc_proc
 361 #endif
 362 #endif
 363 #ifdef MPI
 364       include "mpif.h"
 365 #endif
 366       include 'COMMON.SETUP'
 367       include 'COMMON.IOUNITS'
 368       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 369       include 'COMMON.FFIELD'
 370       include 'COMMON.DERIV'
 371       include 'COMMON.INTERACT'
 372       include 'COMMON.SBRIDGE'
 373       include 'COMMON.CHAIN'
 374       include 'COMMON.VAR'
 375       include 'COMMON.CONTROL'
 376       include 'COMMON.TIME1'
 377       logical reduce
 378 #ifdef MPI
 379       if (nfgtasks.gt.1 .and. reduce) then
 380 #ifdef DEBUG
 381         write (iout,*) "energies before REDUCE"
 382         call enerprint(energia)
 383         call flush(iout)
 384 #endif
 385         do i=0,n_ene
 386           enebuff(i)=energia(i)
 387         enddo
 388         time00=MPI_Wtime()
 389         call MPI_Barrier(FG_COMM,IERR)
 390         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 391         time00=MPI_Wtime()
 392         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 393      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 394 #ifdef DEBUG
 395         write (iout,*) "energies after REDUCE"
 396         call enerprint(energia)
 397         call flush(iout)
 398 #endif
 399         time_Reduce=time_Reduce+MPI_Wtime()-time00
 400       endif
 401       if (fg_rank.eq.0) then
 402 #endif
 403 #ifdef TSCSC
 404       evdw=energia(22)+wsct*energia(23)
 405 #else
 406       evdw=energia(1)
 407 #endif
 408 #ifdef SCP14
 409       evdw2=energia(2)+energia(18)
 410       evdw2_14=energia(18)
 411 #else
 412       evdw2=energia(2)
 413 #endif
 414 #ifdef SPLITELE
 415       ees=energia(3)
 416       evdw1=energia(16)
 417 #else
 418       ees=energia(3)
 419       evdw1=0.0d0
 420 #endif
 421       ecorr=energia(4)
 422       ecorr5=energia(5)
 423       ecorr6=energia(6)
 424       eel_loc=energia(7)
 425       eello_turn3=energia(8)
 426       eello_turn4=energia(9)
 427       eturn6=energia(10)
 428       ebe=energia(11)
 429       escloc=energia(12)
 430       etors=energia(13)
 431       etors_d=energia(14)
 432       ehpb=energia(15)
 433       edihcnstr=energia(19)
 434       estr=energia(17)
 435       Uconst=energia(20)
 436       esccor=energia(21)
 437       edfadis=energia(24)
 438       edfator=energia(25)
 439       edfanei=energia(26)
 440       edfabet=energia(27)
 441 #ifdef SPLITELE
 442       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 443      & +wang*ebe+wtor*etors+wscloc*escloc
 444      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 445      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 446      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 447      & +wbond*estr+Uconst+wsccor*esccor
 448      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 449      & +wdfa_beta*edfabet
 450 #else
 451       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 452      & +wang*ebe+wtor*etors+wscloc*escloc
 453      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 454      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 455      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 456      & +wbond*estr+Uconst+wsccor*esccor
 457      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 458      & +wdfa_beta*edfabet
 459 #endif
 460       energia(0)=etot
 461 c detecting NaNQ
 462 #ifdef ISNAN
 463 #ifdef AIX
 464       if (isnan(etot).ne.0) energia(0)=1.0d+99
 465 #else
 466       if (isnan(etot)) energia(0)=1.0d+99
 467 #endif
 468 #else
 469       i=0
 470 #ifdef WINPGI
 471       idumm=proc_proc(etot,i)
 472 #else
 473       call proc_proc(etot,i)
 474 #endif
 475       if(i.eq.1)energia(0)=1.0d+99
 476 #endif
 477 #ifdef MPI
 478       endif
 479 #endif
 480       return
 481       end
 482 c-------------------------------------------------------------------------------
 483       subroutine sum_gradient
 484       implicit real*8 (a-h,o-z)
 485       include 'DIMENSIONS'
 486 #ifndef ISNAN
 487       external proc_proc
 488 #ifdef WINPGI
 489 cMS$ATTRIBUTES C ::  proc_proc
 490 #endif
 491 #endif
 492 #ifdef MPI
 493       include 'mpif.h'
 494 #endif
 495       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 496      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 497       include 'COMMON.SETUP'
 498       include 'COMMON.IOUNITS'
 499       include 'COMMON.FFIELD'
 500       include 'COMMON.DERIV'
 501       include 'COMMON.INTERACT'
 502       include 'COMMON.SBRIDGE'
 503       include 'COMMON.CHAIN'
 504       include 'COMMON.VAR'
 505       include 'COMMON.CONTROL'
 506       include 'COMMON.TIME1'
 507       include 'COMMON.MAXGRAD'
 508       include 'COMMON.SCCOR'
 509 #ifdef TIMING
 510 #ifdef MPI
 511       time01=MPI_Wtime()
 512 #else
 513       time01=tcpu()
 514 #endif
 515 #endif
 516 #ifdef DEBUG
 517       write (iout,*) "sum_gradient gvdwc, gvdwx"
 518       do i=1,nres
 519         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 520      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 521      &   (gvdwcT(j,i),j=1,3)
 522       enddo
 523       call flush(iout)
 524 #endif
 525 #ifdef MPI
 526 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 527         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 528      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 529 #endif
 530 C
 531 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 532 C            in virtual-bond-vector coordinates
 533 C
 534 #ifdef DEBUG
 535 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 536 c      do i=1,nres-1
 537 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 538 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 539 c      enddo
 540 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 541 c      do i=1,nres-1
 542 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 543 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 544 c      enddo
 545       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 546       do i=1,nres
 547         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 548      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 549      &   g_corr5_loc(i)
 550       enddo
 551       call flush(iout)
 552 #endif
 553 #ifdef SPLITELE
 554 #ifdef TSCSC
 555       do i=1,nct
 556         do j=1,3
 557           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 558      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 559      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 560      &                wel_loc*gel_loc_long(j,i)+
 561      &                wcorr*gradcorr_long(j,i)+
 562      &                wcorr5*gradcorr5_long(j,i)+
 563      &                wcorr6*gradcorr6_long(j,i)+
 564      &                wturn6*gcorr6_turn_long(j,i)+
 565      &                wstrain*ghpbc(j,i)+
 566      &                wdfa_dist*gdfad(j,i)+
 567      &                wdfa_tor*gdfat(j,i)+
 568      &                wdfa_nei*gdfan(j,i)+
 569      &                wdfa_beta*gdfab(j,i)
 570         enddo
 571       enddo
 572 #else
 573       do i=1,nct
 574         do j=1,3
 575           gradbufc(j,i)=wsc*gvdwc(j,i)+
 576      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 577      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 578      &                wel_loc*gel_loc_long(j,i)+
 579      &                wcorr*gradcorr_long(j,i)+
 580      &                wcorr5*gradcorr5_long(j,i)+
 581      &                wcorr6*gradcorr6_long(j,i)+
 582      &                wturn6*gcorr6_turn_long(j,i)+
 583      &                wstrain*ghpbc(j,i)+
 584      &                wdfa_dist*gdfad(j,i)+
 585      &                wdfa_tor*gdfat(j,i)+
 586      &                wdfa_nei*gdfan(j,i)+
 587      &                wdfa_beta*gdfab(j,i)
 588         enddo
 589       enddo
 590 #endif
 591 #else
 592       do i=1,nct
 593         do j=1,3
 594           gradbufc(j,i)=wsc*gvdwc(j,i)+
 595      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 596      &                welec*gelc_long(j,i)+
 597      &                wbond*gradb(j,i)+
 598      &                wel_loc*gel_loc_long(j,i)+
 599      &                wcorr*gradcorr_long(j,i)+
 600      &                wcorr5*gradcorr5_long(j,i)+
 601      &                wcorr6*gradcorr6_long(j,i)+
 602      &                wturn6*gcorr6_turn_long(j,i)+
 603      &                wstrain*ghpbc(j,i)+
 604      &                wdfa_dist*gdfad(j,i)+
 605      &                wdfa_tor*gdfat(j,i)+
 606      &                wdfa_nei*gdfan(j,i)+
 607      &                wdfa_beta*gdfab(j,i)
 608         enddo
 609       enddo
 610 #endif
 611 #ifdef MPI
 612       if (nfgtasks.gt.1) then
 613       time00=MPI_Wtime()
 614 #ifdef DEBUG
 615       write (iout,*) "gradbufc before allreduce"
 616       do i=1,nres
 617         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 618       enddo
 619       call flush(iout)
 620 #endif
 621       do i=1,nres
 622         do j=1,3
 623           gradbufc_sum(j,i)=gradbufc(j,i)
 624         enddo
 625       enddo
 626 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 627 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 628 c      time_reduce=time_reduce+MPI_Wtime()-time00
 629 #ifdef DEBUG
 630 c      write (iout,*) "gradbufc_sum after allreduce"
 631 c      do i=1,nres
 632 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 633 c      enddo
 634 c      call flush(iout)
 635 #endif
 636 #ifdef TIMING
 637 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 638 #endif
 639       do i=nnt,nres
 640         do k=1,3
 641           gradbufc(k,i)=0.0d0
 642         enddo
 643       enddo
 644 #ifdef DEBUG
 645       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 646       write (iout,*) (i," jgrad_start",jgrad_start(i),
 647      &                  " jgrad_end  ",jgrad_end(i),
 648      &                  i=igrad_start,igrad_end)
 649 #endif
 650 c
 651 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 652 c do not parallelize this part.
 653 c
 654 c      do i=igrad_start,igrad_end
 655 c        do j=jgrad_start(i),jgrad_end(i)
 656 c          do k=1,3
 657 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 658 c          enddo
 659 c        enddo
 660 c      enddo
 661       do j=1,3
 662         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 663       enddo
 664       do i=nres-2,nnt,-1
 665         do j=1,3
 666           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 667         enddo
 668       enddo
 669 #ifdef DEBUG
 670       write (iout,*) "gradbufc after summing"
 671       do i=1,nres
 672         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 673       enddo
 674       call flush(iout)
 675 #endif
 676       else
 677 #endif
 678 #ifdef DEBUG
 679       write (iout,*) "gradbufc"
 680       do i=1,nres
 681         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 682       enddo
 683       call flush(iout)
 684 #endif
 685       do i=1,nres
 686         do j=1,3
 687           gradbufc_sum(j,i)=gradbufc(j,i)
 688           gradbufc(j,i)=0.0d0
 689         enddo
 690       enddo
 691       do j=1,3
 692         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 693       enddo
 694       do i=nres-2,nnt,-1
 695         do j=1,3
 696           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 697         enddo
 698       enddo
 699 c      do i=nnt,nres-1
 700 c        do k=1,3
 701 c          gradbufc(k,i)=0.0d0
 702 c        enddo
 703 c        do j=i+1,nres
 704 c          do k=1,3
 705 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 706 c          enddo
 707 c        enddo
 708 c      enddo
 709 #ifdef DEBUG
 710       write (iout,*) "gradbufc after summing"
 711       do i=1,nres
 712         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 713       enddo
 714       call flush(iout)
 715 #endif
 716 #ifdef MPI
 717       endif
 718 #endif
 719       do k=1,3
 720         gradbufc(k,nres)=0.0d0
 721       enddo
 722       do i=1,nct
 723         do j=1,3
 724 #ifdef SPLITELE
 725           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 726      &                wel_loc*gel_loc(j,i)+
 727      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 728      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 729      &                wel_loc*gel_loc_long(j,i)+
 730      &                wcorr*gradcorr_long(j,i)+
 731      &                wcorr5*gradcorr5_long(j,i)+
 732      &                wcorr6*gradcorr6_long(j,i)+
 733      &                wturn6*gcorr6_turn_long(j,i))+
 734      &                wbond*gradb(j,i)+
 735      &                wcorr*gradcorr(j,i)+
 736      &                wturn3*gcorr3_turn(j,i)+
 737      &                wturn4*gcorr4_turn(j,i)+
 738      &                wcorr5*gradcorr5(j,i)+
 739      &                wcorr6*gradcorr6(j,i)+
 740      &                wturn6*gcorr6_turn(j,i)+
 741      &                wsccor*gsccorc(j,i)
 742      &               +wscloc*gscloc(j,i)
 743 #else
 744           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 745      &                wel_loc*gel_loc(j,i)+
 746      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 747      &                welec*gelc_long(j,i)+
 748      &                wel_loc*gel_loc_long(j,i)+
 749      &                wcorr*gcorr_long(j,i)+
 750      &                wcorr5*gradcorr5_long(j,i)+
 751      &                wcorr6*gradcorr6_long(j,i)+
 752      &                wturn6*gcorr6_turn_long(j,i))+
 753      &                wbond*gradb(j,i)+
 754      &                wcorr*gradcorr(j,i)+
 755      &                wturn3*gcorr3_turn(j,i)+
 756      &                wturn4*gcorr4_turn(j,i)+
 757      &                wcorr5*gradcorr5(j,i)+
 758      &                wcorr6*gradcorr6(j,i)+
 759      &                wturn6*gcorr6_turn(j,i)+
 760      &                wsccor*gsccorc(j,i)
 761      &               +wscloc*gscloc(j,i)
 762 #endif
 763 #ifdef TSCSC
 764           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 765      &                  wscp*gradx_scp(j,i)+
 766      &                  wbond*gradbx(j,i)+
 767      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 768      &                  wsccor*gsccorx(j,i)
 769      &                 +wscloc*gsclocx(j,i)
 770 #else
 771           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 772      &                  wbond*gradbx(j,i)+
 773      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 774      &                  wsccor*gsccorx(j,i)
 775      &                 +wscloc*gsclocx(j,i)
 776 #endif
 777         enddo
 778       enddo
 779 #ifdef DEBUG
 780       write (iout,*) "gloc before adding corr"
 781       do i=1,4*nres
 782         write (iout,*) i,gloc(i,icg)
 783       enddo
 784 #endif
 785       do i=1,nres-3
 786         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 787      &   +wcorr5*g_corr5_loc(i)
 788      &   +wcorr6*g_corr6_loc(i)
 789      &   +wturn4*gel_loc_turn4(i)
 790      &   +wturn3*gel_loc_turn3(i)
 791      &   +wturn6*gel_loc_turn6(i)
 792      &   +wel_loc*gel_loc_loc(i)
 793      &   +wsccor*gsccor_loc(i)
 794       enddo
 795 #ifdef DEBUG
 796       write (iout,*) "gloc after adding corr"
 797       do i=1,4*nres
 798         write (iout,*) i,gloc(i,icg)
 799       enddo
 800 #endif
 801 #ifdef MPI
 802       if (nfgtasks.gt.1) then
 803         do j=1,3
 804           do i=1,nres
 805             gradbufc(j,i)=gradc(j,i,icg)
 806             gradbufx(j,i)=gradx(j,i,icg)
 807           enddo
 808         enddo
 809         do i=1,4*nres
 810           glocbuf(i)=gloc(i,icg)
 811         enddo
 812 #ifdef DEBUG
 813       write (iout,*) "gloc_sc before reduce"
 814       do i=1,nres
 815        do j=1,3
 816         write (iout,*) i,j,gloc_sc(j,i,icg)
 817        enddo
 818       enddo
 819 #endif
 820         do i=1,nres
 821          do j=1,3
 822           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 823          enddo
 824         enddo
 825         time00=MPI_Wtime()
 826         call MPI_Barrier(FG_COMM,IERR)
 827         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 828         time00=MPI_Wtime()
 829         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 830      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 831         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 832      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 833         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 834      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 835         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 836      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 837         time_reduce=time_reduce+MPI_Wtime()-time00
 838 #ifdef DEBUG
 839       write (iout,*) "gloc_sc after reduce"
 840       do i=1,nres
 841        do j=1,3
 842         write (iout,*) i,j,gloc_sc(j,i,icg)
 843        enddo
 844       enddo
 845 #endif
 846 #ifdef DEBUG
 847       write (iout,*) "gloc after reduce"
 848       do i=1,4*nres
 849         write (iout,*) i,gloc(i,icg)
 850       enddo
 851 #endif
 852       endif
 853 #endif
 854       if (gnorm_check) then
 855 c
 856 c Compute the maximum elements of the gradient
 857 c
 858       gvdwc_max=0.0d0
 859       gvdwc_scp_max=0.0d0
 860       gelc_max=0.0d0
 861       gvdwpp_max=0.0d0
 862       gradb_max=0.0d0
 863       ghpbc_max=0.0d0
 864       gradcorr_max=0.0d0
 865       gel_loc_max=0.0d0
 866       gcorr3_turn_max=0.0d0
 867       gcorr4_turn_max=0.0d0
 868       gradcorr5_max=0.0d0
 869       gradcorr6_max=0.0d0
 870       gcorr6_turn_max=0.0d0
 871       gsccorc_max=0.0d0
 872       gscloc_max=0.0d0
 873       gvdwx_max=0.0d0
 874       gradx_scp_max=0.0d0
 875       ghpbx_max=0.0d0
 876       gradxorr_max=0.0d0
 877       gsccorx_max=0.0d0
 878       gsclocx_max=0.0d0
 879       do i=1,nct
 880         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 881         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 882 #ifdef TSCSC
 883         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 884         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 885 #endif
 886         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 887         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 888      &   gvdwc_scp_max=gvdwc_scp_norm
 889         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 890         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 891         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 892         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 893         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 894         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 895         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 896         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 897         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 898         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 899         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 900         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 901         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 902      &    gcorr3_turn(1,i)))
 903         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 904      &    gcorr3_turn_max=gcorr3_turn_norm
 905         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 906      &    gcorr4_turn(1,i)))
 907         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 908      &    gcorr4_turn_max=gcorr4_turn_norm
 909         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 910         if (gradcorr5_norm.gt.gradcorr5_max)
 911      &    gradcorr5_max=gradcorr5_norm
 912         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 913         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 914         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 915      &    gcorr6_turn(1,i)))
 916         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 917      &    gcorr6_turn_max=gcorr6_turn_norm
 918         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 919         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 920         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 921         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 922         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 923         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 924 #ifdef TSCSC
 925         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 926         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 927 #endif
 928         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 929         if (gradx_scp_norm.gt.gradx_scp_max)
 930      &    gradx_scp_max=gradx_scp_norm
 931         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 932         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 933         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 934         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 935         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 936         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 937         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 938         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 939       enddo
 940       if (gradout) then
 941 #ifdef AIX
 942         open(istat,file=statname,position="append")
 943 #else
 944         open(istat,file=statname,access="append")
 945 #endif
 946         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 947      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 948      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 949      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 950      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 951      &     gsccorx_max,gsclocx_max
 952         close(istat)
 953         if (gvdwc_max.gt.1.0d4) then
 954           write (iout,*) "gvdwc gvdwx gradb gradbx"
 955           do i=nnt,nct
 956             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 957      &        gradb(j,i),gradbx(j,i),j=1,3)
 958           enddo
 959           call pdbout(0.0d0,'cipiszcze',iout)
 960           call flush(iout)
 961         endif
 962       endif
 963       endif
 964 #ifdef DEBUG
 965       write (iout,*) "gradc gradx gloc"
 966       do i=1,nres
 967         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 968      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 969       enddo
 970 #endif
 971 #ifdef TIMING
 972 #ifdef MPI
 973       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 974 #else
 975       time_sumgradient=time_sumgradient+tcpu()-time01
 976 #endif
 977 #endif
 978       return
 979       end
 980 c-------------------------------------------------------------------------------
 981       subroutine rescale_weights(t_bath)
 982       implicit real*8 (a-h,o-z)
 983       include 'DIMENSIONS'
 984       include 'COMMON.IOUNITS'
 985       include 'COMMON.FFIELD'
 986       include 'COMMON.SBRIDGE'
 987       double precision kfac /2.4d0/
 988       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 989 c      facT=temp0/t_bath
 990 c      facT=2*temp0/(t_bath+temp0)
 991       if (rescale_mode.eq.0) then
 992         facT=1.0d0
 993         facT2=1.0d0
 994         facT3=1.0d0
 995         facT4=1.0d0
 996         facT5=1.0d0
 997       else if (rescale_mode.eq.1) then
 998         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 999         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1000         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1001         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1002         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1003       else if (rescale_mode.eq.2) then
1004         x=t_bath/temp0
1005         x2=x*x
1006         x3=x2*x
1007         x4=x3*x
1008         x5=x4*x
1009         facT=licznik/dlog(dexp(x)+dexp(-x))
1010         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1011         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1012         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1013         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1014       else
1015         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1016         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1017 #ifdef MPI
1018        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1019 #endif
1020        stop 555
1021       endif
1022       welec=weights(3)*fact
1023       wcorr=weights(4)*fact3
1024       wcorr5=weights(5)*fact4
1025       wcorr6=weights(6)*fact5
1026       wel_loc=weights(7)*fact2
1027       wturn3=weights(8)*fact2
1028       wturn4=weights(9)*fact3
1029       wturn6=weights(10)*fact5
1030       wtor=weights(13)*fact
1031       wtor_d=weights(14)*fact2
1032       wsccor=weights(21)*fact
1033 #ifdef TSCSC
1034 c      wsct=t_bath/temp0
1035       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1036 #endif
1037       return
1038       end
1039 C------------------------------------------------------------------------
1040       subroutine enerprint(energia)
1041       implicit real*8 (a-h,o-z)
1042       include 'DIMENSIONS'
1043       include 'COMMON.IOUNITS'
1044       include 'COMMON.FFIELD'
1045       include 'COMMON.SBRIDGE'
1046       include 'COMMON.MD'
1047       double precision energia(0:n_ene)
1048       etot=energia(0)
1049 #ifdef TSCSC
1050       evdw=energia(22)+wsct*energia(23)
1051 #else
1052       evdw=energia(1)
1053 #endif
1054       evdw2=energia(2)
1055 #ifdef SCP14
1056       evdw2=energia(2)+energia(18)
1057 #else
1058       evdw2=energia(2)
1059 #endif
1060       ees=energia(3)
1061 #ifdef SPLITELE
1062       evdw1=energia(16)
1063 #endif
1064       ecorr=energia(4)
1065       ecorr5=energia(5)
1066       ecorr6=energia(6)
1067       eel_loc=energia(7)
1068       eello_turn3=energia(8)
1069       eello_turn4=energia(9)
1070       eello_turn6=energia(10)
1071       ebe=energia(11)
1072       escloc=energia(12)
1073       etors=energia(13)
1074       etors_d=energia(14)
1075       ehpb=energia(15)
1076       edihcnstr=energia(19)
1077       estr=energia(17)
1078       Uconst=energia(20)
1079       esccor=energia(21)
1080 C     Bartek
1081       edfadis = energia(24)
1082       edfator = energia(25)
1083       edfanei = energia(26)
1084       edfabet = energia(27)
1085 #ifdef SPLITELE
1086       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1087      &  estr,wbond,ebe,wang,
1088      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1089      &  ecorr,wcorr,
1090      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1091      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1092      &  edihcnstr,ebr*nss,
1093      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
1094    10 format (/'Virtual-chain energies:'//
1095      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1096      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1097      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1098      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1099      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1100      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1101      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1102      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1103      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1104      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1105      & ' (SS bridges & dist. cnstr.)'/
1106      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1107      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1108      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1109      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1110      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1111      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1112      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1113      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1114      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1115      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1116      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1117      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1118      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1119      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1120      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1121      & 'ETOT=  ',1pE16.6,' (total)')
1122 #else
1123       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1124      &  estr,wbond,ebe,wang,
1125      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1126      &  ecorr,wcorr,
1127      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1128      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1129      &  ebr*nss,
1130      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
1131    10 format (/'Virtual-chain energies:'//
1132      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1133      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1134      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1135      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1136      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1137      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1138      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1139      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1140      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1141      & ' (SS bridges & dist. cnstr.)'/
1142      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1143      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1144      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1145      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1146      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1147      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1148      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1149      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1150      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1151      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1152      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1153      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1154      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1155      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1156      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1157      & 'ETOT=  ',1pE16.6,' (total)')
1158 #endif
1159       return
1160       end
1161 C-----------------------------------------------------------------------
1162       subroutine elj(evdw,evdw_p,evdw_m)
1163 C
1164 C This subroutine calculates the interaction energy of nonbonded side chains
1165 C assuming the LJ potential of interaction.
1166 C
1167       implicit real*8 (a-h,o-z)
1168       include 'DIMENSIONS'
1169       parameter (accur=1.0d-10)
1170       include 'COMMON.GEO'
1171       include 'COMMON.VAR'
1172       include 'COMMON.LOCAL'
1173       include 'COMMON.CHAIN'
1174       include 'COMMON.DERIV'
1175       include 'COMMON.INTERACT'
1176       include 'COMMON.TORSION'
1177       include 'COMMON.SBRIDGE'
1178       include 'COMMON.NAMES'
1179       include 'COMMON.IOUNITS'
1180       include 'COMMON.CONTACTS'
1181       dimension gg(3)
1182 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1183       evdw=0.0D0
1184       do i=iatsc_s,iatsc_e
1185         itypi=itype(i)
1186         itypi1=itype(i+1)
1187         xi=c(1,nres+i)
1188         yi=c(2,nres+i)
1189         zi=c(3,nres+i)
1190 C Change 12/1/95
1191         num_conti=0
1192 C
1193 C Calculate SC interaction energy.
1194 C
1195         do iint=1,nint_gr(i)
1196 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1197 cd   &                  'iend=',iend(i,iint)
1198           do j=istart(i,iint),iend(i,iint)
1199             itypj=itype(j)
1200             xj=c(1,nres+j)-xi
1201             yj=c(2,nres+j)-yi
1202             zj=c(3,nres+j)-zi
1203 C Change 12/1/95 to calculate four-body interactions
1204             rij=xj*xj+yj*yj+zj*zj
1205             rrij=1.0D0/rij
1206 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1207             eps0ij=eps(itypi,itypj)
1208             fac=rrij**expon2
1209             e1=fac*fac*aa(itypi,itypj)
1210             e2=fac*bb(itypi,itypj)
1211             evdwij=e1+e2
1212 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1213 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1214 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1215 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1216 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1217 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1218 #ifdef TSCSC
1219             if (bb(itypi,itypj).gt.0) then
1220                evdw_p=evdw_p+evdwij
1221             else
1222                evdw_m=evdw_m+evdwij
1223             endif
1224 #else
1225             evdw=evdw+evdwij
1226 #endif
1227 C
1228 C Calculate the components of the gradient in DC and X
1229 C
1230             fac=-rrij*(e1+evdwij)
1231             gg(1)=xj*fac
1232             gg(2)=yj*fac
1233             gg(3)=zj*fac
1234 #ifdef TSCSC
1235             if (bb(itypi,itypj).gt.0.0d0) then
1236               do k=1,3
1237                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1238                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1239                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1240                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1241               enddo
1242             else
1243               do k=1,3
1244                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1245                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1246                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1247                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1248               enddo
1249             endif
1250 #else
1251             do k=1,3
1252               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1253               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1254               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1255               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1256             enddo
1257 #endif
1258 cgrad            do k=i,j-1
1259 cgrad              do l=1,3
1260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1261 cgrad              enddo
1262 cgrad            enddo
1263 C
1264 C 12/1/95, revised on 5/20/97
1265 C
1266 C Calculate the contact function. The ith column of the array JCONT will
1267 C contain the numbers of atoms that make contacts with the atom I (of numbers
1268 C greater than I). The arrays FACONT and GACONT will contain the values of
1269 C the contact function and its derivative.
1270 C
1271 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1272 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1273 C Uncomment next line, if the correlation interactions are contact function only
1274             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1275               rij=dsqrt(rij)
1276               sigij=sigma(itypi,itypj)
1277               r0ij=rs0(itypi,itypj)
1278 C
1279 C Check whether the SC's are not too far to make a contact.
1280 C
1281               rcut=1.5d0*r0ij
1282               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1283 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1284 C
1285               if (fcont.gt.0.0D0) then
1286 C If the SC-SC distance if close to sigma, apply spline.
1287 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1288 cAdam &             fcont1,fprimcont1)
1289 cAdam           fcont1=1.0d0-fcont1
1290 cAdam           if (fcont1.gt.0.0d0) then
1291 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1292 cAdam             fcont=fcont*fcont1
1293 cAdam           endif
1294 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1295 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1296 cga             do k=1,3
1297 cga               gg(k)=gg(k)*eps0ij
1298 cga             enddo
1299 cga             eps0ij=-evdwij*eps0ij
1300 C Uncomment for AL's type of SC correlation interactions.
1301 cadam           eps0ij=-evdwij
1302                 num_conti=num_conti+1
1303                 jcont(num_conti,i)=j
1304                 facont(num_conti,i)=fcont*eps0ij
1305                 fprimcont=eps0ij*fprimcont/rij
1306                 fcont=expon*fcont
1307 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1308 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1309 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1310 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1311                 gacont(1,num_conti,i)=-fprimcont*xj
1312                 gacont(2,num_conti,i)=-fprimcont*yj
1313                 gacont(3,num_conti,i)=-fprimcont*zj
1314 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1315 cd              write (iout,'(2i3,3f10.5)')
1316 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1317               endif
1318             endif
1319           enddo      ! j
1320         enddo        ! iint
1321 C Change 12/1/95
1322         num_cont(i)=num_conti
1323       enddo          ! i
1324       do i=1,nct
1325         do j=1,3
1326           gvdwc(j,i)=expon*gvdwc(j,i)
1327           gvdwx(j,i)=expon*gvdwx(j,i)
1328         enddo
1329       enddo
1330 C******************************************************************************
1331 C
1332 C                              N O T E !!!
1333 C
1334 C To save time, the factor of EXPON has been extracted from ALL components
1335 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1336 C use!
1337 C
1338 C******************************************************************************
1339       return
1340       end
1341 C-----------------------------------------------------------------------------
1342       subroutine eljk(evdw,evdw_p,evdw_m)
1343 C
1344 C This subroutine calculates the interaction energy of nonbonded side chains
1345 C assuming the LJK potential of interaction.
1346 C
1347       implicit real*8 (a-h,o-z)
1348       include 'DIMENSIONS'
1349       include 'COMMON.GEO'
1350       include 'COMMON.VAR'
1351       include 'COMMON.LOCAL'
1352       include 'COMMON.CHAIN'
1353       include 'COMMON.DERIV'
1354       include 'COMMON.INTERACT'
1355       include 'COMMON.IOUNITS'
1356       include 'COMMON.NAMES'
1357       dimension gg(3)
1358       logical scheck
1359 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1360       evdw=0.0D0
1361       do i=iatsc_s,iatsc_e
1362         itypi=itype(i)
1363         itypi1=itype(i+1)
1364         xi=c(1,nres+i)
1365         yi=c(2,nres+i)
1366         zi=c(3,nres+i)
1367 C
1368 C Calculate SC interaction energy.
1369 C
1370         do iint=1,nint_gr(i)
1371           do j=istart(i,iint),iend(i,iint)
1372             itypj=itype(j)
1373             xj=c(1,nres+j)-xi
1374             yj=c(2,nres+j)-yi
1375             zj=c(3,nres+j)-zi
1376             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1377             fac_augm=rrij**expon
1378             e_augm=augm(itypi,itypj)*fac_augm
1379             r_inv_ij=dsqrt(rrij)
1380             rij=1.0D0/r_inv_ij
1381             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1382             fac=r_shift_inv**expon
1383             e1=fac*fac*aa(itypi,itypj)
1384             e2=fac*bb(itypi,itypj)
1385             evdwij=e_augm+e1+e2
1386 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1387 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1388 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1389 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1390 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1391 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1392 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1393 #ifdef TSCSC
1394             if (bb(itypi,itypj).gt.0) then
1395                evdw_p=evdw_p+evdwij
1396             else
1397                evdw_m=evdw_m+evdwij
1398             endif
1399 #else
1400             evdw=evdw+evdwij
1401 #endif
1402 C
1403 C Calculate the components of the gradient in DC and X
1404 C
1405             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1406             gg(1)=xj*fac
1407             gg(2)=yj*fac
1408             gg(3)=zj*fac
1409 #ifdef TSCSC
1410             if (bb(itypi,itypj).gt.0.0d0) then
1411               do k=1,3
1412                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1413                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1414                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1415                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1416               enddo
1417             else
1418               do k=1,3
1419                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1420                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1421                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1422                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1423               enddo
1424             endif
1425 #else
1426             do k=1,3
1427               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1428               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1429               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1430               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1431             enddo
1432 #endif
1433 cgrad            do k=i,j-1
1434 cgrad              do l=1,3
1435 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1436 cgrad              enddo
1437 cgrad            enddo
1438           enddo      ! j
1439         enddo        ! iint
1440       enddo          ! i
1441       do i=1,nct
1442         do j=1,3
1443           gvdwc(j,i)=expon*gvdwc(j,i)
1444           gvdwx(j,i)=expon*gvdwx(j,i)
1445         enddo
1446       enddo
1447       return
1448       end
1449 C-----------------------------------------------------------------------------
1450       subroutine ebp(evdw,evdw_p,evdw_m)
1451 C
1452 C This subroutine calculates the interaction energy of nonbonded side chains
1453 C assuming the Berne-Pechukas potential of interaction.
1454 C
1455       implicit real*8 (a-h,o-z)
1456       include 'DIMENSIONS'
1457       include 'COMMON.GEO'
1458       include 'COMMON.VAR'
1459       include 'COMMON.LOCAL'
1460       include 'COMMON.CHAIN'
1461       include 'COMMON.DERIV'
1462       include 'COMMON.NAMES'
1463       include 'COMMON.INTERACT'
1464       include 'COMMON.IOUNITS'
1465       include 'COMMON.CALC'
1466       common /srutu/ icall
1467 c     double precision rrsave(maxdim)
1468       logical lprn
1469       evdw=0.0D0
1470 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1471       evdw=0.0D0
1472 c     if (icall.eq.0) then
1473 c       lprn=.true.
1474 c     else
1475         lprn=.false.
1476 c     endif
1477       ind=0
1478       do i=iatsc_s,iatsc_e
1479         itypi=itype(i)
1480         itypi1=itype(i+1)
1481         xi=c(1,nres+i)
1482         yi=c(2,nres+i)
1483         zi=c(3,nres+i)
1484         dxi=dc_norm(1,nres+i)
1485         dyi=dc_norm(2,nres+i)
1486         dzi=dc_norm(3,nres+i)
1487 c        dsci_inv=dsc_inv(itypi)
1488         dsci_inv=vbld_inv(i+nres)
1489 C
1490 C Calculate SC interaction energy.
1491 C
1492         do iint=1,nint_gr(i)
1493           do j=istart(i,iint),iend(i,iint)
1494             ind=ind+1
1495             itypj=itype(j)
1496 c            dscj_inv=dsc_inv(itypj)
1497             dscj_inv=vbld_inv(j+nres)
1498             chi1=chi(itypi,itypj)
1499             chi2=chi(itypj,itypi)
1500             chi12=chi1*chi2
1501             chip1=chip(itypi)
1502             chip2=chip(itypj)
1503             chip12=chip1*chip2
1504             alf1=alp(itypi)
1505             alf2=alp(itypj)
1506             alf12=0.5D0*(alf1+alf2)
1507 C For diagnostics only!!!
1508 c           chi1=0.0D0
1509 c           chi2=0.0D0
1510 c           chi12=0.0D0
1511 c           chip1=0.0D0
1512 c           chip2=0.0D0
1513 c           chip12=0.0D0
1514 c           alf1=0.0D0
1515 c           alf2=0.0D0
1516 c           alf12=0.0D0
1517             xj=c(1,nres+j)-xi
1518             yj=c(2,nres+j)-yi
1519             zj=c(3,nres+j)-zi
1520             dxj=dc_norm(1,nres+j)
1521             dyj=dc_norm(2,nres+j)
1522             dzj=dc_norm(3,nres+j)
1523             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1524 cd          if (icall.eq.0) then
1525 cd            rrsave(ind)=rrij
1526 cd          else
1527 cd            rrij=rrsave(ind)
1528 cd          endif
1529             rij=dsqrt(rrij)
1530 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1531             call sc_angular
1532 C Calculate whole angle-dependent part of epsilon and contributions
1533 C to its derivatives
1534             fac=(rrij*sigsq)**expon2
1535             e1=fac*fac*aa(itypi,itypj)
1536             e2=fac*bb(itypi,itypj)
1537             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1538             eps2der=evdwij*eps3rt
1539             eps3der=evdwij*eps2rt
1540             evdwij=evdwij*eps2rt*eps3rt
1541 #ifdef TSCSC
1542             if (bb(itypi,itypj).gt.0) then
1543                evdw_p=evdw_p+evdwij
1544             else
1545                evdw_m=evdw_m+evdwij
1546             endif
1547 #else
1548             evdw=evdw+evdwij
1549 #endif
1550             if (lprn) then
1551             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1552             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1553 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1554 cd     &        restyp(itypi),i,restyp(itypj),j,
1555 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1556 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1557 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1558 cd     &        evdwij
1559             endif
1560 C Calculate gradient components.
1561             e1=e1*eps1*eps2rt**2*eps3rt**2
1562             fac=-expon*(e1+evdwij)
1563             sigder=fac/sigsq
1564             fac=rrij*fac
1565 C Calculate radial part of the gradient
1566             gg(1)=xj*fac
1567             gg(2)=yj*fac
1568             gg(3)=zj*fac
1569 C Calculate the angular part of the gradient and sum add the contributions
1570 C to the appropriate components of the Cartesian gradient.
1571 #ifdef TSCSC
1572             if (bb(itypi,itypj).gt.0) then
1573                call sc_grad
1574             else
1575                call sc_grad_T
1576             endif
1577 #else
1578             call sc_grad
1579 #endif
1580           enddo      ! j
1581         enddo        ! iint
1582       enddo          ! i
1583 c     stop
1584       return
1585       end
1586 C-----------------------------------------------------------------------------
1587       subroutine egb(evdw,evdw_p,evdw_m)
1588 C
1589 C This subroutine calculates the interaction energy of nonbonded side chains
1590 C assuming the Gay-Berne potential of interaction.
1591 C
1592       implicit real*8 (a-h,o-z)
1593       include 'DIMENSIONS'
1594       include 'COMMON.GEO'
1595       include 'COMMON.VAR'
1596       include 'COMMON.LOCAL'
1597       include 'COMMON.CHAIN'
1598       include 'COMMON.DERIV'
1599       include 'COMMON.NAMES'
1600       include 'COMMON.INTERACT'
1601       include 'COMMON.IOUNITS'
1602       include 'COMMON.CALC'
1603       include 'COMMON.CONTROL'
1604       logical lprn
1605       evdw=0.0D0
1606 ccccc      energy_dec=.false.
1607 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1608       evdw=0.0D0
1609       evdw_p=0.0D0
1610       evdw_m=0.0D0
1611       lprn=.false.
1612 c     if (icall.eq.0) lprn=.false.
1613       ind=0
1614       do i=iatsc_s,iatsc_e
1615         itypi=itype(i)
1616         itypi1=itype(i+1)
1617         xi=c(1,nres+i)
1618         yi=c(2,nres+i)
1619         zi=c(3,nres+i)
1620         dxi=dc_norm(1,nres+i)
1621         dyi=dc_norm(2,nres+i)
1622         dzi=dc_norm(3,nres+i)
1623 c        dsci_inv=dsc_inv(itypi)
1624         dsci_inv=vbld_inv(i+nres)
1625 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1626 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1627 C
1628 C Calculate SC interaction energy.
1629 C
1630         do iint=1,nint_gr(i)
1631           do j=istart(i,iint),iend(i,iint)
1632             ind=ind+1
1633             itypj=itype(j)
1634 c            dscj_inv=dsc_inv(itypj)
1635             dscj_inv=vbld_inv(j+nres)
1636 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1637 c     &       1.0d0/vbld(j+nres)
1638 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1639             sig0ij=sigma(itypi,itypj)
1640             chi1=chi(itypi,itypj)
1641             chi2=chi(itypj,itypi)
1642             chi12=chi1*chi2
1643             chip1=chip(itypi)
1644             chip2=chip(itypj)
1645             chip12=chip1*chip2
1646             alf1=alp(itypi)
1647             alf2=alp(itypj)
1648             alf12=0.5D0*(alf1+alf2)
1649 C For diagnostics only!!!
1650 c           chi1=0.0D0
1651 c           chi2=0.0D0
1652 c           chi12=0.0D0
1653 c           chip1=0.0D0
1654 c           chip2=0.0D0
1655 c           chip12=0.0D0
1656 c           alf1=0.0D0
1657 c           alf2=0.0D0
1658 c           alf12=0.0D0
1659             xj=c(1,nres+j)-xi
1660             yj=c(2,nres+j)-yi
1661             zj=c(3,nres+j)-zi
1662             dxj=dc_norm(1,nres+j)
1663             dyj=dc_norm(2,nres+j)
1664             dzj=dc_norm(3,nres+j)
1665 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1666 c            write (iout,*) "j",j," dc_norm",
1667 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1668             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1669             rij=dsqrt(rrij)
1670 C Calculate angle-dependent terms of energy and contributions to their
1671 C derivatives.
1672             call sc_angular
1673             sigsq=1.0D0/sigsq
1674             sig=sig0ij*dsqrt(sigsq)
1675             rij_shift=1.0D0/rij-sig+sig0ij
1676 c for diagnostics; uncomment
1677 c            rij_shift=1.2*sig0ij
1678 C I hate to put IF's in the loops, but here don't have another choice!!!!
1679             if (rij_shift.le.0.0D0) then
1680               evdw=1.0D20
1681 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1682 cd     &        restyp(itypi),i,restyp(itypj),j,
1683 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1684               return
1685             endif
1686             sigder=-sig*sigsq
1687 c---------------------------------------------------------------
1688             rij_shift=1.0D0/rij_shift
1689             fac=rij_shift**expon
1690             e1=fac*fac*aa(itypi,itypj)
1691             e2=fac*bb(itypi,itypj)
1692             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1693             eps2der=evdwij*eps3rt
1694             eps3der=evdwij*eps2rt
1695 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1696 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1697             evdwij=evdwij*eps2rt*eps3rt
1698 #ifdef TSCSC
1699             if (bb(itypi,itypj).gt.0) then
1700                evdw_p=evdw_p+evdwij
1701             else
1702                evdw_m=evdw_m+evdwij
1703             endif
1704 #else
1705             evdw=evdw+evdwij
1706 #endif
1707             if (lprn) then
1708             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1709             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1710             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1711      &        restyp(itypi),i,restyp(itypj),j,
1712      &        epsi,sigm,chi1,chi2,chip1,chip2,
1713      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1714      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1715      &        evdwij
1716             endif
1717
1718             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1719      &                        'evdw',i,j,evdwij
1720
1721 C Calculate gradient components.
1722             e1=e1*eps1*eps2rt**2*eps3rt**2
1723             fac=-expon*(e1+evdwij)*rij_shift
1724             sigder=fac*sigder
1725             fac=rij*fac
1726 c            fac=0.0d0
1727 C Calculate the radial part of the gradient
1728             gg(1)=xj*fac
1729             gg(2)=yj*fac
1730             gg(3)=zj*fac
1731 C Calculate angular part of the gradient.
1732 #ifdef TSCSC
1733             if (bb(itypi,itypj).gt.0) then
1734                call sc_grad
1735             else
1736                call sc_grad_T
1737             endif
1738 #else
1739             call sc_grad
1740 #endif
1741           enddo      ! j
1742         enddo        ! iint
1743       enddo          ! i
1744 c      write (iout,*) "Number of loop steps in EGB:",ind
1745 cccc      energy_dec=.false.
1746       return
1747       end
1748 C-----------------------------------------------------------------------------
1749       subroutine egbv(evdw,evdw_p,evdw_m)
1750 C
1751 C This subroutine calculates the interaction energy of nonbonded side chains
1752 C assuming the Gay-Berne-Vorobjev potential of interaction.
1753 C
1754       implicit real*8 (a-h,o-z)
1755       include 'DIMENSIONS'
1756       include 'COMMON.GEO'
1757       include 'COMMON.VAR'
1758       include 'COMMON.LOCAL'
1759       include 'COMMON.CHAIN'
1760       include 'COMMON.DERIV'
1761       include 'COMMON.NAMES'
1762       include 'COMMON.INTERACT'
1763       include 'COMMON.IOUNITS'
1764       include 'COMMON.CALC'
1765       common /srutu/ icall
1766       logical lprn
1767       evdw=0.0D0
1768 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1769       evdw=0.0D0
1770       lprn=.false.
1771 c     if (icall.eq.0) lprn=.true.
1772       ind=0
1773       do i=iatsc_s,iatsc_e
1774         itypi=itype(i)
1775         itypi1=itype(i+1)
1776         xi=c(1,nres+i)
1777         yi=c(2,nres+i)
1778         zi=c(3,nres+i)
1779         dxi=dc_norm(1,nres+i)
1780         dyi=dc_norm(2,nres+i)
1781         dzi=dc_norm(3,nres+i)
1782 c        dsci_inv=dsc_inv(itypi)
1783         dsci_inv=vbld_inv(i+nres)
1784 C
1785 C Calculate SC interaction energy.
1786 C
1787         do iint=1,nint_gr(i)
1788           do j=istart(i,iint),iend(i,iint)
1789             ind=ind+1
1790             itypj=itype(j)
1791 c            dscj_inv=dsc_inv(itypj)
1792             dscj_inv=vbld_inv(j+nres)
1793             sig0ij=sigma(itypi,itypj)
1794             r0ij=r0(itypi,itypj)
1795             chi1=chi(itypi,itypj)
1796             chi2=chi(itypj,itypi)
1797             chi12=chi1*chi2
1798             chip1=chip(itypi)
1799             chip2=chip(itypj)
1800             chip12=chip1*chip2
1801             alf1=alp(itypi)
1802             alf2=alp(itypj)
1803             alf12=0.5D0*(alf1+alf2)
1804 C For diagnostics only!!!
1805 c           chi1=0.0D0
1806 c           chi2=0.0D0
1807 c           chi12=0.0D0
1808 c           chip1=0.0D0
1809 c           chip2=0.0D0
1810 c           chip12=0.0D0
1811 c           alf1=0.0D0
1812 c           alf2=0.0D0
1813 c           alf12=0.0D0
1814             xj=c(1,nres+j)-xi
1815             yj=c(2,nres+j)-yi
1816             zj=c(3,nres+j)-zi
1817             dxj=dc_norm(1,nres+j)
1818             dyj=dc_norm(2,nres+j)
1819             dzj=dc_norm(3,nres+j)
1820             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1821             rij=dsqrt(rrij)
1822 C Calculate angle-dependent terms of energy and contributions to their
1823 C derivatives.
1824             call sc_angular
1825             sigsq=1.0D0/sigsq
1826             sig=sig0ij*dsqrt(sigsq)
1827             rij_shift=1.0D0/rij-sig+r0ij
1828 C I hate to put IF's in the loops, but here don't have another choice!!!!
1829             if (rij_shift.le.0.0D0) then
1830               evdw=1.0D20
1831               return
1832             endif
1833             sigder=-sig*sigsq
1834 c---------------------------------------------------------------
1835             rij_shift=1.0D0/rij_shift
1836             fac=rij_shift**expon
1837             e1=fac*fac*aa(itypi,itypj)
1838             e2=fac*bb(itypi,itypj)
1839             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1840             eps2der=evdwij*eps3rt
1841             eps3der=evdwij*eps2rt
1842             fac_augm=rrij**expon
1843             e_augm=augm(itypi,itypj)*fac_augm
1844             evdwij=evdwij*eps2rt*eps3rt
1845 #ifdef TSCSC
1846             if (bb(itypi,itypj).gt.0) then
1847                evdw_p=evdw_p+evdwij+e_augm
1848             else
1849                evdw_m=evdw_m+evdwij+e_augm
1850             endif
1851 #else
1852             evdw=evdw+evdwij+e_augm
1853 #endif
1854             if (lprn) then
1855             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1856             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1857             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1858      &        restyp(itypi),i,restyp(itypj),j,
1859      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1860      &        chi1,chi2,chip1,chip2,
1861      &        eps1,eps2rt**2,eps3rt**2,
1862      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1863      &        evdwij+e_augm
1864             endif
1865 C Calculate gradient components.
1866             e1=e1*eps1*eps2rt**2*eps3rt**2
1867             fac=-expon*(e1+evdwij)*rij_shift
1868             sigder=fac*sigder
1869             fac=rij*fac-2*expon*rrij*e_augm
1870 C Calculate the radial part of the gradient
1871             gg(1)=xj*fac
1872             gg(2)=yj*fac
1873             gg(3)=zj*fac
1874 C Calculate angular part of the gradient.
1875 #ifdef TSCSC
1876             if (bb(itypi,itypj).gt.0) then
1877                call sc_grad
1878             else
1879                call sc_grad_T
1880             endif
1881 #else
1882             call sc_grad
1883 #endif
1884           enddo      ! j
1885         enddo        ! iint
1886       enddo          ! i
1887       end
1888 C-----------------------------------------------------------------------------
1889       subroutine sc_angular
1890 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1891 C om12. Called by ebp, egb, and egbv.
1892       implicit none
1893       include 'COMMON.CALC'
1894       include 'COMMON.IOUNITS'
1895       erij(1)=xj*rij
1896       erij(2)=yj*rij
1897       erij(3)=zj*rij
1898       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1899       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1900       om12=dxi*dxj+dyi*dyj+dzi*dzj
1901       chiom12=chi12*om12
1902 C Calculate eps1(om12) and its derivative in om12
1903       faceps1=1.0D0-om12*chiom12
1904       faceps1_inv=1.0D0/faceps1
1905       eps1=dsqrt(faceps1_inv)
1906 C Following variable is eps1*deps1/dom12
1907       eps1_om12=faceps1_inv*chiom12
1908 c diagnostics only
1909 c      faceps1_inv=om12
1910 c      eps1=om12
1911 c      eps1_om12=1.0d0
1912 c      write (iout,*) "om12",om12," eps1",eps1
1913 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1914 C and om12.
1915       om1om2=om1*om2
1916       chiom1=chi1*om1
1917       chiom2=chi2*om2
1918       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1919       sigsq=1.0D0-facsig*faceps1_inv
1920       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1921       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1922       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1923 c diagnostics only
1924 c      sigsq=1.0d0
1925 c      sigsq_om1=0.0d0
1926 c      sigsq_om2=0.0d0
1927 c      sigsq_om12=0.0d0
1928 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1929 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1930 c     &    " eps1",eps1
1931 C Calculate eps2 and its derivatives in om1, om2, and om12.
1932       chipom1=chip1*om1
1933       chipom2=chip2*om2
1934       chipom12=chip12*om12
1935       facp=1.0D0-om12*chipom12
1936       facp_inv=1.0D0/facp
1937       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1938 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1939 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1940 C Following variable is the square root of eps2
1941       eps2rt=1.0D0-facp1*facp_inv
1942 C Following three variables are the derivatives of the square root of eps
1943 C in om1, om2, and om12.
1944       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1945       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1946       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1947 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1948       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1949 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1950 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1951 c     &  " eps2rt_om12",eps2rt_om12
1952 C Calculate whole angle-dependent part of epsilon and contributions
1953 C to its derivatives
1954       return
1955       end
1956
1957 C----------------------------------------------------------------------------
1958       subroutine sc_grad_T
1959       implicit real*8 (a-h,o-z)
1960       include 'DIMENSIONS'
1961       include 'COMMON.CHAIN'
1962       include 'COMMON.DERIV'
1963       include 'COMMON.CALC'
1964       include 'COMMON.IOUNITS'
1965       double precision dcosom1(3),dcosom2(3)
1966       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1967       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1968       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1969      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1970 c diagnostics only
1971 c      eom1=0.0d0
1972 c      eom2=0.0d0
1973 c      eom12=evdwij*eps1_om12
1974 c end diagnostics
1975 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1976 c     &  " sigder",sigder
1977 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1978 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1979       do k=1,3
1980         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1981         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1982       enddo
1983       do k=1,3
1984         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1985       enddo
1986 c      write (iout,*) "gg",(gg(k),k=1,3)
1987       do k=1,3
1988         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1989      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1990      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1991         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1992      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1993      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1994 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1995 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1996 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1997 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1998       enddo
1999 C
2000 C Calculate the components of the gradient in DC and X
2001 C
2002 cgrad      do k=i,j-1
2003 cgrad        do l=1,3
2004 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2005 cgrad        enddo
2006 cgrad      enddo
2007       do l=1,3
2008         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2009         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2010       enddo
2011       return
2012       end
2013
2014 C----------------------------------------------------------------------------
2015       subroutine sc_grad
2016       implicit real*8 (a-h,o-z)
2017       include 'DIMENSIONS'
2018       include 'COMMON.CHAIN'
2019       include 'COMMON.DERIV'
2020       include 'COMMON.CALC'
2021       include 'COMMON.IOUNITS'
2022       double precision dcosom1(3),dcosom2(3)
2023       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2024       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2025       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2026      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2027 c diagnostics only
2028 c      eom1=0.0d0
2029 c      eom2=0.0d0
2030 c      eom12=evdwij*eps1_om12
2031 c end diagnostics
2032 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2033 c     &  " sigder",sigder
2034 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2035 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2036       do k=1,3
2037         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2038         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2039       enddo
2040       do k=1,3
2041         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2042       enddo
2043 c      write (iout,*) "gg",(gg(k),k=1,3)
2044       do k=1,3
2045         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2046      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2047      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2048         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2049      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2050      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2051 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2052 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2053 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2054 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2055       enddo
2056 C
2057 C Calculate the components of the gradient in DC and X
2058 C
2059 cgrad      do k=i,j-1
2060 cgrad        do l=1,3
2061 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2062 cgrad        enddo
2063 cgrad      enddo
2064       do l=1,3
2065         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2066         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2067       enddo
2068       return
2069       end
2070 C-----------------------------------------------------------------------
2071       subroutine e_softsphere(evdw)
2072 C
2073 C This subroutine calculates the interaction energy of nonbonded side chains
2074 C assuming the LJ potential of interaction.
2075 C
2076       implicit real*8 (a-h,o-z)
2077       include 'DIMENSIONS'
2078       parameter (accur=1.0d-10)
2079       include 'COMMON.GEO'
2080       include 'COMMON.VAR'
2081       include 'COMMON.LOCAL'
2082       include 'COMMON.CHAIN'
2083       include 'COMMON.DERIV'
2084       include 'COMMON.INTERACT'
2085       include 'COMMON.TORSION'
2086       include 'COMMON.SBRIDGE'
2087       include 'COMMON.NAMES'
2088       include 'COMMON.IOUNITS'
2089       include 'COMMON.CONTACTS'
2090       dimension gg(3)
2091 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2092       evdw=0.0D0
2093       do i=iatsc_s,iatsc_e
2094         itypi=itype(i)
2095         itypi1=itype(i+1)
2096         xi=c(1,nres+i)
2097         yi=c(2,nres+i)
2098         zi=c(3,nres+i)
2099 C
2100 C Calculate SC interaction energy.
2101 C
2102         do iint=1,nint_gr(i)
2103 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2104 cd   &                  'iend=',iend(i,iint)
2105           do j=istart(i,iint),iend(i,iint)
2106             itypj=itype(j)
2107             xj=c(1,nres+j)-xi
2108             yj=c(2,nres+j)-yi
2109             zj=c(3,nres+j)-zi
2110             rij=xj*xj+yj*yj+zj*zj
2111 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2112             r0ij=r0(itypi,itypj)
2113             r0ijsq=r0ij*r0ij
2114 c            print *,i,j,r0ij,dsqrt(rij)
2115             if (rij.lt.r0ijsq) then
2116               evdwij=0.25d0*(rij-r0ijsq)**2
2117               fac=rij-r0ijsq
2118             else
2119               evdwij=0.0d0
2120               fac=0.0d0
2121             endif
2122             evdw=evdw+evdwij
2123 C
2124 C Calculate the components of the gradient in DC and X
2125 C
2126             gg(1)=xj*fac
2127             gg(2)=yj*fac
2128             gg(3)=zj*fac
2129             do k=1,3
2130               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2131               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2132               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2133               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2134             enddo
2135 cgrad            do k=i,j-1
2136 cgrad              do l=1,3
2137 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2138 cgrad              enddo
2139 cgrad            enddo
2140           enddo ! j
2141         enddo ! iint
2142       enddo ! i
2143       return
2144       end
2145 C--------------------------------------------------------------------------
2146       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2147      &              eello_turn4)
2148 C
2149 C Soft-sphere potential of p-p interaction
2150 C
2151       implicit real*8 (a-h,o-z)
2152       include 'DIMENSIONS'
2153       include 'COMMON.CONTROL'
2154       include 'COMMON.IOUNITS'
2155       include 'COMMON.GEO'
2156       include 'COMMON.VAR'
2157       include 'COMMON.LOCAL'
2158       include 'COMMON.CHAIN'
2159       include 'COMMON.DERIV'
2160       include 'COMMON.INTERACT'
2161       include 'COMMON.CONTACTS'
2162       include 'COMMON.TORSION'
2163       include 'COMMON.VECTORS'
2164       include 'COMMON.FFIELD'
2165       dimension ggg(3)
2166 cd      write(iout,*) 'In EELEC_soft_sphere'
2167       ees=0.0D0
2168       evdw1=0.0D0
2169       eel_loc=0.0d0
2170       eello_turn3=0.0d0
2171       eello_turn4=0.0d0
2172       ind=0
2173       do i=iatel_s,iatel_e
2174         dxi=dc(1,i)
2175         dyi=dc(2,i)
2176         dzi=dc(3,i)
2177         xmedi=c(1,i)+0.5d0*dxi
2178         ymedi=c(2,i)+0.5d0*dyi
2179         zmedi=c(3,i)+0.5d0*dzi
2180         num_conti=0
2181 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2182         do j=ielstart(i),ielend(i)
2183           ind=ind+1
2184           iteli=itel(i)
2185           itelj=itel(j)
2186           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2187           r0ij=rpp(iteli,itelj)
2188           r0ijsq=r0ij*r0ij
2189           dxj=dc(1,j)
2190           dyj=dc(2,j)
2191           dzj=dc(3,j)
2192           xj=c(1,j)+0.5D0*dxj-xmedi
2193           yj=c(2,j)+0.5D0*dyj-ymedi
2194           zj=c(3,j)+0.5D0*dzj-zmedi
2195           rij=xj*xj+yj*yj+zj*zj
2196           if (rij.lt.r0ijsq) then
2197             evdw1ij=0.25d0*(rij-r0ijsq)**2
2198             fac=rij-r0ijsq
2199           else
2200             evdw1ij=0.0d0
2201             fac=0.0d0
2202           endif
2203           evdw1=evdw1+evdw1ij
2204 C
2205 C Calculate contributions to the Cartesian gradient.
2206 C
2207           ggg(1)=fac*xj
2208           ggg(2)=fac*yj
2209           ggg(3)=fac*zj
2210           do k=1,3
2211             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2212             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2213           enddo
2214 *
2215 * Loop over residues i+1 thru j-1.
2216 *
2217 cgrad          do k=i+1,j-1
2218 cgrad            do l=1,3
2219 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2220 cgrad            enddo
2221 cgrad          enddo
2222         enddo ! j
2223       enddo   ! i
2224 cgrad      do i=nnt,nct-1
2225 cgrad        do k=1,3
2226 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2227 cgrad        enddo
2228 cgrad        do j=i+1,nct-1
2229 cgrad          do k=1,3
2230 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2231 cgrad          enddo
2232 cgrad        enddo
2233 cgrad      enddo
2234       return
2235       end
2236 c------------------------------------------------------------------------------
2237       subroutine vec_and_deriv
2238       implicit real*8 (a-h,o-z)
2239       include 'DIMENSIONS'
2240 #ifdef MPI
2241       include 'mpif.h'
2242 #endif
2243       include 'COMMON.IOUNITS'
2244       include 'COMMON.GEO'
2245       include 'COMMON.VAR'
2246       include 'COMMON.LOCAL'
2247       include 'COMMON.CHAIN'
2248       include 'COMMON.VECTORS'
2249       include 'COMMON.SETUP'
2250       include 'COMMON.TIME1'
2251       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2252 C Compute the local reference systems. For reference system (i), the
2253 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2254 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2255 #ifdef PARVEC
2256       do i=ivec_start,ivec_end
2257 #else
2258       do i=1,nres-1
2259 #endif
2260           if (i.eq.nres-1) then
2261 C Case of the last full residue
2262 C Compute the Z-axis
2263             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2264             costh=dcos(pi-theta(nres))
2265             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2266             do k=1,3
2267               uz(k,i)=fac*uz(k,i)
2268             enddo
2269 C Compute the derivatives of uz
2270             uzder(1,1,1)= 0.0d0
2271             uzder(2,1,1)=-dc_norm(3,i-1)
2272             uzder(3,1,1)= dc_norm(2,i-1)
2273             uzder(1,2,1)= dc_norm(3,i-1)
2274             uzder(2,2,1)= 0.0d0
2275             uzder(3,2,1)=-dc_norm(1,i-1)
2276             uzder(1,3,1)=-dc_norm(2,i-1)
2277             uzder(2,3,1)= dc_norm(1,i-1)
2278             uzder(3,3,1)= 0.0d0
2279             uzder(1,1,2)= 0.0d0
2280             uzder(2,1,2)= dc_norm(3,i)
2281             uzder(3,1,2)=-dc_norm(2,i)
2282             uzder(1,2,2)=-dc_norm(3,i)
2283             uzder(2,2,2)= 0.0d0
2284             uzder(3,2,2)= dc_norm(1,i)
2285             uzder(1,3,2)= dc_norm(2,i)
2286             uzder(2,3,2)=-dc_norm(1,i)
2287             uzder(3,3,2)= 0.0d0
2288 C Compute the Y-axis
2289             facy=fac
2290             do k=1,3
2291               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2292             enddo
2293 C Compute the derivatives of uy
2294             do j=1,3
2295               do k=1,3
2296                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2297      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2298                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2299               enddo
2300               uyder(j,j,1)=uyder(j,j,1)-costh
2301               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2302             enddo
2303             do j=1,2
2304               do k=1,3
2305                 do l=1,3
2306                   uygrad(l,k,j,i)=uyder(l,k,j)
2307                   uzgrad(l,k,j,i)=uzder(l,k,j)
2308                 enddo
2309               enddo
2310             enddo
2311             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2312             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2313             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2314             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2315           else
2316 C Other residues
2317 C Compute the Z-axis
2318             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2319             costh=dcos(pi-theta(i+2))
2320             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2321             do k=1,3
2322               uz(k,i)=fac*uz(k,i)
2323             enddo
2324 C Compute the derivatives of uz
2325             uzder(1,1,1)= 0.0d0
2326             uzder(2,1,1)=-dc_norm(3,i+1)
2327             uzder(3,1,1)= dc_norm(2,i+1)
2328             uzder(1,2,1)= dc_norm(3,i+1)
2329             uzder(2,2,1)= 0.0d0
2330             uzder(3,2,1)=-dc_norm(1,i+1)
2331             uzder(1,3,1)=-dc_norm(2,i+1)
2332             uzder(2,3,1)= dc_norm(1,i+1)
2333             uzder(3,3,1)= 0.0d0
2334             uzder(1,1,2)= 0.0d0
2335             uzder(2,1,2)= dc_norm(3,i)
2336             uzder(3,1,2)=-dc_norm(2,i)
2337             uzder(1,2,2)=-dc_norm(3,i)
2338             uzder(2,2,2)= 0.0d0
2339             uzder(3,2,2)= dc_norm(1,i)
2340             uzder(1,3,2)= dc_norm(2,i)
2341             uzder(2,3,2)=-dc_norm(1,i)
2342             uzder(3,3,2)= 0.0d0
2343 C Compute the Y-axis
2344             facy=fac
2345             do k=1,3
2346               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2347             enddo
2348 C Compute the derivatives of uy
2349             do j=1,3
2350               do k=1,3
2351                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2352      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2353                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2354               enddo
2355               uyder(j,j,1)=uyder(j,j,1)-costh
2356               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2357             enddo
2358             do j=1,2
2359               do k=1,3
2360                 do l=1,3
2361                   uygrad(l,k,j,i)=uyder(l,k,j)
2362                   uzgrad(l,k,j,i)=uzder(l,k,j)
2363                 enddo
2364               enddo
2365             enddo
2366             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2367             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2368             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2369             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2370           endif
2371       enddo
2372       do i=1,nres-1
2373         vbld_inv_temp(1)=vbld_inv(i+1)
2374         if (i.lt.nres-1) then
2375           vbld_inv_temp(2)=vbld_inv(i+2)
2376           else
2377           vbld_inv_temp(2)=vbld_inv(i)
2378           endif
2379         do j=1,2
2380           do k=1,3
2381             do l=1,3
2382               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2383               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2384             enddo
2385           enddo
2386         enddo
2387       enddo
2388 #if defined(PARVEC) && defined(MPI)
2389       if (nfgtasks1.gt.1) then
2390         time00=MPI_Wtime()
2391 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2392 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2393 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2394         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2395      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2396      &   FG_COMM1,IERR)
2397         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2398      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2399      &   FG_COMM1,IERR)
2400         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2401      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2402      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2403         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2404      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2405      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2406         time_gather=time_gather+MPI_Wtime()-time00
2407       endif
2408 c      if (fg_rank.eq.0) then
2409 c        write (iout,*) "Arrays UY and UZ"
2410 c        do i=1,nres-1
2411 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2412 c     &     (uz(k,i),k=1,3)
2413 c        enddo
2414 c      endif
2415 #endif
2416       return
2417       end
2418 C-----------------------------------------------------------------------------
2419       subroutine check_vecgrad
2420       implicit real*8 (a-h,o-z)
2421       include 'DIMENSIONS'
2422       include 'COMMON.IOUNITS'
2423       include 'COMMON.GEO'
2424       include 'COMMON.VAR'
2425       include 'COMMON.LOCAL'
2426       include 'COMMON.CHAIN'
2427       include 'COMMON.VECTORS'
2428       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2429       dimension uyt(3,maxres),uzt(3,maxres)
2430       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2431       double precision delta /1.0d-7/
2432       call vec_and_deriv
2433 cd      do i=1,nres
2434 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2435 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2436 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2437 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2438 cd     &     (dc_norm(if90,i),if90=1,3)
2439 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2440 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2441 cd          write(iout,'(a)')
2442 cd      enddo
2443       do i=1,nres
2444         do j=1,2
2445           do k=1,3
2446             do l=1,3
2447               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2448               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2449             enddo
2450           enddo
2451         enddo
2452       enddo
2453       call vec_and_deriv
2454       do i=1,nres
2455         do j=1,3
2456           uyt(j,i)=uy(j,i)
2457           uzt(j,i)=uz(j,i)
2458         enddo
2459       enddo
2460       do i=1,nres
2461 cd        write (iout,*) 'i=',i
2462         do k=1,3
2463           erij(k)=dc_norm(k,i)
2464         enddo
2465         do j=1,3
2466           do k=1,3
2467             dc_norm(k,i)=erij(k)
2468           enddo
2469           dc_norm(j,i)=dc_norm(j,i)+delta
2470 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2471 c          do k=1,3
2472 c            dc_norm(k,i)=dc_norm(k,i)/fac
2473 c          enddo
2474 c          write (iout,*) (dc_norm(k,i),k=1,3)
2475 c          write (iout,*) (erij(k),k=1,3)
2476           call vec_and_deriv
2477           do k=1,3
2478             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2479             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2480             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2481             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2482           enddo
2483 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2484 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2485 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2486         enddo
2487         do k=1,3
2488           dc_norm(k,i)=erij(k)
2489         enddo
2490 cd        do k=1,3
2491 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2492 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2493 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2494 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2495 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2496 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2497 cd          write (iout,'(a)')
2498 cd        enddo
2499       enddo
2500       return
2501       end
2502 C--------------------------------------------------------------------------
2503       subroutine set_matrices
2504       implicit real*8 (a-h,o-z)
2505       include 'DIMENSIONS'
2506 #ifdef MPI
2507       include "mpif.h"
2508       include "COMMON.SETUP"
2509       integer IERR
2510       integer status(MPI_STATUS_SIZE)
2511 #endif
2512       include 'COMMON.IOUNITS'
2513       include 'COMMON.GEO'
2514       include 'COMMON.VAR'
2515       include 'COMMON.LOCAL'
2516       include 'COMMON.CHAIN'
2517       include 'COMMON.DERIV'
2518       include 'COMMON.INTERACT'
2519       include 'COMMON.CONTACTS'
2520       include 'COMMON.TORSION'
2521       include 'COMMON.VECTORS'
2522       include 'COMMON.FFIELD'
2523       double precision auxvec(2),auxmat(2,2)
2524 C
2525 C Compute the virtual-bond-torsional-angle dependent quantities needed
2526 C to calculate the el-loc multibody terms of various order.
2527 C
2528 #ifdef PARMAT
2529       do i=ivec_start+2,ivec_end+2
2530 #else
2531       do i=3,nres+1
2532 #endif
2533         if (i .lt. nres+1) then
2534           sin1=dsin(phi(i))
2535           cos1=dcos(phi(i))
2536           sintab(i-2)=sin1
2537           costab(i-2)=cos1
2538           obrot(1,i-2)=cos1
2539           obrot(2,i-2)=sin1
2540           sin2=dsin(2*phi(i))
2541           cos2=dcos(2*phi(i))
2542           sintab2(i-2)=sin2
2543           costab2(i-2)=cos2
2544           obrot2(1,i-2)=cos2
2545           obrot2(2,i-2)=sin2
2546           Ug(1,1,i-2)=-cos1
2547           Ug(1,2,i-2)=-sin1
2548           Ug(2,1,i-2)=-sin1
2549           Ug(2,2,i-2)= cos1
2550           Ug2(1,1,i-2)=-cos2
2551           Ug2(1,2,i-2)=-sin2
2552           Ug2(2,1,i-2)=-sin2
2553           Ug2(2,2,i-2)= cos2
2554         else
2555           costab(i-2)=1.0d0
2556           sintab(i-2)=0.0d0
2557           obrot(1,i-2)=1.0d0
2558           obrot(2,i-2)=0.0d0
2559           obrot2(1,i-2)=0.0d0
2560           obrot2(2,i-2)=0.0d0
2561           Ug(1,1,i-2)=1.0d0
2562           Ug(1,2,i-2)=0.0d0
2563           Ug(2,1,i-2)=0.0d0
2564           Ug(2,2,i-2)=1.0d0
2565           Ug2(1,1,i-2)=0.0d0
2566           Ug2(1,2,i-2)=0.0d0
2567           Ug2(2,1,i-2)=0.0d0
2568           Ug2(2,2,i-2)=0.0d0
2569         endif
2570         if (i .gt. 3 .and. i .lt. nres+1) then
2571           obrot_der(1,i-2)=-sin1
2572           obrot_der(2,i-2)= cos1
2573           Ugder(1,1,i-2)= sin1
2574           Ugder(1,2,i-2)=-cos1
2575           Ugder(2,1,i-2)=-cos1
2576           Ugder(2,2,i-2)=-sin1
2577           dwacos2=cos2+cos2
2578           dwasin2=sin2+sin2
2579           obrot2_der(1,i-2)=-dwasin2
2580           obrot2_der(2,i-2)= dwacos2
2581           Ug2der(1,1,i-2)= dwasin2
2582           Ug2der(1,2,i-2)=-dwacos2
2583           Ug2der(2,1,i-2)=-dwacos2
2584           Ug2der(2,2,i-2)=-dwasin2
2585         else
2586           obrot_der(1,i-2)=0.0d0
2587           obrot_der(2,i-2)=0.0d0
2588           Ugder(1,1,i-2)=0.0d0
2589           Ugder(1,2,i-2)=0.0d0
2590           Ugder(2,1,i-2)=0.0d0
2591           Ugder(2,2,i-2)=0.0d0
2592           obrot2_der(1,i-2)=0.0d0
2593           obrot2_der(2,i-2)=0.0d0
2594           Ug2der(1,1,i-2)=0.0d0
2595           Ug2der(1,2,i-2)=0.0d0
2596           Ug2der(2,1,i-2)=0.0d0
2597           Ug2der(2,2,i-2)=0.0d0
2598         endif
2599 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2600         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2601           iti = itortyp(itype(i-2))
2602         else
2603           iti=ntortyp+1
2604         endif
2605 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2606         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2607           iti1 = itortyp(itype(i-1))
2608         else
2609           iti1=ntortyp+1
2610         endif
2611 cd        write (iout,*) '*******i',i,' iti1',iti
2612 cd        write (iout,*) 'b1',b1(:,iti)
2613 cd        write (iout,*) 'b2',b2(:,iti)
2614 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2615 c        if (i .gt. iatel_s+2) then
2616         if (i .gt. nnt+2) then
2617           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2618           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2619           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2620      &    then
2621           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2622           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2623           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2624           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2625           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2626           endif
2627         else
2628           do k=1,2
2629             Ub2(k,i-2)=0.0d0
2630             Ctobr(k,i-2)=0.0d0
2631             Dtobr2(k,i-2)=0.0d0
2632             do l=1,2
2633               EUg(l,k,i-2)=0.0d0
2634               CUg(l,k,i-2)=0.0d0
2635               DUg(l,k,i-2)=0.0d0
2636               DtUg2(l,k,i-2)=0.0d0
2637             enddo
2638           enddo
2639         endif
2640         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2641         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2642         do k=1,2
2643           muder(k,i-2)=Ub2der(k,i-2)
2644         enddo
2645 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2646         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2647           iti1 = itortyp(itype(i-1))
2648         else
2649           iti1=ntortyp+1
2650         endif
2651         do k=1,2
2652           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2653         enddo
2654 cd        write (iout,*) 'mu ',mu(:,i-2)
2655 cd        write (iout,*) 'mu1',mu1(:,i-2)
2656 cd        write (iout,*) 'mu2',mu2(:,i-2)
2657         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2658      &  then
2659         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2660         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2661         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2662         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2663         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2664 C Vectors and matrices dependent on a single virtual-bond dihedral.
2665         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2666         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2667         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2668         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2669         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2670         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2671         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2672         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2673         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2674         endif
2675       enddo
2676 C Matrices dependent on two consecutive virtual-bond dihedrals.
2677 C The order of matrices is from left to right.
2678       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2679      &then
2680 c      do i=max0(ivec_start,2),ivec_end
2681       do i=2,nres-1
2682         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2683         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2684         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2685         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2686         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2687         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2688         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2689         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2690       enddo
2691       endif
2692 #if defined(MPI) && defined(PARMAT)
2693 #ifdef DEBUG
2694 c      if (fg_rank.eq.0) then
2695         write (iout,*) "Arrays UG and UGDER before GATHER"
2696         do i=1,nres-1
2697           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2698      &     ((ug(l,k,i),l=1,2),k=1,2),
2699      &     ((ugder(l,k,i),l=1,2),k=1,2)
2700         enddo
2701         write (iout,*) "Arrays UG2 and UG2DER"
2702         do i=1,nres-1
2703           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2704      &     ((ug2(l,k,i),l=1,2),k=1,2),
2705      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2706         enddo
2707         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2708         do i=1,nres-1
2709           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2710      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2711      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2712         enddo
2713         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2714         do i=1,nres-1
2715           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2716      &     costab(i),sintab(i),costab2(i),sintab2(i)
2717         enddo
2718         write (iout,*) "Array MUDER"
2719         do i=1,nres-1
2720           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2721         enddo
2722 c      endif
2723 #endif
2724       if (nfgtasks.gt.1) then
2725         time00=MPI_Wtime()
2726 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2727 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2728 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2729 #ifdef MATGATHER
2730         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2731      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2732      &   FG_COMM1,IERR)
2733         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2749      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2750      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2751         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2752      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2753      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2754         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2755      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2756      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2757         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2758      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2759      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2760         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2761      &  then
2762         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2763      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2764      &   FG_COMM1,IERR)
2765         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2770      &   FG_COMM1,IERR)
2771        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2773      &   FG_COMM1,IERR)
2774         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2778      &   ivec_count(fg_rank1),
2779      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2782      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2785      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2791      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2792      &   FG_COMM1,IERR)
2793         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2794      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2795      &   FG_COMM1,IERR)
2796         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2797      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2798      &   FG_COMM1,IERR)
2799         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2800      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2801      &   FG_COMM1,IERR)
2802         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2803      &   ivec_count(fg_rank1),
2804      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2805      &   FG_COMM1,IERR)
2806         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2807      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2808      &   FG_COMM1,IERR)
2809        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2811      &   FG_COMM1,IERR)
2812         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2816      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2817      &   FG_COMM1,IERR)
2818         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2819      &   ivec_count(fg_rank1),
2820      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2821      &   FG_COMM1,IERR)
2822         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2823      &   ivec_count(fg_rank1),
2824      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2825      &   FG_COMM1,IERR)
2826         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2827      &   ivec_count(fg_rank1),
2828      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2829      &   MPI_MAT2,FG_COMM1,IERR)
2830         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2831      &   ivec_count(fg_rank1),
2832      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2833      &   MPI_MAT2,FG_COMM1,IERR)
2834         endif
2835 #else
2836 c Passes matrix info through the ring
2837       isend=fg_rank1
2838       irecv=fg_rank1-1
2839       if (irecv.lt.0) irecv=nfgtasks1-1
2840       iprev=irecv
2841       inext=fg_rank1+1
2842       if (inext.ge.nfgtasks1) inext=0
2843       do i=1,nfgtasks1-1
2844 c        write (iout,*) "isend",isend," irecv",irecv
2845 c        call flush(iout)
2846         lensend=lentyp(isend)
2847         lenrecv=lentyp(irecv)
2848 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2849 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2850 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2851 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2852 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather ROTAT1"
2854 c        call flush(iout)
2855 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2856 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2857 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2858 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2859 c        write (iout,*) "Gather ROTAT2"
2860 c        call flush(iout)
2861         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2862      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2863      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2864      &   iprev,4400+irecv,FG_COMM,status,IERR)
2865 c        write (iout,*) "Gather ROTAT_OLD"
2866 c        call flush(iout)
2867         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2868      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2869      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2870      &   iprev,5500+irecv,FG_COMM,status,IERR)
2871 c        write (iout,*) "Gather PRECOMP11"
2872 c        call flush(iout)
2873         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2874      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2875      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2876      &   iprev,6600+irecv,FG_COMM,status,IERR)
2877 c        write (iout,*) "Gather PRECOMP12"
2878 c        call flush(iout)
2879         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2880      &  then
2881         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2882      &   MPI_ROTAT2(lensend),inext,7700+isend,
2883      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2884      &   iprev,7700+irecv,FG_COMM,status,IERR)
2885 c        write (iout,*) "Gather PRECOMP21"
2886 c        call flush(iout)
2887         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2888      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2889      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2890      &   iprev,8800+irecv,FG_COMM,status,IERR)
2891 c        write (iout,*) "Gather PRECOMP22"
2892 c        call flush(iout)
2893         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2894      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2895      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2896      &   MPI_PRECOMP23(lenrecv),
2897      &   iprev,9900+irecv,FG_COMM,status,IERR)
2898 c        write (iout,*) "Gather PRECOMP23"
2899 c        call flush(iout)
2900         endif
2901         isend=irecv
2902         irecv=irecv-1
2903         if (irecv.lt.0) irecv=nfgtasks1-1
2904       enddo
2905 #endif
2906         time_gather=time_gather+MPI_Wtime()-time00
2907       endif
2908 #ifdef DEBUG
2909 c      if (fg_rank.eq.0) then
2910         write (iout,*) "Arrays UG and UGDER"
2911         do i=1,nres-1
2912           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2913      &     ((ug(l,k,i),l=1,2),k=1,2),
2914      &     ((ugder(l,k,i),l=1,2),k=1,2)
2915         enddo
2916         write (iout,*) "Arrays UG2 and UG2DER"
2917         do i=1,nres-1
2918           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2919      &     ((ug2(l,k,i),l=1,2),k=1,2),
2920      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2921         enddo
2922         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2923         do i=1,nres-1
2924           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2925      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2926      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2927         enddo
2928         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2929         do i=1,nres-1
2930           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2931      &     costab(i),sintab(i),costab2(i),sintab2(i)
2932         enddo
2933         write (iout,*) "Array MUDER"
2934         do i=1,nres-1
2935           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2936         enddo
2937 c      endif
2938 #endif
2939 #endif
2940 cd      do i=1,nres
2941 cd        iti = itortyp(itype(i))
2942 cd        write (iout,*) i
2943 cd        do j=1,2
2944 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2945 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2946 cd        enddo
2947 cd      enddo
2948       return
2949       end
2950 C--------------------------------------------------------------------------
2951       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2952 C
2953 C This subroutine calculates the average interaction energy and its gradient
2954 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2955 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2956 C The potential depends both on the distance of peptide-group centers and on
2957 C the orientation of the CA-CA virtual bonds.
2958 C
2959       implicit real*8 (a-h,o-z)
2960 #ifdef MPI
2961       include 'mpif.h'
2962 #endif
2963       include 'DIMENSIONS'
2964       include 'COMMON.CONTROL'
2965       include 'COMMON.SETUP'
2966       include 'COMMON.IOUNITS'
2967       include 'COMMON.GEO'
2968       include 'COMMON.VAR'
2969       include 'COMMON.LOCAL'
2970       include 'COMMON.CHAIN'
2971       include 'COMMON.DERIV'
2972       include 'COMMON.INTERACT'
2973       include 'COMMON.CONTACTS'
2974       include 'COMMON.TORSION'
2975       include 'COMMON.VECTORS'
2976       include 'COMMON.FFIELD'
2977       include 'COMMON.TIME1'
2978       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2979      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2980       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2981      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2982       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2983      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2984      &    num_conti,j1,j2
2985 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2986 #ifdef MOMENT
2987       double precision scal_el /1.0d0/
2988 #else
2989       double precision scal_el /0.5d0/
2990 #endif
2991 C 12/13/98
2992 C 13-go grudnia roku pamietnego...
2993       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2994      &                   0.0d0,1.0d0,0.0d0,
2995      &                   0.0d0,0.0d0,1.0d0/
2996 cd      write(iout,*) 'In EELEC'
2997 cd      do i=1,nloctyp
2998 cd        write(iout,*) 'Type',i
2999 cd        write(iout,*) 'B1',B1(:,i)
3000 cd        write(iout,*) 'B2',B2(:,i)
3001 cd        write(iout,*) 'CC',CC(:,:,i)
3002 cd        write(iout,*) 'DD',DD(:,:,i)
3003 cd        write(iout,*) 'EE',EE(:,:,i)
3004 cd      enddo
3005 cd      call check_vecgrad
3006 cd      stop
3007       if (icheckgrad.eq.1) then
3008         do i=1,nres-1
3009           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3010           do k=1,3
3011             dc_norm(k,i)=dc(k,i)*fac
3012           enddo
3013 c          write (iout,*) 'i',i,' fac',fac
3014         enddo
3015       endif
3016       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3017      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3018      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3019 c        call vec_and_deriv
3020 #ifdef TIMING
3021         time01=MPI_Wtime()
3022 #endif
3023         call set_matrices
3024 #ifdef TIMING
3025         time_mat=time_mat+MPI_Wtime()-time01
3026 #endif
3027       endif
3028 cd      do i=1,nres-1
3029 cd        write (iout,*) 'i=',i
3030 cd        do k=1,3
3031 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3032 cd        enddo
3033 cd        do k=1,3
3034 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3035 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3036 cd        enddo
3037 cd      enddo
3038       t_eelecij=0.0d0
3039       ees=0.0D0
3040       evdw1=0.0D0
3041       eel_loc=0.0d0
3042       eello_turn3=0.0d0
3043       eello_turn4=0.0d0
3044       ind=0
3045       do i=1,nres
3046         num_cont_hb(i)=0
3047       enddo
3048 cd      print '(a)','Enter EELEC'
3049 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3050       do i=1,nres
3051         gel_loc_loc(i)=0.0d0
3052         gcorr_loc(i)=0.0d0
3053       enddo
3054 c
3055 c
3056 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3057 C
3058 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3059 C
3060       do i=iturn3_start,iturn3_end
3061         dxi=dc(1,i)
3062         dyi=dc(2,i)
3063         dzi=dc(3,i)
3064         dx_normi=dc_norm(1,i)
3065         dy_normi=dc_norm(2,i)
3066         dz_normi=dc_norm(3,i)
3067         xmedi=c(1,i)+0.5d0*dxi
3068         ymedi=c(2,i)+0.5d0*dyi
3069         zmedi=c(3,i)+0.5d0*dzi
3070         num_conti=0
3071         call eelecij(i,i+2,ees,evdw1,eel_loc)
3072         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3073         num_cont_hb(i)=num_conti
3074       enddo
3075       do i=iturn4_start,iturn4_end
3076         dxi=dc(1,i)
3077         dyi=dc(2,i)
3078         dzi=dc(3,i)
3079         dx_normi=dc_norm(1,i)
3080         dy_normi=dc_norm(2,i)
3081         dz_normi=dc_norm(3,i)
3082         xmedi=c(1,i)+0.5d0*dxi
3083         ymedi=c(2,i)+0.5d0*dyi
3084         zmedi=c(3,i)+0.5d0*dzi
3085         num_conti=num_cont_hb(i)
3086         call eelecij(i,i+3,ees,evdw1,eel_loc)
3087         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3088         num_cont_hb(i)=num_conti
3089       enddo   ! i
3090 c
3091 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3092 c
3093       do i=iatel_s,iatel_e
3094         dxi=dc(1,i)
3095         dyi=dc(2,i)
3096         dzi=dc(3,i)
3097         dx_normi=dc_norm(1,i)
3098         dy_normi=dc_norm(2,i)
3099         dz_normi=dc_norm(3,i)
3100         xmedi=c(1,i)+0.5d0*dxi
3101         ymedi=c(2,i)+0.5d0*dyi
3102         zmedi=c(3,i)+0.5d0*dzi
3103 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3104         num_conti=num_cont_hb(i)
3105         do j=ielstart(i),ielend(i)
3106           call eelecij(i,j,ees,evdw1,eel_loc)
3107         enddo ! j
3108         num_cont_hb(i)=num_conti
3109       enddo   ! i
3110 c      write (iout,*) "Number of loop steps in EELEC:",ind
3111 cd      do i=1,nres
3112 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3113 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3114 cd      enddo
3115 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3116 ccc      eel_loc=eel_loc+eello_turn3
3117 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3118       return
3119       end
3120 C-------------------------------------------------------------------------------
3121       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3122       implicit real*8 (a-h,o-z)
3123       include 'DIMENSIONS'
3124 #ifdef MPI
3125       include "mpif.h"
3126 #endif
3127       include 'COMMON.CONTROL'
3128       include 'COMMON.IOUNITS'
3129       include 'COMMON.GEO'
3130       include 'COMMON.VAR'
3131       include 'COMMON.LOCAL'
3132       include 'COMMON.CHAIN'
3133       include 'COMMON.DERIV'
3134       include 'COMMON.INTERACT'
3135       include 'COMMON.CONTACTS'
3136       include 'COMMON.TORSION'
3137       include 'COMMON.VECTORS'
3138       include 'COMMON.FFIELD'
3139       include 'COMMON.TIME1'
3140       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3141      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3142       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3143      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3144       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3145      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3146      &    num_conti,j1,j2
3147 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3148 #ifdef MOMENT
3149       double precision scal_el /1.0d0/
3150 #else
3151       double precision scal_el /0.5d0/
3152 #endif
3153 C 12/13/98
3154 C 13-go grudnia roku pamietnego...
3155       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3156      &                   0.0d0,1.0d0,0.0d0,
3157      &                   0.0d0,0.0d0,1.0d0/
3158 c          time00=MPI_Wtime()
3159 cd      write (iout,*) "eelecij",i,j
3160 c          ind=ind+1
3161           iteli=itel(i)
3162           itelj=itel(j)
3163           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3164           aaa=app(iteli,itelj)
3165           bbb=bpp(iteli,itelj)
3166           ael6i=ael6(iteli,itelj)
3167           ael3i=ael3(iteli,itelj)
3168           dxj=dc(1,j)
3169           dyj=dc(2,j)
3170           dzj=dc(3,j)
3171           dx_normj=dc_norm(1,j)
3172           dy_normj=dc_norm(2,j)
3173           dz_normj=dc_norm(3,j)
3174           xj=c(1,j)+0.5D0*dxj-xmedi
3175           yj=c(2,j)+0.5D0*dyj-ymedi
3176           zj=c(3,j)+0.5D0*dzj-zmedi
3177           rij=xj*xj+yj*yj+zj*zj
3178           rrmij=1.0D0/rij
3179           rij=dsqrt(rij)
3180           rmij=1.0D0/rij
3181           r3ij=rrmij*rmij
3182           r6ij=r3ij*r3ij
3183           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3184           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3185           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3186           fac=cosa-3.0D0*cosb*cosg
3187           ev1=aaa*r6ij*r6ij
3188 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3189           if (j.eq.i+2) ev1=scal_el*ev1
3190           ev2=bbb*r6ij
3191           fac3=ael6i*r6ij
3192           fac4=ael3i*r3ij
3193           evdwij=ev1+ev2
3194           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3195           el2=fac4*fac
3196           eesij=el1+el2
3197 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3198           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3199           ees=ees+eesij
3200           evdw1=evdw1+evdwij
3201 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3202 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3203 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3204 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3205
3206           if (energy_dec) then
3207               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3208               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3209           endif
3210
3211 C
3212 C Calculate contributions to the Cartesian gradient.
3213 C
3214 #ifdef SPLITELE
3215           facvdw=-6*rrmij*(ev1+evdwij)
3216           facel=-3*rrmij*(el1+eesij)
3217           fac1=fac
3218           erij(1)=xj*rmij
3219           erij(2)=yj*rmij
3220           erij(3)=zj*rmij
3221 *
3222 * Radial derivatives. First process both termini of the fragment (i,j)
3223 *
3224           ggg(1)=facel*xj
3225           ggg(2)=facel*yj
3226           ggg(3)=facel*zj
3227 c          do k=1,3
3228 c            ghalf=0.5D0*ggg(k)
3229 c            gelc(k,i)=gelc(k,i)+ghalf
3230 c            gelc(k,j)=gelc(k,j)+ghalf
3231 c          enddo
3232 c 9/28/08 AL Gradient compotents will be summed only at the end
3233           do k=1,3
3234             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3235             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3236           enddo
3237 *
3238 * Loop over residues i+1 thru j-1.
3239 *
3240 cgrad          do k=i+1,j-1
3241 cgrad            do l=1,3
3242 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3243 cgrad            enddo
3244 cgrad          enddo
3245           ggg(1)=facvdw*xj
3246           ggg(2)=facvdw*yj
3247           ggg(3)=facvdw*zj
3248 c          do k=1,3
3249 c            ghalf=0.5D0*ggg(k)
3250 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3251 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3252 c          enddo
3253 c 9/28/08 AL Gradient compotents will be summed only at the end
3254           do k=1,3
3255             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3256             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3257           enddo
3258 *
3259 * Loop over residues i+1 thru j-1.
3260 *
3261 cgrad          do k=i+1,j-1
3262 cgrad            do l=1,3
3263 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3264 cgrad            enddo
3265 cgrad          enddo
3266 #else
3267           facvdw=ev1+evdwij
3268           facel=el1+eesij
3269           fac1=fac
3270           fac=-3*rrmij*(facvdw+facvdw+facel)
3271           erij(1)=xj*rmij
3272           erij(2)=yj*rmij
3273           erij(3)=zj*rmij
3274 *
3275 * Radial derivatives. First process both termini of the fragment (i,j)
3276 *
3277           ggg(1)=fac*xj
3278           ggg(2)=fac*yj
3279           ggg(3)=fac*zj
3280 c          do k=1,3
3281 c            ghalf=0.5D0*ggg(k)
3282 c            gelc(k,i)=gelc(k,i)+ghalf
3283 c            gelc(k,j)=gelc(k,j)+ghalf
3284 c          enddo
3285 c 9/28/08 AL Gradient compotents will be summed only at the end
3286           do k=1,3
3287             gelc_long(k,j)=gelc(k,j)+ggg(k)
3288             gelc_long(k,i)=gelc(k,i)-ggg(k)
3289           enddo
3290 *
3291 * Loop over residues i+1 thru j-1.
3292 *
3293 cgrad          do k=i+1,j-1
3294 cgrad            do l=1,3
3295 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3296 cgrad            enddo
3297 cgrad          enddo
3298 c 9/28/08 AL Gradient compotents will be summed only at the end
3299           ggg(1)=facvdw*xj
3300           ggg(2)=facvdw*yj
3301           ggg(3)=facvdw*zj
3302           do k=1,3
3303             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3304             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3305           enddo
3306 #endif
3307 *
3308 * Angular part
3309 *
3310           ecosa=2.0D0*fac3*fac1+fac4
3311           fac4=-3.0D0*fac4
3312           fac3=-6.0D0*fac3
3313           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3314           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3315           do k=1,3
3316             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3317             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3318           enddo
3319 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3320 cd   &          (dcosg(k),k=1,3)
3321           do k=1,3
3322             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3323           enddo
3324 c          do k=1,3
3325 c            ghalf=0.5D0*ggg(k)
3326 c            gelc(k,i)=gelc(k,i)+ghalf
3327 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3328 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3329 c            gelc(k,j)=gelc(k,j)+ghalf
3330 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3331 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3332 c          enddo
3333 cgrad          do k=i+1,j-1
3334 cgrad            do l=1,3
3335 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3336 cgrad            enddo
3337 cgrad          enddo
3338           do k=1,3
3339             gelc(k,i)=gelc(k,i)
3340      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3341      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3342             gelc(k,j)=gelc(k,j)
3343      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3344      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3345             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3346             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3347           enddo
3348           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3349      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3350      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3351 C
3352 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3353 C   energy of a peptide unit is assumed in the form of a second-order
3354 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3355 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3356 C   are computed for EVERY pair of non-contiguous peptide groups.
3357 C
3358           if (j.lt.nres-1) then
3359             j1=j+1
3360             j2=j-1
3361           else
3362             j1=j-1
3363             j2=j-2
3364           endif
3365           kkk=0
3366           do k=1,2
3367             do l=1,2
3368               kkk=kkk+1
3369               muij(kkk)=mu(k,i)*mu(l,j)
3370             enddo
3371           enddo
3372 cd         write (iout,*) 'EELEC: i',i,' j',j
3373 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3374 cd          write(iout,*) 'muij',muij
3375           ury=scalar(uy(1,i),erij)
3376           urz=scalar(uz(1,i),erij)
3377           vry=scalar(uy(1,j),erij)
3378           vrz=scalar(uz(1,j),erij)
3379           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3380           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3381           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3382           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3383           fac=dsqrt(-ael6i)*r3ij
3384           a22=a22*fac
3385           a23=a23*fac
3386           a32=a32*fac
3387           a33=a33*fac
3388 cd          write (iout,'(4i5,4f10.5)')
3389 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3390 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3391 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3392 cd     &      uy(:,j),uz(:,j)
3393 cd          write (iout,'(4f10.5)')
3394 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3395 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3396 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3397 cd           write (iout,'(9f10.5/)')
3398 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3399 C Derivatives of the elements of A in virtual-bond vectors
3400           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3401           do k=1,3
3402             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3403             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3404             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3405             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3406             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3407             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3408             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3409             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3410             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3411             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3412             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3413             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3414           enddo
3415 C Compute radial contributions to the gradient
3416           facr=-3.0d0*rrmij
3417           a22der=a22*facr
3418           a23der=a23*facr
3419           a32der=a32*facr
3420           a33der=a33*facr
3421           agg(1,1)=a22der*xj
3422           agg(2,1)=a22der*yj
3423           agg(3,1)=a22der*zj
3424           agg(1,2)=a23der*xj
3425           agg(2,2)=a23der*yj
3426           agg(3,2)=a23der*zj
3427           agg(1,3)=a32der*xj
3428           agg(2,3)=a32der*yj
3429           agg(3,3)=a32der*zj
3430           agg(1,4)=a33der*xj
3431           agg(2,4)=a33der*yj
3432           agg(3,4)=a33der*zj
3433 C Add the contributions coming from er
3434           fac3=-3.0d0*fac
3435           do k=1,3
3436             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3437             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3438             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3439             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3440           enddo
3441           do k=1,3
3442 C Derivatives in DC(i)
3443 cgrad            ghalf1=0.5d0*agg(k,1)
3444 cgrad            ghalf2=0.5d0*agg(k,2)
3445 cgrad            ghalf3=0.5d0*agg(k,3)
3446 cgrad            ghalf4=0.5d0*agg(k,4)
3447             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3448      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3449             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3450      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3451             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3452      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3453             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3454      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3455 C Derivatives in DC(i+1)
3456             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3457      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3458             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3459      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3460             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3461      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3462             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3463      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3464 C Derivatives in DC(j)
3465             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3466      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3467             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3468      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3469             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3470      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3471             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3472      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3473 C Derivatives in DC(j+1) or DC(nres-1)
3474             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3475      &      -3.0d0*vryg(k,3)*ury)
3476             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3477      &      -3.0d0*vrzg(k,3)*ury)
3478             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3479      &      -3.0d0*vryg(k,3)*urz)
3480             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3481      &      -3.0d0*vrzg(k,3)*urz)
3482 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3483 cgrad              do l=1,4
3484 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3485 cgrad              enddo
3486 cgrad            endif
3487           enddo
3488           acipa(1,1)=a22
3489           acipa(1,2)=a23
3490           acipa(2,1)=a32
3491           acipa(2,2)=a33
3492           a22=-a22
3493           a23=-a23
3494           do l=1,2
3495             do k=1,3
3496               agg(k,l)=-agg(k,l)
3497               aggi(k,l)=-aggi(k,l)
3498               aggi1(k,l)=-aggi1(k,l)
3499               aggj(k,l)=-aggj(k,l)
3500               aggj1(k,l)=-aggj1(k,l)
3501             enddo
3502           enddo
3503           if (j.lt.nres-1) then
3504             a22=-a22
3505             a32=-a32
3506             do l=1,3,2
3507               do k=1,3
3508                 agg(k,l)=-agg(k,l)
3509                 aggi(k,l)=-aggi(k,l)
3510                 aggi1(k,l)=-aggi1(k,l)
3511                 aggj(k,l)=-aggj(k,l)
3512                 aggj1(k,l)=-aggj1(k,l)
3513               enddo
3514             enddo
3515           else
3516             a22=-a22
3517             a23=-a23
3518             a32=-a32
3519             a33=-a33
3520             do l=1,4
3521               do k=1,3
3522                 agg(k,l)=-agg(k,l)
3523                 aggi(k,l)=-aggi(k,l)
3524                 aggi1(k,l)=-aggi1(k,l)
3525                 aggj(k,l)=-aggj(k,l)
3526                 aggj1(k,l)=-aggj1(k,l)
3527               enddo
3528             enddo
3529           endif
3530           ENDIF ! WCORR
3531           IF (wel_loc.gt.0.0d0) THEN
3532 C Contribution to the local-electrostatic energy coming from the i-j pair
3533           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3534      &     +a33*muij(4)
3535 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3536
3537           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3538      &            'eelloc',i,j,eel_loc_ij
3539
3540           eel_loc=eel_loc+eel_loc_ij
3541 C Partial derivatives in virtual-bond dihedral angles gamma
3542           if (i.gt.1)
3543      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3544      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3545      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3546           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3547      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3548      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3549 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3550           do l=1,3
3551             ggg(l)=agg(l,1)*muij(1)+
3552      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3553             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3554             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3555 cgrad            ghalf=0.5d0*ggg(l)
3556 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3557 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3558           enddo
3559 cgrad          do k=i+1,j2
3560 cgrad            do l=1,3
3561 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3562 cgrad            enddo
3563 cgrad          enddo
3564 C Remaining derivatives of eello
3565           do l=1,3
3566             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3567      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3568             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3569      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3570             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3571      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3572             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3573      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3574           enddo
3575           ENDIF
3576 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3577 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3578           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3579      &       .and. num_conti.le.maxconts) then
3580 c            write (iout,*) i,j," entered corr"
3581 C
3582 C Calculate the contact function. The ith column of the array JCONT will
3583 C contain the numbers of atoms that make contacts with the atom I (of numbers
3584 C greater than I). The arrays FACONT and GACONT will contain the values of
3585 C the contact function and its derivative.
3586 c           r0ij=1.02D0*rpp(iteli,itelj)
3587 c           r0ij=1.11D0*rpp(iteli,itelj)
3588             r0ij=2.20D0*rpp(iteli,itelj)
3589 c           r0ij=1.55D0*rpp(iteli,itelj)
3590             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3591             if (fcont.gt.0.0D0) then
3592               num_conti=num_conti+1
3593               if (num_conti.gt.maxconts) then
3594                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3595      &                         ' will skip next contacts for this conf.'
3596               else
3597                 jcont_hb(num_conti,i)=j
3598 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3599 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3600                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3601      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3602 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3603 C  terms.
3604                 d_cont(num_conti,i)=rij
3605 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3606 C     --- Electrostatic-interaction matrix ---
3607                 a_chuj(1,1,num_conti,i)=a22
3608                 a_chuj(1,2,num_conti,i)=a23
3609                 a_chuj(2,1,num_conti,i)=a32
3610                 a_chuj(2,2,num_conti,i)=a33
3611 C     --- Gradient of rij
3612                 do kkk=1,3
3613                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3614                 enddo
3615                 kkll=0
3616                 do k=1,2
3617                   do l=1,2
3618                     kkll=kkll+1
3619                     do m=1,3
3620                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3621                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3622                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3623                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3624                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3625                     enddo
3626                   enddo
3627                 enddo
3628                 ENDIF
3629                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3630 C Calculate contact energies
3631                 cosa4=4.0D0*cosa
3632                 wij=cosa-3.0D0*cosb*cosg
3633                 cosbg1=cosb+cosg
3634                 cosbg2=cosb-cosg
3635 c               fac3=dsqrt(-ael6i)/r0ij**3
3636                 fac3=dsqrt(-ael6i)*r3ij
3637 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3638                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3639                 if (ees0tmp.gt.0) then
3640                   ees0pij=dsqrt(ees0tmp)
3641                 else
3642                   ees0pij=0
3643                 endif
3644 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3645                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3646                 if (ees0tmp.gt.0) then
3647                   ees0mij=dsqrt(ees0tmp)
3648                 else
3649                   ees0mij=0
3650                 endif
3651 c               ees0mij=0.0D0
3652                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3653                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3654 C Diagnostics. Comment out or remove after debugging!
3655 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3656 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3657 c               ees0m(num_conti,i)=0.0D0
3658 C End diagnostics.
3659 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3660 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3661 C Angular derivatives of the contact function
3662                 ees0pij1=fac3/ees0pij
3663                 ees0mij1=fac3/ees0mij
3664                 fac3p=-3.0D0*fac3*rrmij
3665                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3666                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3667 c               ees0mij1=0.0D0
3668                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3669                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3670                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3671                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3672                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3673                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3674                 ecosap=ecosa1+ecosa2
3675                 ecosbp=ecosb1+ecosb2
3676                 ecosgp=ecosg1+ecosg2
3677                 ecosam=ecosa1-ecosa2
3678                 ecosbm=ecosb1-ecosb2
3679                 ecosgm=ecosg1-ecosg2
3680 C Diagnostics
3681 c               ecosap=ecosa1
3682 c               ecosbp=ecosb1
3683 c               ecosgp=ecosg1
3684 c               ecosam=0.0D0
3685 c               ecosbm=0.0D0
3686 c               ecosgm=0.0D0
3687 C End diagnostics
3688                 facont_hb(num_conti,i)=fcont
3689                 fprimcont=fprimcont/rij
3690 cd              facont_hb(num_conti,i)=1.0D0
3691 C Following line is for diagnostics.
3692 cd              fprimcont=0.0D0
3693                 do k=1,3
3694                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3695                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3696                 enddo
3697                 do k=1,3
3698                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3699                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3700                 enddo
3701                 gggp(1)=gggp(1)+ees0pijp*xj
3702                 gggp(2)=gggp(2)+ees0pijp*yj
3703                 gggp(3)=gggp(3)+ees0pijp*zj
3704                 gggm(1)=gggm(1)+ees0mijp*xj
3705                 gggm(2)=gggm(2)+ees0mijp*yj
3706                 gggm(3)=gggm(3)+ees0mijp*zj
3707 C Derivatives due to the contact function
3708                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3709                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3710                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3711                 do k=1,3
3712 c
3713 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3714 c          following the change of gradient-summation algorithm.
3715 c
3716 cgrad                  ghalfp=0.5D0*gggp(k)
3717 cgrad                  ghalfm=0.5D0*gggm(k)
3718                   gacontp_hb1(k,num_conti,i)=!ghalfp
3719      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3720      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3721                   gacontp_hb2(k,num_conti,i)=!ghalfp
3722      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3723      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3724                   gacontp_hb3(k,num_conti,i)=gggp(k)
3725                   gacontm_hb1(k,num_conti,i)=!ghalfm
3726      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3727      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3728                   gacontm_hb2(k,num_conti,i)=!ghalfm
3729      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3730      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3731                   gacontm_hb3(k,num_conti,i)=gggm(k)
3732                 enddo
3733 C Diagnostics. Comment out or remove after debugging!
3734 cdiag           do k=1,3
3735 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3736 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3737 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3738 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3739 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3740 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3741 cdiag           enddo
3742               ENDIF ! wcorr
3743               endif  ! num_conti.le.maxconts
3744             endif  ! fcont.gt.0
3745           endif    ! j.gt.i+1
3746           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3747             do k=1,4
3748               do l=1,3
3749                 ghalf=0.5d0*agg(l,k)
3750                 aggi(l,k)=aggi(l,k)+ghalf
3751                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3752                 aggj(l,k)=aggj(l,k)+ghalf
3753               enddo
3754             enddo
3755             if (j.eq.nres-1 .and. i.lt.j-2) then
3756               do k=1,4
3757                 do l=1,3
3758                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3759                 enddo
3760               enddo
3761             endif
3762           endif
3763 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3764       return
3765       end
3766 C-----------------------------------------------------------------------------
3767       subroutine eturn3(i,eello_turn3)
3768 C Third- and fourth-order contributions from turns
3769       implicit real*8 (a-h,o-z)
3770       include 'DIMENSIONS'
3771       include 'COMMON.IOUNITS'
3772       include 'COMMON.GEO'
3773       include 'COMMON.VAR'
3774       include 'COMMON.LOCAL'
3775       include 'COMMON.CHAIN'
3776       include 'COMMON.DERIV'
3777       include 'COMMON.INTERACT'
3778       include 'COMMON.CONTACTS'
3779       include 'COMMON.TORSION'
3780       include 'COMMON.VECTORS'
3781       include 'COMMON.FFIELD'
3782       include 'COMMON.CONTROL'
3783       dimension ggg(3)
3784       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3785      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3786      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3787       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3788      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3789       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3790      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3791      &    num_conti,j1,j2
3792       j=i+2
3793 c      write (iout,*) "eturn3",i,j,j1,j2
3794       a_temp(1,1)=a22
3795       a_temp(1,2)=a23
3796       a_temp(2,1)=a32
3797       a_temp(2,2)=a33
3798 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3799 C
3800 C               Third-order contributions
3801 C
3802 C                 (i+2)o----(i+3)
3803 C                      | |
3804 C                      | |
3805 C                 (i+1)o----i
3806 C
3807 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3808 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3809         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3810         call transpose2(auxmat(1,1),auxmat1(1,1))
3811         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3812         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3813         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3814      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3815 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3816 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3817 cd     &    ' eello_turn3_num',4*eello_turn3_num
3818 C Derivatives in gamma(i)
3819         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3820         call transpose2(auxmat2(1,1),auxmat3(1,1))
3821         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3822         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3823 C Derivatives in gamma(i+1)
3824         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3825         call transpose2(auxmat2(1,1),auxmat3(1,1))
3826         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3827         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3828      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3829 C Cartesian derivatives
3830         do l=1,3
3831 c            ghalf1=0.5d0*agg(l,1)
3832 c            ghalf2=0.5d0*agg(l,2)
3833 c            ghalf3=0.5d0*agg(l,3)
3834 c            ghalf4=0.5d0*agg(l,4)
3835           a_temp(1,1)=aggi(l,1)!+ghalf1
3836           a_temp(1,2)=aggi(l,2)!+ghalf2
3837           a_temp(2,1)=aggi(l,3)!+ghalf3
3838           a_temp(2,2)=aggi(l,4)!+ghalf4
3839           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3840           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3841      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3842           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3843           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3844           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3845           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3846           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3847           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3848      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3849           a_temp(1,1)=aggj(l,1)!+ghalf1
3850           a_temp(1,2)=aggj(l,2)!+ghalf2
3851           a_temp(2,1)=aggj(l,3)!+ghalf3
3852           a_temp(2,2)=aggj(l,4)!+ghalf4
3853           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3854           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3855      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3856           a_temp(1,1)=aggj1(l,1)
3857           a_temp(1,2)=aggj1(l,2)
3858           a_temp(2,1)=aggj1(l,3)
3859           a_temp(2,2)=aggj1(l,4)
3860           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3861           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3862      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3863         enddo
3864       return
3865       end
3866 C-------------------------------------------------------------------------------
3867       subroutine eturn4(i,eello_turn4)
3868 C Third- and fourth-order contributions from turns
3869       implicit real*8 (a-h,o-z)
3870       include 'DIMENSIONS'
3871       include 'COMMON.IOUNITS'
3872       include 'COMMON.GEO'
3873       include 'COMMON.VAR'
3874       include 'COMMON.LOCAL'
3875       include 'COMMON.CHAIN'
3876       include 'COMMON.DERIV'
3877       include 'COMMON.INTERACT'
3878       include 'COMMON.CONTACTS'
3879       include 'COMMON.TORSION'
3880       include 'COMMON.VECTORS'
3881       include 'COMMON.FFIELD'
3882       include 'COMMON.CONTROL'
3883       dimension ggg(3)
3884       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3885      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3886      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3887       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3888      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3889       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3890      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3891      &    num_conti,j1,j2
3892       j=i+3
3893 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3894 C
3895 C               Fourth-order contributions
3896 C
3897 C                 (i+3)o----(i+4)
3898 C                     /  |
3899 C               (i+2)o   |
3900 C                     \  |
3901 C                 (i+1)o----i
3902 C
3903 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3904 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3905 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3906         a_temp(1,1)=a22
3907         a_temp(1,2)=a23
3908         a_temp(2,1)=a32
3909         a_temp(2,2)=a33
3910         iti1=itortyp(itype(i+1))
3911         iti2=itortyp(itype(i+2))
3912         iti3=itortyp(itype(i+3))
3913 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3914         call transpose2(EUg(1,1,i+1),e1t(1,1))
3915         call transpose2(Eug(1,1,i+2),e2t(1,1))
3916         call transpose2(Eug(1,1,i+3),e3t(1,1))
3917         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3918         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3919         s1=scalar2(b1(1,iti2),auxvec(1))
3920         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3921         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3922         s2=scalar2(b1(1,iti1),auxvec(1))
3923         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3924         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3925         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3926         eello_turn4=eello_turn4-(s1+s2+s3)
3927         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3928      &      'eturn4',i,j,-(s1+s2+s3)
3929 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3930 cd     &    ' eello_turn4_num',8*eello_turn4_num
3931 C Derivatives in gamma(i)
3932         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3933         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3934         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3935         s1=scalar2(b1(1,iti2),auxvec(1))
3936         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3937         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3938         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3939 C Derivatives in gamma(i+1)
3940         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3941         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3942         s2=scalar2(b1(1,iti1),auxvec(1))
3943         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3944         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3945         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3946         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3947 C Derivatives in gamma(i+2)
3948         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3949         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3950         s1=scalar2(b1(1,iti2),auxvec(1))
3951         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3952         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3953         s2=scalar2(b1(1,iti1),auxvec(1))
3954         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3955         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3956         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3957         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3958 C Cartesian derivatives
3959 C Derivatives of this turn contributions in DC(i+2)
3960         if (j.lt.nres-1) then
3961           do l=1,3
3962             a_temp(1,1)=agg(l,1)
3963             a_temp(1,2)=agg(l,2)
3964             a_temp(2,1)=agg(l,3)
3965             a_temp(2,2)=agg(l,4)
3966             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3967             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3968             s1=scalar2(b1(1,iti2),auxvec(1))
3969             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3970             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3971             s2=scalar2(b1(1,iti1),auxvec(1))
3972             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3973             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3974             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3975             ggg(l)=-(s1+s2+s3)
3976             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3977           enddo
3978         endif
3979 C Remaining derivatives of this turn contribution
3980         do l=1,3
3981           a_temp(1,1)=aggi(l,1)
3982           a_temp(1,2)=aggi(l,2)
3983           a_temp(2,1)=aggi(l,3)
3984           a_temp(2,2)=aggi(l,4)
3985           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3986           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3987           s1=scalar2(b1(1,iti2),auxvec(1))
3988           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3989           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3990           s2=scalar2(b1(1,iti1),auxvec(1))
3991           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3992           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3993           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3994           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3995           a_temp(1,1)=aggi1(l,1)
3996           a_temp(1,2)=aggi1(l,2)
3997           a_temp(2,1)=aggi1(l,3)
3998           a_temp(2,2)=aggi1(l,4)
3999           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4000           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4001           s1=scalar2(b1(1,iti2),auxvec(1))
4002           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4003           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4004           s2=scalar2(b1(1,iti1),auxvec(1))
4005           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4006           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4007           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4008           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4009           a_temp(1,1)=aggj(l,1)
4010           a_temp(1,2)=aggj(l,2)
4011           a_temp(2,1)=aggj(l,3)
4012           a_temp(2,2)=aggj(l,4)
4013           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4014           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4015           s1=scalar2(b1(1,iti2),auxvec(1))
4016           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4017           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4018           s2=scalar2(b1(1,iti1),auxvec(1))
4019           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4020           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4021           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4022           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4023           a_temp(1,1)=aggj1(l,1)
4024           a_temp(1,2)=aggj1(l,2)
4025           a_temp(2,1)=aggj1(l,3)
4026           a_temp(2,2)=aggj1(l,4)
4027           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4028           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4029           s1=scalar2(b1(1,iti2),auxvec(1))
4030           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4031           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4032           s2=scalar2(b1(1,iti1),auxvec(1))
4033           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4034           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4035           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4036 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4037           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4038         enddo
4039       return
4040       end
4041 C-----------------------------------------------------------------------------
4042       subroutine vecpr(u,v,w)
4043       implicit real*8(a-h,o-z)
4044       dimension u(3),v(3),w(3)
4045       w(1)=u(2)*v(3)-u(3)*v(2)
4046       w(2)=-u(1)*v(3)+u(3)*v(1)
4047       w(3)=u(1)*v(2)-u(2)*v(1)
4048       return
4049       end
4050 C-----------------------------------------------------------------------------
4051       subroutine unormderiv(u,ugrad,unorm,ungrad)
4052 C This subroutine computes the derivatives of a normalized vector u, given
4053 C the derivatives computed without normalization conditions, ugrad. Returns
4054 C ungrad.
4055       implicit none
4056       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4057       double precision vec(3)
4058       double precision scalar
4059       integer i,j
4060 c      write (2,*) 'ugrad',ugrad
4061 c      write (2,*) 'u',u
4062       do i=1,3
4063         vec(i)=scalar(ugrad(1,i),u(1))
4064       enddo
4065 c      write (2,*) 'vec',vec
4066       do i=1,3
4067         do j=1,3
4068           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4069         enddo
4070       enddo
4071 c      write (2,*) 'ungrad',ungrad
4072       return
4073       end
4074 C-----------------------------------------------------------------------------
4075       subroutine escp_soft_sphere(evdw2,evdw2_14)
4076 C
4077 C This subroutine calculates the excluded-volume interaction energy between
4078 C peptide-group centers and side chains and its gradient in virtual-bond and
4079 C side-chain vectors.
4080 C
4081       implicit real*8 (a-h,o-z)
4082       include 'DIMENSIONS'
4083       include 'COMMON.GEO'
4084       include 'COMMON.VAR'
4085       include 'COMMON.LOCAL'
4086       include 'COMMON.CHAIN'
4087       include 'COMMON.DERIV'
4088       include 'COMMON.INTERACT'
4089       include 'COMMON.FFIELD'
4090       include 'COMMON.IOUNITS'
4091       include 'COMMON.CONTROL'
4092       dimension ggg(3)
4093       evdw2=0.0D0
4094       evdw2_14=0.0d0
4095       r0_scp=4.5d0
4096 cd    print '(a)','Enter ESCP'
4097 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4098       do i=iatscp_s,iatscp_e
4099         iteli=itel(i)
4100         xi=0.5D0*(c(1,i)+c(1,i+1))
4101         yi=0.5D0*(c(2,i)+c(2,i+1))
4102         zi=0.5D0*(c(3,i)+c(3,i+1))
4103
4104         do iint=1,nscp_gr(i)
4105
4106         do j=iscpstart(i,iint),iscpend(i,iint)
4107           itypj=itype(j)
4108 C Uncomment following three lines for SC-p interactions
4109 c         xj=c(1,nres+j)-xi
4110 c         yj=c(2,nres+j)-yi
4111 c         zj=c(3,nres+j)-zi
4112 C Uncomment following three lines for Ca-p interactions
4113           xj=c(1,j)-xi
4114           yj=c(2,j)-yi
4115           zj=c(3,j)-zi
4116           rij=xj*xj+yj*yj+zj*zj
4117           r0ij=r0_scp
4118           r0ijsq=r0ij*r0ij
4119           if (rij.lt.r0ijsq) then
4120             evdwij=0.25d0*(rij-r0ijsq)**2
4121             fac=rij-r0ijsq
4122           else
4123             evdwij=0.0d0
4124             fac=0.0d0
4125           endif
4126           evdw2=evdw2+evdwij
4127 C
4128 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4129 C
4130           ggg(1)=xj*fac
4131           ggg(2)=yj*fac
4132           ggg(3)=zj*fac
4133 cgrad          if (j.lt.i) then
4134 cd          write (iout,*) 'j<i'
4135 C Uncomment following three lines for SC-p interactions
4136 c           do k=1,3
4137 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4138 c           enddo
4139 cgrad          else
4140 cd          write (iout,*) 'j>i'
4141 cgrad            do k=1,3
4142 cgrad              ggg(k)=-ggg(k)
4143 C Uncomment following line for SC-p interactions
4144 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4145 cgrad            enddo
4146 cgrad          endif
4147 cgrad          do k=1,3
4148 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4149 cgrad          enddo
4150 cgrad          kstart=min0(i+1,j)
4151 cgrad          kend=max0(i-1,j-1)
4152 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4153 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4154 cgrad          do k=kstart,kend
4155 cgrad            do l=1,3
4156 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4157 cgrad            enddo
4158 cgrad          enddo
4159           do k=1,3
4160             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4161             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4162           enddo
4163         enddo
4164
4165         enddo ! iint
4166       enddo ! i
4167       return
4168       end
4169 C-----------------------------------------------------------------------------
4170       subroutine escp(evdw2,evdw2_14)
4171 C
4172 C This subroutine calculates the excluded-volume interaction energy between
4173 C peptide-group centers and side chains and its gradient in virtual-bond and
4174 C side-chain vectors.
4175 C
4176       implicit real*8 (a-h,o-z)
4177       include 'DIMENSIONS'
4178       include 'COMMON.GEO'
4179       include 'COMMON.VAR'
4180       include 'COMMON.LOCAL'
4181       include 'COMMON.CHAIN'
4182       include 'COMMON.DERIV'
4183       include 'COMMON.INTERACT'
4184       include 'COMMON.FFIELD'
4185       include 'COMMON.IOUNITS'
4186       include 'COMMON.CONTROL'
4187       dimension ggg(3)
4188       evdw2=0.0D0
4189       evdw2_14=0.0d0
4190 cd    print '(a)','Enter ESCP'
4191 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4192       do i=iatscp_s,iatscp_e
4193         iteli=itel(i)
4194         xi=0.5D0*(c(1,i)+c(1,i+1))
4195         yi=0.5D0*(c(2,i)+c(2,i+1))
4196         zi=0.5D0*(c(3,i)+c(3,i+1))
4197
4198         do iint=1,nscp_gr(i)
4199
4200         do j=iscpstart(i,iint),iscpend(i,iint)
4201           itypj=itype(j)
4202 C Uncomment following three lines for SC-p interactions
4203 c         xj=c(1,nres+j)-xi
4204 c         yj=c(2,nres+j)-yi
4205 c         zj=c(3,nres+j)-zi
4206 C Uncomment following three lines for Ca-p interactions
4207           xj=c(1,j)-xi
4208           yj=c(2,j)-yi
4209           zj=c(3,j)-zi
4210           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4211           fac=rrij**expon2
4212           e1=fac*fac*aad(itypj,iteli)
4213           e2=fac*bad(itypj,iteli)
4214           if (iabs(j-i) .le. 2) then
4215             e1=scal14*e1
4216             e2=scal14*e2
4217             evdw2_14=evdw2_14+e1+e2
4218           endif
4219           evdwij=e1+e2
4220           evdw2=evdw2+evdwij
4221           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4222      &        'evdw2',i,j,evdwij
4223 C
4224 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4225 C
4226           fac=-(evdwij+e1)*rrij
4227           ggg(1)=xj*fac
4228           ggg(2)=yj*fac
4229           ggg(3)=zj*fac
4230 cgrad          if (j.lt.i) then
4231 cd          write (iout,*) 'j<i'
4232 C Uncomment following three lines for SC-p interactions
4233 c           do k=1,3
4234 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4235 c           enddo
4236 cgrad          else
4237 cd          write (iout,*) 'j>i'
4238 cgrad            do k=1,3
4239 cgrad              ggg(k)=-ggg(k)
4240 C Uncomment following line for SC-p interactions
4241 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4242 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4243 cgrad            enddo
4244 cgrad          endif
4245 cgrad          do k=1,3
4246 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4247 cgrad          enddo
4248 cgrad          kstart=min0(i+1,j)
4249 cgrad          kend=max0(i-1,j-1)
4250 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4251 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4252 cgrad          do k=kstart,kend
4253 cgrad            do l=1,3
4254 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4255 cgrad            enddo
4256 cgrad          enddo
4257           do k=1,3
4258             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4259             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4260           enddo
4261         enddo
4262
4263         enddo ! iint
4264       enddo ! i
4265       do i=1,nct
4266         do j=1,3
4267           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4268           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4269           gradx_scp(j,i)=expon*gradx_scp(j,i)
4270         enddo
4271       enddo
4272 C******************************************************************************
4273 C
4274 C                              N O T E !!!
4275 C
4276 C To save time the factor EXPON has been extracted from ALL components
4277 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4278 C use!
4279 C
4280 C******************************************************************************
4281       return
4282       end
4283 C--------------------------------------------------------------------------
4284       subroutine edis(ehpb)
4285 C
4286 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4287 C
4288       implicit real*8 (a-h,o-z)
4289       include 'DIMENSIONS'
4290       include 'COMMON.SBRIDGE'
4291       include 'COMMON.CHAIN'
4292       include 'COMMON.DERIV'
4293       include 'COMMON.VAR'
4294       include 'COMMON.INTERACT'
4295       include 'COMMON.IOUNITS'
4296       dimension ggg(3)
4297       ehpb=0.0D0
4298 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4299 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4300       if (link_end.eq.0) return
4301       do i=link_start,link_end
4302 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4303 C CA-CA distance used in regularization of structure.
4304         ii=ihpb(i)
4305         jj=jhpb(i)
4306 C iii and jjj point to the residues for which the distance is assigned.
4307         if (ii.gt.nres) then
4308           iii=ii-nres
4309           jjj=jj-nres
4310         else
4311           iii=ii
4312           jjj=jj
4313         endif
4314 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4315 c     &    dhpb(i),dhpb1(i),forcon(i)
4316 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4317 C    distance and angle dependent SS bond potential.
4318         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4319           call ssbond_ene(iii,jjj,eij)
4320           ehpb=ehpb+2*eij
4321 cd          write (iout,*) "eij",eij
4322         else if (ii.gt.nres .and. jj.gt.nres) then
4323 c Restraints from contact prediction
4324           dd=dist(ii,jj)
4325           if (dhpb1(i).gt.0.0d0) then
4326             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4327             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4328 c            write (iout,*) "beta nmr",
4329 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4330           else
4331             dd=dist(ii,jj)
4332             rdis=dd-dhpb(i)
4333 C Get the force constant corresponding to this distance.
4334             waga=forcon(i)
4335 C Calculate the contribution to energy.
4336             ehpb=ehpb+waga*rdis*rdis
4337 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4338 C
4339 C Evaluate gradient.
4340 C
4341             fac=waga*rdis/dd
4342           endif
4343           do j=1,3
4344             ggg(j)=fac*(c(j,jj)-c(j,ii))
4345           enddo
4346           do j=1,3
4347             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4348             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4349           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         else
4355 C Calculate the distance between the two points and its difference from the
4356 C target distance.
4357           dd=dist(ii,jj)
4358           if (dhpb1(i).gt.0.0d0) then
4359             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4360             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4361 c            write (iout,*) "alph nmr",
4362 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4363           else
4364             rdis=dd-dhpb(i)
4365 C Get the force constant corresponding to this distance.
4366             waga=forcon(i)
4367 C Calculate the contribution to energy.
4368             ehpb=ehpb+waga*rdis*rdis
4369 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4370 C
4371 C Evaluate gradient.
4372 C
4373             fac=waga*rdis/dd
4374           endif
4375 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4376 cd   &   ' waga=',waga,' fac=',fac
4377             do j=1,3
4378               ggg(j)=fac*(c(j,jj)-c(j,ii))
4379             enddo
4380 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4381 C If this is a SC-SC distance, we need to calculate the contributions to the
4382 C Cartesian gradient in the SC vectors (ghpbx).
4383           if (iii.lt.ii) then
4384           do j=1,3
4385             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4386             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4387           enddo
4388           endif
4389 cgrad        do j=iii,jjj-1
4390 cgrad          do k=1,3
4391 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4392 cgrad          enddo
4393 cgrad        enddo
4394           do k=1,3
4395             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4396             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4397           enddo
4398         endif
4399       enddo
4400       ehpb=0.5D0*ehpb
4401       return
4402       end
4403 C--------------------------------------------------------------------------
4404       subroutine ssbond_ene(i,j,eij)
4405 C
4406 C Calculate the distance and angle dependent SS-bond potential energy
4407 C using a free-energy function derived based on RHF/6-31G** ab initio
4408 C calculations of diethyl disulfide.
4409 C
4410 C A. Liwo and U. Kozlowska, 11/24/03
4411 C
4412       implicit real*8 (a-h,o-z)
4413       include 'DIMENSIONS'
4414       include 'COMMON.SBRIDGE'
4415       include 'COMMON.CHAIN'
4416       include 'COMMON.DERIV'
4417       include 'COMMON.LOCAL'
4418       include 'COMMON.INTERACT'
4419       include 'COMMON.VAR'
4420       include 'COMMON.IOUNITS'
4421       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4422       itypi=itype(i)
4423       xi=c(1,nres+i)
4424       yi=c(2,nres+i)
4425       zi=c(3,nres+i)
4426       dxi=dc_norm(1,nres+i)
4427       dyi=dc_norm(2,nres+i)
4428       dzi=dc_norm(3,nres+i)
4429 c      dsci_inv=dsc_inv(itypi)
4430       dsci_inv=vbld_inv(nres+i)
4431       itypj=itype(j)
4432 c      dscj_inv=dsc_inv(itypj)
4433       dscj_inv=vbld_inv(nres+j)
4434       xj=c(1,nres+j)-xi
4435       yj=c(2,nres+j)-yi
4436       zj=c(3,nres+j)-zi
4437       dxj=dc_norm(1,nres+j)
4438       dyj=dc_norm(2,nres+j)
4439       dzj=dc_norm(3,nres+j)
4440       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4441       rij=dsqrt(rrij)
4442       erij(1)=xj*rij
4443       erij(2)=yj*rij
4444       erij(3)=zj*rij
4445       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4446       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4447       om12=dxi*dxj+dyi*dyj+dzi*dzj
4448       do k=1,3
4449         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4450         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4451       enddo
4452       rij=1.0d0/rij
4453       deltad=rij-d0cm
4454       deltat1=1.0d0-om1
4455       deltat2=1.0d0+om2
4456       deltat12=om2-om1+2.0d0
4457       cosphi=om12-om1*om2
4458       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4459      &  +akct*deltad*deltat12
4460      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4461 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4462 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4463 c     &  " deltat12",deltat12," eij",eij
4464       ed=2*akcm*deltad+akct*deltat12
4465       pom1=akct*deltad
4466       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4467       eom1=-2*akth*deltat1-pom1-om2*pom2
4468       eom2= 2*akth*deltat2+pom1-om1*pom2
4469       eom12=pom2
4470       do k=1,3
4471         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4472         ghpbx(k,i)=ghpbx(k,i)-ggk
4473      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4474      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4475         ghpbx(k,j)=ghpbx(k,j)+ggk
4476      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4477      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4478         ghpbc(k,i)=ghpbc(k,i)-ggk
4479         ghpbc(k,j)=ghpbc(k,j)+ggk
4480       enddo
4481 C
4482 C Calculate the components of the gradient in DC and X
4483 C
4484 cgrad      do k=i,j-1
4485 cgrad        do l=1,3
4486 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4487 cgrad        enddo
4488 cgrad      enddo
4489       return
4490       end
4491 C--------------------------------------------------------------------------
4492       subroutine ebond(estr)
4493 c
4494 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4495 c
4496       implicit real*8 (a-h,o-z)
4497       include 'DIMENSIONS'
4498       include 'COMMON.LOCAL'
4499       include 'COMMON.GEO'
4500       include 'COMMON.INTERACT'
4501       include 'COMMON.DERIV'
4502       include 'COMMON.VAR'
4503       include 'COMMON.CHAIN'
4504       include 'COMMON.IOUNITS'
4505       include 'COMMON.NAMES'
4506       include 'COMMON.FFIELD'
4507       include 'COMMON.CONTROL'
4508       include 'COMMON.SETUP'
4509       double precision u(3),ud(3)
4510       estr=0.0d0
4511       do i=ibondp_start,ibondp_end
4512         diff = vbld(i)-vbldp0
4513 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4514         estr=estr+diff*diff
4515         do j=1,3
4516           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4517         enddo
4518 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4519       enddo
4520       estr=0.5d0*AKP*estr
4521 c
4522 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4523 c
4524       do i=ibond_start,ibond_end
4525         iti=itype(i)
4526         if (iti.ne.10) then
4527           nbi=nbondterm(iti)
4528           if (nbi.eq.1) then
4529             diff=vbld(i+nres)-vbldsc0(1,iti)
4530 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4531 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4532             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4533             do j=1,3
4534               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4535             enddo
4536           else
4537             do j=1,nbi
4538               diff=vbld(i+nres)-vbldsc0(j,iti)
4539               ud(j)=aksc(j,iti)*diff
4540               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4541             enddo
4542             uprod=u(1)
4543             do j=2,nbi
4544               uprod=uprod*u(j)
4545             enddo
4546             usum=0.0d0
4547             usumsqder=0.0d0
4548             do j=1,nbi
4549               uprod1=1.0d0
4550               uprod2=1.0d0
4551               do k=1,nbi
4552                 if (k.ne.j) then
4553                   uprod1=uprod1*u(k)
4554                   uprod2=uprod2*u(k)*u(k)
4555                 endif
4556               enddo
4557               usum=usum+uprod1
4558               usumsqder=usumsqder+ud(j)*uprod2
4559             enddo
4560             estr=estr+uprod/usum
4561             do j=1,3
4562              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4563             enddo
4564           endif
4565         endif
4566       enddo
4567       return
4568       end
4569 #ifdef CRYST_THETA
4570 C--------------------------------------------------------------------------
4571       subroutine ebend(etheta)
4572 C
4573 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4574 C angles gamma and its derivatives in consecutive thetas and gammas.
4575 C
4576       implicit real*8 (a-h,o-z)
4577       include 'DIMENSIONS'
4578       include 'COMMON.LOCAL'
4579       include 'COMMON.GEO'
4580       include 'COMMON.INTERACT'
4581       include 'COMMON.DERIV'
4582       include 'COMMON.VAR'
4583       include 'COMMON.CHAIN'
4584       include 'COMMON.IOUNITS'
4585       include 'COMMON.NAMES'
4586       include 'COMMON.FFIELD'
4587       include 'COMMON.CONTROL'
4588       common /calcthet/ term1,term2,termm,diffak,ratak,
4589      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4590      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4591       double precision y(2),z(2)
4592       delta=0.02d0*pi
4593 c      time11=dexp(-2*time)
4594 c      time12=1.0d0
4595       etheta=0.0D0
4596 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4597       do i=ithet_start,ithet_end
4598 C Zero the energy function and its derivative at 0 or pi.
4599         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4600         it=itype(i-1)
4601         if (i.gt.3) then
4602 #ifdef OSF
4603           phii=phi(i)
4604           if (phii.ne.phii) phii=150.0
4605 #else
4606           phii=phi(i)
4607 #endif
4608           y(1)=dcos(phii)
4609           y(2)=dsin(phii)
4610         else
4611           y(1)=0.0D0
4612           y(2)=0.0D0
4613         endif
4614         if (i.lt.nres) then
4615 #ifdef OSF
4616           phii1=phi(i+1)
4617           if (phii1.ne.phii1) phii1=150.0
4618           phii1=pinorm(phii1)
4619           z(1)=cos(phii1)
4620 #else
4621           phii1=phi(i+1)
4622           z(1)=dcos(phii1)
4623 #endif
4624           z(2)=dsin(phii1)
4625         else
4626           z(1)=0.0D0
4627           z(2)=0.0D0
4628         endif
4629 C Calculate the "mean" value of theta from the part of the distribution
4630 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4631 C In following comments this theta will be referred to as t_c.
4632         thet_pred_mean=0.0d0
4633         do k=1,2
4634           athetk=athet(k,it)
4635           bthetk=bthet(k,it)
4636           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4637         enddo
4638         dthett=thet_pred_mean*ssd
4639         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4640 C Derivatives of the "mean" values in gamma1 and gamma2.
4641         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4642         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4643         if (theta(i).gt.pi-delta) then
4644           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4645      &         E_tc0)
4646           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4647           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4648           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4649      &        E_theta)
4650           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4651      &        E_tc)
4652         else if (theta(i).lt.delta) then
4653           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4654           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4655           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4656      &        E_theta)
4657           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4658           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4659      &        E_tc)
4660         else
4661           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4662      &        E_theta,E_tc)
4663         endif
4664         etheta=etheta+ethetai
4665         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4666      &      'ebend',i,ethetai
4667         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4668         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4669         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4670       enddo
4671 C Ufff.... We've done all this!!!
4672       return
4673       end
4674 C---------------------------------------------------------------------------
4675       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4676      &     E_tc)
4677       implicit real*8 (a-h,o-z)
4678       include 'DIMENSIONS'
4679       include 'COMMON.LOCAL'
4680       include 'COMMON.IOUNITS'
4681       common /calcthet/ term1,term2,termm,diffak,ratak,
4682      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4683      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4684 C Calculate the contributions to both Gaussian lobes.
4685 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4686 C The "polynomial part" of the "standard deviation" of this part of
4687 C the distribution.
4688         sig=polthet(3,it)
4689         do j=2,0,-1
4690           sig=sig*thet_pred_mean+polthet(j,it)
4691         enddo
4692 C Derivative of the "interior part" of the "standard deviation of the"
4693 C gamma-dependent Gaussian lobe in t_c.
4694         sigtc=3*polthet(3,it)
4695         do j=2,1,-1
4696           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4697         enddo
4698         sigtc=sig*sigtc
4699 C Set the parameters of both Gaussian lobes of the distribution.
4700 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4701         fac=sig*sig+sigc0(it)
4702         sigcsq=fac+fac
4703         sigc=1.0D0/sigcsq
4704 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4705         sigsqtc=-4.0D0*sigcsq*sigtc
4706 c       print *,i,sig,sigtc,sigsqtc
4707 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4708         sigtc=-sigtc/(fac*fac)
4709 C Following variable is sigma(t_c)**(-2)
4710         sigcsq=sigcsq*sigcsq
4711         sig0i=sig0(it)
4712         sig0inv=1.0D0/sig0i**2
4713         delthec=thetai-thet_pred_mean
4714         delthe0=thetai-theta0i
4715         term1=-0.5D0*sigcsq*delthec*delthec
4716         term2=-0.5D0*sig0inv*delthe0*delthe0
4717 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4718 C NaNs in taking the logarithm. We extract the largest exponent which is added
4719 C to the energy (this being the log of the distribution) at the end of energy
4720 C term evaluation for this virtual-bond angle.
4721         if (term1.gt.term2) then
4722           termm=term1
4723           term2=dexp(term2-termm)
4724           term1=1.0d0
4725         else
4726           termm=term2
4727           term1=dexp(term1-termm)
4728           term2=1.0d0
4729         endif
4730 C The ratio between the gamma-independent and gamma-dependent lobes of
4731 C the distribution is a Gaussian function of thet_pred_mean too.
4732         diffak=gthet(2,it)-thet_pred_mean
4733         ratak=diffak/gthet(3,it)**2
4734         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4735 C Let's differentiate it in thet_pred_mean NOW.
4736         aktc=ak*ratak
4737 C Now put together the distribution terms to make complete distribution.
4738         termexp=term1+ak*term2
4739         termpre=sigc+ak*sig0i
4740 C Contribution of the bending energy from this theta is just the -log of
4741 C the sum of the contributions from the two lobes and the pre-exponential
4742 C factor. Simple enough, isn't it?
4743         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4744 C NOW the derivatives!!!
4745 C 6/6/97 Take into account the deformation.
4746         E_theta=(delthec*sigcsq*term1
4747      &       +ak*delthe0*sig0inv*term2)/termexp
4748         E_tc=((sigtc+aktc*sig0i)/termpre
4749      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4750      &       aktc*term2)/termexp)
4751       return
4752       end
4753 c-----------------------------------------------------------------------------
4754       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4755       implicit real*8 (a-h,o-z)
4756       include 'DIMENSIONS'
4757       include 'COMMON.LOCAL'
4758       include 'COMMON.IOUNITS'
4759       common /calcthet/ term1,term2,termm,diffak,ratak,
4760      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4761      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4762       delthec=thetai-thet_pred_mean
4763       delthe0=thetai-theta0i
4764 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4765       t3 = thetai-thet_pred_mean
4766       t6 = t3**2
4767       t9 = term1
4768       t12 = t3*sigcsq
4769       t14 = t12+t6*sigsqtc
4770       t16 = 1.0d0
4771       t21 = thetai-theta0i
4772       t23 = t21**2
4773       t26 = term2
4774       t27 = t21*t26
4775       t32 = termexp
4776       t40 = t32**2
4777       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4778      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4779      & *(-t12*t9-ak*sig0inv*t27)
4780       return
4781       end
4782 #else
4783 C--------------------------------------------------------------------------
4784       subroutine ebend(etheta)
4785 C
4786 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4787 C angles gamma and its derivatives in consecutive thetas and gammas.
4788 C ab initio-derived potentials from
4789 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4790 C
4791       implicit real*8 (a-h,o-z)
4792       include 'DIMENSIONS'
4793       include 'COMMON.LOCAL'
4794       include 'COMMON.GEO'
4795       include 'COMMON.INTERACT'
4796       include 'COMMON.DERIV'
4797       include 'COMMON.VAR'
4798       include 'COMMON.CHAIN'
4799       include 'COMMON.IOUNITS'
4800       include 'COMMON.NAMES'
4801       include 'COMMON.FFIELD'
4802       include 'COMMON.CONTROL'
4803       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4804      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4805      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4806      & sinph1ph2(maxdouble,maxdouble)
4807       logical lprn /.false./, lprn1 /.false./
4808       etheta=0.0D0
4809       do i=ithet_start,ithet_end
4810         dethetai=0.0d0
4811         dephii=0.0d0
4812         dephii1=0.0d0
4813         theti2=0.5d0*theta(i)
4814         ityp2=ithetyp(itype(i-1))
4815         do k=1,nntheterm
4816           coskt(k)=dcos(k*theti2)
4817           sinkt(k)=dsin(k*theti2)
4818         enddo
4819         if (i.gt.3) then
4820 #ifdef OSF
4821           phii=phi(i)
4822           if (phii.ne.phii) phii=150.0
4823 #else
4824           phii=phi(i)
4825 #endif
4826           ityp1=ithetyp(itype(i-2))
4827           do k=1,nsingle
4828             cosph1(k)=dcos(k*phii)
4829             sinph1(k)=dsin(k*phii)
4830           enddo
4831         else
4832           phii=0.0d0
4833           ityp1=nthetyp+1
4834           do k=1,nsingle
4835             cosph1(k)=0.0d0
4836             sinph1(k)=0.0d0
4837           enddo
4838         endif
4839         if (i.lt.nres) then
4840 #ifdef OSF
4841           phii1=phi(i+1)
4842           if (phii1.ne.phii1) phii1=150.0
4843           phii1=pinorm(phii1)
4844 #else
4845           phii1=phi(i+1)
4846 #endif
4847           ityp3=ithetyp(itype(i))
4848           do k=1,nsingle
4849             cosph2(k)=dcos(k*phii1)
4850             sinph2(k)=dsin(k*phii1)
4851           enddo
4852         else
4853           phii1=0.0d0
4854           ityp3=nthetyp+1
4855           do k=1,nsingle
4856             cosph2(k)=0.0d0
4857             sinph2(k)=0.0d0
4858           enddo
4859         endif
4860         ethetai=aa0thet(ityp1,ityp2,ityp3)
4861         do k=1,ndouble
4862           do l=1,k-1
4863             ccl=cosph1(l)*cosph2(k-l)
4864             ssl=sinph1(l)*sinph2(k-l)
4865             scl=sinph1(l)*cosph2(k-l)
4866             csl=cosph1(l)*sinph2(k-l)
4867             cosph1ph2(l,k)=ccl-ssl
4868             cosph1ph2(k,l)=ccl+ssl
4869             sinph1ph2(l,k)=scl+csl
4870             sinph1ph2(k,l)=scl-csl
4871           enddo
4872         enddo
4873         if (lprn) then
4874         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4875      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4876         write (iout,*) "coskt and sinkt"
4877         do k=1,nntheterm
4878           write (iout,*) k,coskt(k),sinkt(k)
4879         enddo
4880         endif
4881         do k=1,ntheterm
4882           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4883           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4884      &      *coskt(k)
4885           if (lprn)
4886      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4887      &     " ethetai",ethetai
4888         enddo
4889         if (lprn) then
4890         write (iout,*) "cosph and sinph"
4891         do k=1,nsingle
4892           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4893         enddo
4894         write (iout,*) "cosph1ph2 and sinph2ph2"
4895         do k=2,ndouble
4896           do l=1,k-1
4897             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4898      &         sinph1ph2(l,k),sinph1ph2(k,l)
4899           enddo
4900         enddo
4901         write(iout,*) "ethetai",ethetai
4902         endif
4903         do m=1,ntheterm2
4904           do k=1,nsingle
4905             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4906      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4907      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4908      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4909             ethetai=ethetai+sinkt(m)*aux
4910             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4911             dephii=dephii+k*sinkt(m)*(
4912      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4913      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4914             dephii1=dephii1+k*sinkt(m)*(
4915      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4916      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4917             if (lprn)
4918      &      write (iout,*) "m",m," k",k," bbthet",
4919      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4920      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4921      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4922      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4923           enddo
4924         enddo
4925         if (lprn)
4926      &  write(iout,*) "ethetai",ethetai
4927         do m=1,ntheterm3
4928           do k=2,ndouble
4929             do l=1,k-1
4930               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4931      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4932      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4933      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4934               ethetai=ethetai+sinkt(m)*aux
4935               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4936               dephii=dephii+l*sinkt(m)*(
4937      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4938      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4939      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4940      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4941               dephii1=dephii1+(k-l)*sinkt(m)*(
4942      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4943      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4944      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4945      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4946               if (lprn) then
4947               write (iout,*) "m",m," k",k," l",l," ffthet",
4948      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4949      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4950      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4951      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4952               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4953      &            cosph1ph2(k,l)*sinkt(m),
4954      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4955               endif
4956             enddo
4957           enddo
4958         enddo
4959 10      continue
4960         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4961      &   i,theta(i)*rad2deg,phii*rad2deg,
4962      &   phii1*rad2deg,ethetai
4963         etheta=etheta+ethetai
4964         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4965         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4966         gloc(nphi+i-2,icg)=wang*dethetai
4967       enddo
4968       return
4969       end
4970 #endif
4971 #ifdef CRYST_SC
4972 c-----------------------------------------------------------------------------
4973       subroutine esc(escloc)
4974 C Calculate the local energy of a side chain and its derivatives in the
4975 C corresponding virtual-bond valence angles THETA and the spherical angles
4976 C ALPHA and OMEGA.
4977       implicit real*8 (a-h,o-z)
4978       include 'DIMENSIONS'
4979       include 'COMMON.GEO'
4980       include 'COMMON.LOCAL'
4981       include 'COMMON.VAR'
4982       include 'COMMON.INTERACT'
4983       include 'COMMON.DERIV'
4984       include 'COMMON.CHAIN'
4985       include 'COMMON.IOUNITS'
4986       include 'COMMON.NAMES'
4987       include 'COMMON.FFIELD'
4988       include 'COMMON.CONTROL'
4989       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4990      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4991       common /sccalc/ time11,time12,time112,theti,it,nlobit
4992       delta=0.02d0*pi
4993       escloc=0.0D0
4994 c     write (iout,'(a)') 'ESC'
4995       do i=loc_start,loc_end
4996         it=itype(i)
4997         if (it.eq.10) goto 1
4998         nlobit=nlob(it)
4999 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5000 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5001         theti=theta(i+1)-pipol
5002         x(1)=dtan(theti)
5003         x(2)=alph(i)
5004         x(3)=omeg(i)
5005
5006         if (x(2).gt.pi-delta) then
5007           xtemp(1)=x(1)
5008           xtemp(2)=pi-delta
5009           xtemp(3)=x(3)
5010           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5011           xtemp(2)=pi
5012           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5013           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5014      &        escloci,dersc(2))
5015           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5016      &        ddersc0(1),dersc(1))
5017           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5018      &        ddersc0(3),dersc(3))
5019           xtemp(2)=pi-delta
5020           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5021           xtemp(2)=pi
5022           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5023           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5024      &            dersc0(2),esclocbi,dersc02)
5025           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5026      &            dersc12,dersc01)
5027           call splinthet(x(2),0.5d0*delta,ss,ssd)
5028           dersc0(1)=dersc01
5029           dersc0(2)=dersc02
5030           dersc0(3)=0.0d0
5031           do k=1,3
5032             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5033           enddo
5034           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5035 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5036 c    &             esclocbi,ss,ssd
5037           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5038 c         escloci=esclocbi
5039 c         write (iout,*) escloci
5040         else if (x(2).lt.delta) then
5041           xtemp(1)=x(1)
5042           xtemp(2)=delta
5043           xtemp(3)=x(3)
5044           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5045           xtemp(2)=0.0d0
5046           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5047           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5048      &        escloci,dersc(2))
5049           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5050      &        ddersc0(1),dersc(1))
5051           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5052      &        ddersc0(3),dersc(3))
5053           xtemp(2)=delta
5054           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5055           xtemp(2)=0.0d0
5056           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5057           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5058      &            dersc0(2),esclocbi,dersc02)
5059           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5060      &            dersc12,dersc01)
5061           dersc0(1)=dersc01
5062           dersc0(2)=dersc02
5063           dersc0(3)=0.0d0
5064           call splinthet(x(2),0.5d0*delta,ss,ssd)
5065           do k=1,3
5066             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5067           enddo
5068           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5069 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5070 c    &             esclocbi,ss,ssd
5071           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5072 c         write (iout,*) escloci
5073         else
5074           call enesc(x,escloci,dersc,ddummy,.false.)
5075         endif
5076
5077         escloc=escloc+escloci
5078         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5079      &     'escloc',i,escloci
5080 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5081
5082         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5083      &   wscloc*dersc(1)
5084         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5085         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5086     1   continue
5087       enddo
5088       return
5089       end
5090 C---------------------------------------------------------------------------
5091       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5092       implicit real*8 (a-h,o-z)
5093       include 'DIMENSIONS'
5094       include 'COMMON.GEO'
5095       include 'COMMON.LOCAL'
5096       include 'COMMON.IOUNITS'
5097       common /sccalc/ time11,time12,time112,theti,it,nlobit
5098       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5099       double precision contr(maxlob,-1:1)
5100       logical mixed
5101 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5102         escloc_i=0.0D0
5103         do j=1,3
5104           dersc(j)=0.0D0
5105           if (mixed) ddersc(j)=0.0d0
5106         enddo
5107         x3=x(3)
5108
5109 C Because of periodicity of the dependence of the SC energy in omega we have
5110 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5111 C To avoid underflows, first compute & store the exponents.
5112
5113         do iii=-1,1
5114
5115           x(3)=x3+iii*dwapi
5116
5117           do j=1,nlobit
5118             do k=1,3
5119               z(k)=x(k)-censc(k,j,it)
5120             enddo
5121             do k=1,3
5122               Axk=0.0D0
5123               do l=1,3
5124                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5125               enddo
5126               Ax(k,j,iii)=Axk
5127             enddo
5128             expfac=0.0D0
5129             do k=1,3
5130               expfac=expfac+Ax(k,j,iii)*z(k)
5131             enddo
5132             contr(j,iii)=expfac
5133           enddo ! j
5134
5135         enddo ! iii
5136
5137         x(3)=x3
5138 C As in the case of ebend, we want to avoid underflows in exponentiation and
5139 C subsequent NaNs and INFs in energy calculation.
5140 C Find the largest exponent
5141         emin=contr(1,-1)
5142         do iii=-1,1
5143           do j=1,nlobit
5144             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5145           enddo
5146         enddo
5147         emin=0.5D0*emin
5148 cd      print *,'it=',it,' emin=',emin
5149
5150 C Compute the contribution to SC energy and derivatives
5151         do iii=-1,1
5152
5153           do j=1,nlobit
5154 #ifdef OSF
5155             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5156             if(adexp.ne.adexp) adexp=1.0
5157             expfac=dexp(adexp)
5158 #else
5159             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5160 #endif
5161 cd          print *,'j=',j,' expfac=',expfac
5162             escloc_i=escloc_i+expfac
5163             do k=1,3
5164               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5165             enddo
5166             if (mixed) then
5167               do k=1,3,2
5168                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5169      &            +gaussc(k,2,j,it))*expfac
5170               enddo
5171             endif
5172           enddo
5173
5174         enddo ! iii
5175
5176         dersc(1)=dersc(1)/cos(theti)**2
5177         ddersc(1)=ddersc(1)/cos(theti)**2
5178         ddersc(3)=ddersc(3)
5179
5180         escloci=-(dlog(escloc_i)-emin)
5181         do j=1,3
5182           dersc(j)=dersc(j)/escloc_i
5183         enddo
5184         if (mixed) then
5185           do j=1,3,2
5186             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5187           enddo
5188         endif
5189       return
5190       end
5191 C------------------------------------------------------------------------------
5192       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5193       implicit real*8 (a-h,o-z)
5194       include 'DIMENSIONS'
5195       include 'COMMON.GEO'
5196       include 'COMMON.LOCAL'
5197       include 'COMMON.IOUNITS'
5198       common /sccalc/ time11,time12,time112,theti,it,nlobit
5199       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5200       double precision contr(maxlob)
5201       logical mixed
5202
5203       escloc_i=0.0D0
5204
5205       do j=1,3
5206         dersc(j)=0.0D0
5207       enddo
5208
5209       do j=1,nlobit
5210         do k=1,2
5211           z(k)=x(k)-censc(k,j,it)
5212         enddo
5213         z(3)=dwapi
5214         do k=1,3
5215           Axk=0.0D0
5216           do l=1,3
5217             Axk=Axk+gaussc(l,k,j,it)*z(l)
5218           enddo
5219           Ax(k,j)=Axk
5220         enddo
5221         expfac=0.0D0
5222         do k=1,3
5223           expfac=expfac+Ax(k,j)*z(k)
5224         enddo
5225         contr(j)=expfac
5226       enddo ! j
5227
5228 C As in the case of ebend, we want to avoid underflows in exponentiation and
5229 C subsequent NaNs and INFs in energy calculation.
5230 C Find the largest exponent
5231       emin=contr(1)
5232       do j=1,nlobit
5233         if (emin.gt.contr(j)) emin=contr(j)
5234       enddo
5235       emin=0.5D0*emin
5236
5237 C Compute the contribution to SC energy and derivatives
5238
5239       dersc12=0.0d0
5240       do j=1,nlobit
5241         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5242         escloc_i=escloc_i+expfac
5243         do k=1,2
5244           dersc(k)=dersc(k)+Ax(k,j)*expfac
5245         enddo
5246         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5247      &            +gaussc(1,2,j,it))*expfac
5248         dersc(3)=0.0d0
5249       enddo
5250
5251       dersc(1)=dersc(1)/cos(theti)**2
5252       dersc12=dersc12/cos(theti)**2
5253       escloci=-(dlog(escloc_i)-emin)
5254       do j=1,2
5255         dersc(j)=dersc(j)/escloc_i
5256       enddo
5257       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5258       return
5259       end
5260 #else
5261 c----------------------------------------------------------------------------------
5262       subroutine esc(escloc)
5263 C Calculate the local energy of a side chain and its derivatives in the
5264 C corresponding virtual-bond valence angles THETA and the spherical angles
5265 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5266 C added by Urszula Kozlowska. 07/11/2007
5267 C
5268       implicit real*8 (a-h,o-z)
5269       include 'DIMENSIONS'
5270       include 'COMMON.GEO'
5271       include 'COMMON.LOCAL'
5272       include 'COMMON.VAR'
5273       include 'COMMON.SCROT'
5274       include 'COMMON.INTERACT'
5275       include 'COMMON.DERIV'
5276       include 'COMMON.CHAIN'
5277       include 'COMMON.IOUNITS'
5278       include 'COMMON.NAMES'
5279       include 'COMMON.FFIELD'
5280       include 'COMMON.CONTROL'
5281       include 'COMMON.VECTORS'
5282       double precision x_prime(3),y_prime(3),z_prime(3)
5283      &    , sumene,dsc_i,dp2_i,x(65),
5284      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5285      &    de_dxx,de_dyy,de_dzz,de_dt
5286       double precision s1_t,s1_6_t,s2_t,s2_6_t
5287       double precision
5288      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5289      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5290      & dt_dCi(3),dt_dCi1(3)
5291       common /sccalc/ time11,time12,time112,theti,it,nlobit
5292       delta=0.02d0*pi
5293       escloc=0.0D0
5294       do i=loc_start,loc_end
5295         costtab(i+1) =dcos(theta(i+1))
5296         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5297         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5298         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5299         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5300         cosfac=dsqrt(cosfac2)
5301         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5302         sinfac=dsqrt(sinfac2)
5303         it=itype(i)
5304         if (it.eq.10) goto 1
5305 c
5306 C  Compute the axes of tghe local cartesian coordinates system; store in
5307 c   x_prime, y_prime and z_prime
5308 c
5309         do j=1,3
5310           x_prime(j) = 0.00
5311           y_prime(j) = 0.00
5312           z_prime(j) = 0.00
5313         enddo
5314 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5315 C     &   dc_norm(3,i+nres)
5316         do j = 1,3
5317           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5318           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5319         enddo
5320         do j = 1,3
5321           z_prime(j) = -uz(j,i-1)
5322         enddo
5323 c       write (2,*) "i",i
5324 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5325 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5326 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5327 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5328 c      & " xy",scalar(x_prime(1),y_prime(1)),
5329 c      & " xz",scalar(x_prime(1),z_prime(1)),
5330 c      & " yy",scalar(y_prime(1),y_prime(1)),
5331 c      & " yz",scalar(y_prime(1),z_prime(1)),
5332 c      & " zz",scalar(z_prime(1),z_prime(1))
5333 c
5334 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5335 C to local coordinate system. Store in xx, yy, zz.
5336 c
5337         xx=0.0d0
5338         yy=0.0d0
5339         zz=0.0d0
5340         do j = 1,3
5341           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5342           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5343           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5344         enddo
5345
5346         xxtab(i)=xx
5347         yytab(i)=yy
5348         zztab(i)=zz
5349 C
5350 C Compute the energy of the ith side cbain
5351 C
5352 c        write (2,*) "xx",xx," yy",yy," zz",zz
5353         it=itype(i)
5354         do j = 1,65
5355           x(j) = sc_parmin(j,it)
5356         enddo
5357 #ifdef CHECK_COORD
5358 Cc diagnostics - remove later
5359         xx1 = dcos(alph(2))
5360         yy1 = dsin(alph(2))*dcos(omeg(2))
5361         zz1 = -dsin(alph(2))*dsin(omeg(2))
5362         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5363      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5364      &    xx1,yy1,zz1
5365 C,"  --- ", xx_w,yy_w,zz_w
5366 c end diagnostics
5367 #endif
5368         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5369      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5370      &   + x(10)*yy*zz
5371         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5372      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5373      & + x(20)*yy*zz
5374         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5375      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5376      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5377      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5378      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5379      &  +x(40)*xx*yy*zz
5380         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5381      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5382      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5383      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5384      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5385      &  +x(60)*xx*yy*zz
5386         dsc_i   = 0.743d0+x(61)
5387         dp2_i   = 1.9d0+x(62)
5388         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5389      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5390         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5391      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5392         s1=(1+x(63))/(0.1d0 + dscp1)
5393         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5394         s2=(1+x(65))/(0.1d0 + dscp2)
5395         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5396         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5397      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5398 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5399 c     &   sumene4,
5400 c     &   dscp1,dscp2,sumene
5401 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5402         escloc = escloc + sumene
5403 c        write (2,*) "i",i," escloc",sumene,escloc
5404 #ifdef DEBUG
5405 C
5406 C This section to check the numerical derivatives of the energy of ith side
5407 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5408 C #define DEBUG in the code to turn it on.
5409 C
5410         write (2,*) "sumene               =",sumene
5411         aincr=1.0d-7
5412         xxsave=xx
5413         xx=xx+aincr
5414         write (2,*) xx,yy,zz
5415         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5416         de_dxx_num=(sumenep-sumene)/aincr
5417         xx=xxsave
5418         write (2,*) "xx+ sumene from enesc=",sumenep
5419         yysave=yy
5420         yy=yy+aincr
5421         write (2,*) xx,yy,zz
5422         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5423         de_dyy_num=(sumenep-sumene)/aincr
5424         yy=yysave
5425         write (2,*) "yy+ sumene from enesc=",sumenep
5426         zzsave=zz
5427         zz=zz+aincr
5428         write (2,*) xx,yy,zz
5429         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5430         de_dzz_num=(sumenep-sumene)/aincr
5431         zz=zzsave
5432         write (2,*) "zz+ sumene from enesc=",sumenep
5433         costsave=cost2tab(i+1)
5434         sintsave=sint2tab(i+1)
5435         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5436         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5437         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5438         de_dt_num=(sumenep-sumene)/aincr
5439         write (2,*) " t+ sumene from enesc=",sumenep
5440         cost2tab(i+1)=costsave
5441         sint2tab(i+1)=sintsave
5442 C End of diagnostics section.
5443 #endif
5444 C
5445 C Compute the gradient of esc
5446 C
5447         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5448         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5449         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5450         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5451         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5452         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5453         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5454         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5455         pom1=(sumene3*sint2tab(i+1)+sumene1)
5456      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5457         pom2=(sumene4*cost2tab(i+1)+sumene2)
5458      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5459         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5460         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5461      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5462      &  +x(40)*yy*zz
5463         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5464         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5465      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5466      &  +x(60)*yy*zz
5467         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5468      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5469      &        +(pom1+pom2)*pom_dx
5470 #ifdef DEBUG
5471         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5472 #endif
5473 C
5474         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5475         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5476      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5477      &  +x(40)*xx*zz
5478         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5479         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5480      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5481      &  +x(59)*zz**2 +x(60)*xx*zz
5482         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5483      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5484      &        +(pom1-pom2)*pom_dy
5485 #ifdef DEBUG
5486         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5487 #endif
5488 C
5489         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5490      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5491      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5492      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5493      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5494      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5495      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5496      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5497 #ifdef DEBUG
5498         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5499 #endif
5500 C
5501         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5502      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5503      &  +pom1*pom_dt1+pom2*pom_dt2
5504 #ifdef DEBUG
5505         write(2,*), "de_dt = ", de_dt,de_dt_num
5506 #endif
5507 c
5508 C
5509        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5510        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5511        cosfac2xx=cosfac2*xx
5512        sinfac2yy=sinfac2*yy
5513        do k = 1,3
5514          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5515      &      vbld_inv(i+1)
5516          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5517      &      vbld_inv(i)
5518          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5519          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5520 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5521 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5522 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5523 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5524          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5525          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5526          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5527          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5528          dZZ_Ci1(k)=0.0d0
5529          dZZ_Ci(k)=0.0d0
5530          do j=1,3
5531            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5532            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5533          enddo
5534
5535          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5536          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5537          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5538 c
5539          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5540          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5541        enddo
5542
5543        do k=1,3
5544          dXX_Ctab(k,i)=dXX_Ci(k)
5545          dXX_C1tab(k,i)=dXX_Ci1(k)
5546          dYY_Ctab(k,i)=dYY_Ci(k)
5547          dYY_C1tab(k,i)=dYY_Ci1(k)
5548          dZZ_Ctab(k,i)=dZZ_Ci(k)
5549          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5550          dXX_XYZtab(k,i)=dXX_XYZ(k)
5551          dYY_XYZtab(k,i)=dYY_XYZ(k)
5552          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5553        enddo
5554
5555        do k = 1,3
5556 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5557 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5558 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5559 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5560 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5561 c     &    dt_dci(k)
5562 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5563 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5564          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5565      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5566          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5567      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5568          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5569      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5570        enddo
5571 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5572 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5573
5574 C to check gradient call subroutine check_grad
5575
5576     1 continue
5577       enddo
5578       return
5579       end
5580 c------------------------------------------------------------------------------
5581       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5582       implicit none
5583       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5584      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5585       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5586      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5587      &   + x(10)*yy*zz
5588       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5589      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5590      & + x(20)*yy*zz
5591       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5592      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5593      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5594      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5595      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5596      &  +x(40)*xx*yy*zz
5597       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5598      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5599      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5600      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5601      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5602      &  +x(60)*xx*yy*zz
5603       dsc_i   = 0.743d0+x(61)
5604       dp2_i   = 1.9d0+x(62)
5605       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5606      &          *(xx*cost2+yy*sint2))
5607       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5608      &          *(xx*cost2-yy*sint2))
5609       s1=(1+x(63))/(0.1d0 + dscp1)
5610       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5611       s2=(1+x(65))/(0.1d0 + dscp2)
5612       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5613       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5614      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5615       enesc=sumene
5616       return
5617       end
5618 #endif
5619 c------------------------------------------------------------------------------
5620       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5621 C
5622 C This procedure calculates two-body contact function g(rij) and its derivative:
5623 C
5624 C           eps0ij                                     !       x < -1
5625 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5626 C            0                                         !       x > 1
5627 C
5628 C where x=(rij-r0ij)/delta
5629 C
5630 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5631 C
5632       implicit none
5633       double precision rij,r0ij,eps0ij,fcont,fprimcont
5634       double precision x,x2,x4,delta
5635 c     delta=0.02D0*r0ij
5636 c      delta=0.2D0*r0ij
5637       x=(rij-r0ij)/delta
5638       if (x.lt.-1.0D0) then
5639         fcont=eps0ij
5640         fprimcont=0.0D0
5641       else if (x.le.1.0D0) then
5642         x2=x*x
5643         x4=x2*x2
5644         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5645         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5646       else
5647         fcont=0.0D0
5648         fprimcont=0.0D0
5649       endif
5650       return
5651       end
5652 c------------------------------------------------------------------------------
5653       subroutine splinthet(theti,delta,ss,ssder)
5654       implicit real*8 (a-h,o-z)
5655       include 'DIMENSIONS'
5656       include 'COMMON.VAR'
5657       include 'COMMON.GEO'
5658       thetup=pi-delta
5659       thetlow=delta
5660       if (theti.gt.pipol) then
5661         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5662       else
5663         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5664         ssder=-ssder
5665       endif
5666       return
5667       end
5668 c------------------------------------------------------------------------------
5669       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5670       implicit none
5671       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5672       double precision ksi,ksi2,ksi3,a1,a2,a3
5673       a1=fprim0*delta/(f1-f0)
5674       a2=3.0d0-2.0d0*a1
5675       a3=a1-2.0d0
5676       ksi=(x-x0)/delta
5677       ksi2=ksi*ksi
5678       ksi3=ksi2*ksi
5679       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5680       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5681       return
5682       end
5683 c------------------------------------------------------------------------------
5684       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5685       implicit none
5686       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5687       double precision ksi,ksi2,ksi3,a1,a2,a3
5688       ksi=(x-x0)/delta
5689       ksi2=ksi*ksi
5690       ksi3=ksi2*ksi
5691       a1=fprim0x*delta
5692       a2=3*(f1x-f0x)-2*fprim0x*delta
5693       a3=fprim0x*delta-2*(f1x-f0x)
5694       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5695       return
5696       end
5697 C-----------------------------------------------------------------------------
5698 #ifdef CRYST_TOR
5699 C-----------------------------------------------------------------------------
5700       subroutine etor(etors,edihcnstr)
5701       implicit real*8 (a-h,o-z)
5702       include 'DIMENSIONS'
5703       include 'COMMON.VAR'
5704       include 'COMMON.GEO'
5705       include 'COMMON.LOCAL'
5706       include 'COMMON.TORSION'
5707       include 'COMMON.INTERACT'
5708       include 'COMMON.DERIV'
5709       include 'COMMON.CHAIN'
5710       include 'COMMON.NAMES'
5711       include 'COMMON.IOUNITS'
5712       include 'COMMON.FFIELD'
5713       include 'COMMON.TORCNSTR'
5714       include 'COMMON.CONTROL'
5715       logical lprn
5716 C Set lprn=.true. for debugging
5717       lprn=.false.
5718 c      lprn=.true.
5719       etors=0.0D0
5720       do i=iphi_start,iphi_end
5721       etors_ii=0.0D0
5722         itori=itortyp(itype(i-2))
5723         itori1=itortyp(itype(i-1))
5724         phii=phi(i)
5725         gloci=0.0D0
5726 C Proline-Proline pair is a special case...
5727         if (itori.eq.3 .and. itori1.eq.3) then
5728           if (phii.gt.-dwapi3) then
5729             cosphi=dcos(3*phii)
5730             fac=1.0D0/(1.0D0-cosphi)
5731             etorsi=v1(1,3,3)*fac
5732             etorsi=etorsi+etorsi
5733             etors=etors+etorsi-v1(1,3,3)
5734             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5735             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5736           endif
5737           do j=1,3
5738             v1ij=v1(j+1,itori,itori1)
5739             v2ij=v2(j+1,itori,itori1)
5740             cosphi=dcos(j*phii)
5741             sinphi=dsin(j*phii)
5742             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5743             if (energy_dec) etors_ii=etors_ii+
5744      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5745             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5746           enddo
5747         else
5748           do j=1,nterm_old
5749             v1ij=v1(j,itori,itori1)
5750             v2ij=v2(j,itori,itori1)
5751             cosphi=dcos(j*phii)
5752             sinphi=dsin(j*phii)
5753             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5754             if (energy_dec) etors_ii=etors_ii+
5755      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5756             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5757           enddo
5758         endif
5759         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5760      &        'etor',i,etors_ii
5761         if (lprn)
5762      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5763      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5764      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5765         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5766         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5767       enddo
5768 ! 6/20/98 - dihedral angle constraints
5769       edihcnstr=0.0d0
5770       do i=1,ndih_constr
5771         itori=idih_constr(i)
5772         phii=phi(itori)
5773         difi=phii-phi0(i)
5774         if (difi.gt.drange(i)) then
5775           difi=difi-drange(i)
5776           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5777           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5778         else if (difi.lt.-drange(i)) then
5779           difi=difi+drange(i)
5780           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5781           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5782         endif
5783 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5784 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5785       enddo
5786 !      write (iout,*) 'edihcnstr',edihcnstr
5787       return
5788       end
5789 c------------------------------------------------------------------------------
5790       subroutine etor_d(etors_d)
5791       etors_d=0.0d0
5792       return
5793       end
5794 c----------------------------------------------------------------------------
5795 #else
5796       subroutine etor(etors,edihcnstr)
5797       implicit real*8 (a-h,o-z)
5798       include 'DIMENSIONS'
5799       include 'COMMON.VAR'
5800       include 'COMMON.GEO'
5801       include 'COMMON.LOCAL'
5802       include 'COMMON.TORSION'
5803       include 'COMMON.INTERACT'
5804       include 'COMMON.DERIV'
5805       include 'COMMON.CHAIN'
5806       include 'COMMON.NAMES'
5807       include 'COMMON.IOUNITS'
5808       include 'COMMON.FFIELD'
5809       include 'COMMON.TORCNSTR'
5810       include 'COMMON.CONTROL'
5811       logical lprn
5812 C Set lprn=.true. for debugging
5813       lprn=.false.
5814 c     lprn=.true.
5815       etors=0.0D0
5816       do i=iphi_start,iphi_end
5817       etors_ii=0.0D0
5818         itori=itortyp(itype(i-2))
5819         itori1=itortyp(itype(i-1))
5820         phii=phi(i)
5821         gloci=0.0D0
5822 C Regular cosine and sine terms
5823         do j=1,nterm(itori,itori1)
5824           v1ij=v1(j,itori,itori1)
5825           v2ij=v2(j,itori,itori1)
5826           cosphi=dcos(j*phii)
5827           sinphi=dsin(j*phii)
5828           etors=etors+v1ij*cosphi+v2ij*sinphi
5829           if (energy_dec) etors_ii=etors_ii+
5830      &                v1ij*cosphi+v2ij*sinphi
5831           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5832         enddo
5833 C Lorentz terms
5834 C                         v1
5835 C  E = SUM ----------------------------------- - v1
5836 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5837 C
5838         cosphi=dcos(0.5d0*phii)
5839         sinphi=dsin(0.5d0*phii)
5840         do j=1,nlor(itori,itori1)
5841           vl1ij=vlor1(j,itori,itori1)
5842           vl2ij=vlor2(j,itori,itori1)
5843           vl3ij=vlor3(j,itori,itori1)
5844           pom=vl2ij*cosphi+vl3ij*sinphi
5845           pom1=1.0d0/(pom*pom+1.0d0)
5846           etors=etors+vl1ij*pom1
5847           if (energy_dec) etors_ii=etors_ii+
5848      &                vl1ij*pom1
5849           pom=-pom*pom1*pom1
5850           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5851         enddo
5852 C Subtract the constant term
5853         etors=etors-v0(itori,itori1)
5854           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5855      &         'etor',i,etors_ii-v0(itori,itori1)
5856         if (lprn)
5857      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5858      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5859      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5860         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5861 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5862       enddo
5863 ! 6/20/98 - dihedral angle constraints
5864       edihcnstr=0.0d0
5865 c      do i=1,ndih_constr
5866       do i=idihconstr_start,idihconstr_end
5867         itori=idih_constr(i)
5868         phii=phi(itori)
5869         difi=pinorm(phii-phi0(i))
5870         if (difi.gt.drange(i)) then
5871           difi=difi-drange(i)
5872           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5873           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5874         else if (difi.lt.-drange(i)) then
5875           difi=difi+drange(i)
5876           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5877           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5878         else
5879           difi=0.0
5880         endif
5881 c        write (iout,*) "gloci", gloc(i-3,icg)
5882 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5883 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5884 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5885       enddo
5886 cd       write (iout,*) 'edihcnstr',edihcnstr
5887       return
5888       end
5889 c----------------------------------------------------------------------------
5890       subroutine etor_d(etors_d)
5891 C 6/23/01 Compute double torsional energy
5892       implicit real*8 (a-h,o-z)
5893       include 'DIMENSIONS'
5894       include 'COMMON.VAR'
5895       include 'COMMON.GEO'
5896       include 'COMMON.LOCAL'
5897       include 'COMMON.TORSION'
5898       include 'COMMON.INTERACT'
5899       include 'COMMON.DERIV'
5900       include 'COMMON.CHAIN'
5901       include 'COMMON.NAMES'
5902       include 'COMMON.IOUNITS'
5903       include 'COMMON.FFIELD'
5904       include 'COMMON.TORCNSTR'
5905       logical lprn
5906 C Set lprn=.true. for debugging
5907       lprn=.false.
5908 c     lprn=.true.
5909       etors_d=0.0D0
5910       do i=iphid_start,iphid_end
5911         itori=itortyp(itype(i-2))
5912         itori1=itortyp(itype(i-1))
5913         itori2=itortyp(itype(i))
5914         phii=phi(i)
5915         phii1=phi(i+1)
5916         gloci1=0.0D0
5917         gloci2=0.0D0
5918         do j=1,ntermd_1(itori,itori1,itori2)
5919           v1cij=v1c(1,j,itori,itori1,itori2)
5920           v1sij=v1s(1,j,itori,itori1,itori2)
5921           v2cij=v1c(2,j,itori,itori1,itori2)
5922           v2sij=v1s(2,j,itori,itori1,itori2)
5923           cosphi1=dcos(j*phii)
5924           sinphi1=dsin(j*phii)
5925           cosphi2=dcos(j*phii1)
5926           sinphi2=dsin(j*phii1)
5927           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5928      &     v2cij*cosphi2+v2sij*sinphi2
5929           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5930           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5931         enddo
5932         do k=2,ntermd_2(itori,itori1,itori2)
5933           do l=1,k-1
5934             v1cdij = v2c(k,l,itori,itori1,itori2)
5935             v2cdij = v2c(l,k,itori,itori1,itori2)
5936             v1sdij = v2s(k,l,itori,itori1,itori2)
5937             v2sdij = v2s(l,k,itori,itori1,itori2)
5938             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5939             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5940             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5941             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5942             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5943      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5944             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5945      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5946             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5947      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5948           enddo
5949         enddo
5950         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5951         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5952 c        write (iout,*) "gloci", gloc(i-3,icg)
5953       enddo
5954       return
5955       end
5956 #endif
5957 c------------------------------------------------------------------------------
5958       subroutine eback_sc_corr(esccor)
5959 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5960 c        conformational states; temporarily implemented as differences
5961 c        between UNRES torsional potentials (dependent on three types of
5962 c        residues) and the torsional potentials dependent on all 20 types
5963 c        of residues computed from AM1  energy surfaces of terminally-blocked
5964 c        amino-acid residues.
5965       implicit real*8 (a-h,o-z)
5966       include 'DIMENSIONS'
5967       include 'COMMON.VAR'
5968       include 'COMMON.GEO'
5969       include 'COMMON.LOCAL'
5970       include 'COMMON.TORSION'
5971       include 'COMMON.SCCOR'
5972       include 'COMMON.INTERACT'
5973       include 'COMMON.DERIV'
5974       include 'COMMON.CHAIN'
5975       include 'COMMON.NAMES'
5976       include 'COMMON.IOUNITS'
5977       include 'COMMON.FFIELD'
5978       include 'COMMON.CONTROL'
5979       logical lprn
5980 C Set lprn=.true. for debugging
5981       lprn=.false.
5982 c      lprn=.true.
5983 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5984       esccor=0.0D0
5985       do i=itau_start,itau_end
5986         esccor_ii=0.0D0
5987         isccori=isccortyp(itype(i-2))
5988         isccori1=isccortyp(itype(i-1))
5989         phii=phi(i)
5990 cccc  Added 9 May 2012
5991 cc Tauangle is torsional engle depending on the value of first digit
5992 c(see comment below)
5993 cc Omicron is flat angle depending on the value of first digit
5994 c(see comment below)
5995
5996
5997         do intertyp=1,3 !intertyp
5998 cc Added 09 May 2012 (Adasko)
5999 cc  Intertyp means interaction type of backbone mainchain correlation:
6000 c   1 = SC...Ca...Ca...Ca
6001 c   2 = Ca...Ca...Ca...SC
6002 c   3 = SC...Ca...Ca...SCi
6003         gloci=0.0D0
6004         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6005      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6006      &      (itype(i-1).eq.21)))
6007      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6008      &     .or.(itype(i-2).eq.21)))
6009      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6010      &      (itype(i-1).eq.21)))) cycle
6011         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6012         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6013      & cycle
6014         do j=1,nterm_sccor(isccori,isccori1)
6015           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6016           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6017           cosphi=dcos(j*tauangle(intertyp,i))
6018           sinphi=dsin(j*tauangle(intertyp,i))
6019           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6020           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6021         enddo
6022         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6023 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6024 c     &gloc_sc(intertyp,i-3,icg)
6025         if (lprn)
6026      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6027      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6028      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6029      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6030         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6031        enddo !intertyp
6032       enddo
6033 c        do i=1,nres
6034 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6035 c        enddo
6036       return
6037       end
6038 c----------------------------------------------------------------------------
6039       subroutine multibody(ecorr)
6040 C This subroutine calculates multi-body contributions to energy following
6041 C the idea of Skolnick et al. If side chains I and J make a contact and
6042 C at the same time side chains I+1 and J+1 make a contact, an extra
6043 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6044       implicit real*8 (a-h,o-z)
6045       include 'DIMENSIONS'
6046       include 'COMMON.IOUNITS'
6047       include 'COMMON.DERIV'
6048       include 'COMMON.INTERACT'
6049       include 'COMMON.CONTACTS'
6050       double precision gx(3),gx1(3)
6051       logical lprn
6052
6053 C Set lprn=.true. for debugging
6054       lprn=.false.
6055
6056       if (lprn) then
6057         write (iout,'(a)') 'Contact function values:'
6058         do i=nnt,nct-2
6059           write (iout,'(i2,20(1x,i2,f10.5))')
6060      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6061         enddo
6062       endif
6063       ecorr=0.0D0
6064       do i=nnt,nct
6065         do j=1,3
6066           gradcorr(j,i)=0.0D0
6067           gradxorr(j,i)=0.0D0
6068         enddo
6069       enddo
6070       do i=nnt,nct-2
6071
6072         DO ISHIFT = 3,4
6073
6074         i1=i+ishift
6075         num_conti=num_cont(i)
6076         num_conti1=num_cont(i1)
6077         do jj=1,num_conti
6078           j=jcont(jj,i)
6079           do kk=1,num_conti1
6080             j1=jcont(kk,i1)
6081             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6082 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6083 cd   &                   ' ishift=',ishift
6084 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6085 C The system gains extra energy.
6086               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6087             endif   ! j1==j+-ishift
6088           enddo     ! kk
6089         enddo       ! jj
6090
6091         ENDDO ! ISHIFT
6092
6093       enddo         ! i
6094       return
6095       end
6096 c------------------------------------------------------------------------------
6097       double precision function esccorr(i,j,k,l,jj,kk)
6098       implicit real*8 (a-h,o-z)
6099       include 'DIMENSIONS'
6100       include 'COMMON.IOUNITS'
6101       include 'COMMON.DERIV'
6102       include 'COMMON.INTERACT'
6103       include 'COMMON.CONTACTS'
6104       double precision gx(3),gx1(3)
6105       logical lprn
6106       lprn=.false.
6107       eij=facont(jj,i)
6108       ekl=facont(kk,k)
6109 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6110 C Calculate the multi-body contribution to energy.
6111 C Calculate multi-body contributions to the gradient.
6112 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6113 cd   & k,l,(gacont(m,kk,k),m=1,3)
6114       do m=1,3
6115         gx(m) =ekl*gacont(m,jj,i)
6116         gx1(m)=eij*gacont(m,kk,k)
6117         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6118         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6119         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6120         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6121       enddo
6122       do m=i,j-1
6123         do ll=1,3
6124           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6125         enddo
6126       enddo
6127       do m=k,l-1
6128         do ll=1,3
6129           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6130         enddo
6131       enddo
6132       esccorr=-eij*ekl
6133       return
6134       end
6135 c------------------------------------------------------------------------------
6136       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6137 C This subroutine calculates multi-body contributions to hydrogen-bonding
6138       implicit real*8 (a-h,o-z)
6139       include 'DIMENSIONS'
6140       include 'COMMON.IOUNITS'
6141 #ifdef MPI
6142       include "mpif.h"
6143       parameter (max_cont=maxconts)
6144       parameter (max_dim=26)
6145       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6146       double precision zapas(max_dim,maxconts,max_fg_procs),
6147      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6148       common /przechowalnia/ zapas
6149       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6150      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6151 #endif
6152       include 'COMMON.SETUP'
6153       include 'COMMON.FFIELD'
6154       include 'COMMON.DERIV'
6155       include 'COMMON.INTERACT'
6156       include 'COMMON.CONTACTS'
6157       include 'COMMON.CONTROL'
6158       include 'COMMON.LOCAL'
6159       double precision gx(3),gx1(3),time00
6160       logical lprn,ldone
6161
6162 C Set lprn=.true. for debugging
6163       lprn=.false.
6164 #ifdef MPI
6165       n_corr=0
6166       n_corr1=0
6167       if (nfgtasks.le.1) goto 30
6168       if (lprn) then
6169         write (iout,'(a)') 'Contact function values before RECEIVE:'
6170         do i=nnt,nct-2
6171           write (iout,'(2i3,50(1x,i2,f5.2))')
6172      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6173      &    j=1,num_cont_hb(i))
6174         enddo
6175       endif
6176       call flush(iout)
6177       do i=1,ntask_cont_from
6178         ncont_recv(i)=0
6179       enddo
6180       do i=1,ntask_cont_to
6181         ncont_sent(i)=0
6182       enddo
6183 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6184 c     & ntask_cont_to
6185 C Make the list of contacts to send to send to other procesors
6186 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6187 c      call flush(iout)
6188       do i=iturn3_start,iturn3_end
6189 c        write (iout,*) "make contact list turn3",i," num_cont",
6190 c     &    num_cont_hb(i)
6191         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6192       enddo
6193       do i=iturn4_start,iturn4_end
6194 c        write (iout,*) "make contact list turn4",i," num_cont",
6195 c     &   num_cont_hb(i)
6196         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6197       enddo
6198       do ii=1,nat_sent
6199         i=iat_sent(ii)
6200 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6201 c     &    num_cont_hb(i)
6202         do j=1,num_cont_hb(i)
6203         do k=1,4
6204           jjc=jcont_hb(j,i)
6205           iproc=iint_sent_local(k,jjc,ii)
6206 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6207           if (iproc.gt.0) then
6208             ncont_sent(iproc)=ncont_sent(iproc)+1
6209             nn=ncont_sent(iproc)
6210             zapas(1,nn,iproc)=i
6211             zapas(2,nn,iproc)=jjc
6212             zapas(3,nn,iproc)=facont_hb(j,i)
6213             zapas(4,nn,iproc)=ees0p(j,i)
6214             zapas(5,nn,iproc)=ees0m(j,i)
6215             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6216             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6217             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6218             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6219             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6220             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6221             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6222             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6223             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6224             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6225             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6226             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6227             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6228             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6229             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6230             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6231             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6232             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6233             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6234             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6235             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6236           endif
6237         enddo
6238         enddo
6239       enddo
6240       if (lprn) then
6241       write (iout,*)
6242      &  "Numbers of contacts to be sent to other processors",
6243      &  (ncont_sent(i),i=1,ntask_cont_to)
6244       write (iout,*) "Contacts sent"
6245       do ii=1,ntask_cont_to
6246         nn=ncont_sent(ii)
6247         iproc=itask_cont_to(ii)
6248         write (iout,*) nn," contacts to processor",iproc,
6249      &   " of CONT_TO_COMM group"
6250         do i=1,nn
6251           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6252         enddo
6253       enddo
6254       call flush(iout)
6255       endif
6256       CorrelType=477
6257       CorrelID=fg_rank+1
6258       CorrelType1=478
6259       CorrelID1=nfgtasks+fg_rank+1
6260       ireq=0
6261 C Receive the numbers of needed contacts from other processors
6262       do ii=1,ntask_cont_from
6263         iproc=itask_cont_from(ii)
6264         ireq=ireq+1
6265         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6266      &    FG_COMM,req(ireq),IERR)
6267       enddo
6268 c      write (iout,*) "IRECV ended"
6269 c      call flush(iout)
6270 C Send the number of contacts needed by other processors
6271       do ii=1,ntask_cont_to
6272         iproc=itask_cont_to(ii)
6273         ireq=ireq+1
6274         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6275      &    FG_COMM,req(ireq),IERR)
6276       enddo
6277 c      write (iout,*) "ISEND ended"
6278 c      write (iout,*) "number of requests (nn)",ireq
6279       call flush(iout)
6280       if (ireq.gt.0)
6281      &  call MPI_Waitall(ireq,req,status_array,ierr)
6282 c      write (iout,*)
6283 c     &  "Numbers of contacts to be received from other processors",
6284 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6285 c      call flush(iout)
6286 C Receive contacts
6287       ireq=0
6288       do ii=1,ntask_cont_from
6289         iproc=itask_cont_from(ii)
6290         nn=ncont_recv(ii)
6291 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6292 c     &   " of CONT_TO_COMM group"
6293         call flush(iout)
6294         if (nn.gt.0) then
6295           ireq=ireq+1
6296           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6297      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6298 c          write (iout,*) "ireq,req",ireq,req(ireq)
6299         endif
6300       enddo
6301 C Send the contacts to processors that need them
6302       do ii=1,ntask_cont_to
6303         iproc=itask_cont_to(ii)
6304         nn=ncont_sent(ii)
6305 c        write (iout,*) nn," contacts to processor",iproc,
6306 c     &   " of CONT_TO_COMM group"
6307         if (nn.gt.0) then
6308           ireq=ireq+1
6309           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6310      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6311 c          write (iout,*) "ireq,req",ireq,req(ireq)
6312 c          do i=1,nn
6313 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6314 c          enddo
6315         endif
6316       enddo
6317 c      write (iout,*) "number of requests (contacts)",ireq
6318 c      write (iout,*) "req",(req(i),i=1,4)
6319 c      call flush(iout)
6320       if (ireq.gt.0)
6321      & call MPI_Waitall(ireq,req,status_array,ierr)
6322       do iii=1,ntask_cont_from
6323         iproc=itask_cont_from(iii)
6324         nn=ncont_recv(iii)
6325         if (lprn) then
6326         write (iout,*) "Received",nn," contacts from processor",iproc,
6327      &   " of CONT_FROM_COMM group"
6328         call flush(iout)
6329         do i=1,nn
6330           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6331         enddo
6332         call flush(iout)
6333         endif
6334         do i=1,nn
6335           ii=zapas_recv(1,i,iii)
6336 c Flag the received contacts to prevent double-counting
6337           jj=-zapas_recv(2,i,iii)
6338 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6339 c          call flush(iout)
6340           nnn=num_cont_hb(ii)+1
6341           num_cont_hb(ii)=nnn
6342           jcont_hb(nnn,ii)=jj
6343           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6344           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6345           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6346           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6347           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6348           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6349           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6350           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6351           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6352           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6353           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6354           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6355           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6356           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6357           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6358           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6359           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6360           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6361           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6362           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6363           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6364           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6365           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6366           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6367         enddo
6368       enddo
6369       call flush(iout)
6370       if (lprn) then
6371         write (iout,'(a)') 'Contact function values after receive:'
6372         do i=nnt,nct-2
6373           write (iout,'(2i3,50(1x,i3,f5.2))')
6374      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6375      &    j=1,num_cont_hb(i))
6376         enddo
6377         call flush(iout)
6378       endif
6379    30 continue
6380 #endif
6381       if (lprn) then
6382         write (iout,'(a)') 'Contact function values:'
6383         do i=nnt,nct-2
6384           write (iout,'(2i3,50(1x,i3,f5.2))')
6385      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6386      &    j=1,num_cont_hb(i))
6387         enddo
6388       endif
6389       ecorr=0.0D0
6390 C Remove the loop below after debugging !!!
6391       do i=nnt,nct
6392         do j=1,3
6393           gradcorr(j,i)=0.0D0
6394           gradxorr(j,i)=0.0D0
6395         enddo
6396       enddo
6397 C Calculate the local-electrostatic correlation terms
6398       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6399         i1=i+1
6400         num_conti=num_cont_hb(i)
6401         num_conti1=num_cont_hb(i+1)
6402         do jj=1,num_conti
6403           j=jcont_hb(jj,i)
6404           jp=iabs(j)
6405           do kk=1,num_conti1
6406             j1=jcont_hb(kk,i1)
6407             jp1=iabs(j1)
6408 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6409 c     &         ' jj=',jj,' kk=',kk
6410             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6411      &          .or. j.lt.0 .and. j1.gt.0) .and.
6412      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6413 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6414 C The system gains extra energy.
6415               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6416               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6417      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6418               n_corr=n_corr+1
6419             else if (j1.eq.j) then
6420 C Contacts I-J and I-(J+1) occur simultaneously.
6421 C The system loses extra energy.
6422 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6423             endif
6424           enddo ! kk
6425           do kk=1,num_conti
6426             j1=jcont_hb(kk,i)
6427 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6428 c    &         ' jj=',jj,' kk=',kk
6429             if (j1.eq.j+1) then
6430 C Contacts I-J and (I+1)-J occur simultaneously.
6431 C The system loses extra energy.
6432 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6433             endif ! j1==j+1
6434           enddo ! kk
6435         enddo ! jj
6436       enddo ! i
6437       return
6438       end
6439 c------------------------------------------------------------------------------
6440       subroutine add_hb_contact(ii,jj,itask)
6441       implicit real*8 (a-h,o-z)
6442       include "DIMENSIONS"
6443       include "COMMON.IOUNITS"
6444       integer max_cont
6445       integer max_dim
6446       parameter (max_cont=maxconts)
6447       parameter (max_dim=26)
6448       include "COMMON.CONTACTS"
6449       double precision zapas(max_dim,maxconts,max_fg_procs),
6450      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6451       common /przechowalnia/ zapas
6452       integer i,j,ii,jj,iproc,itask(4),nn
6453 c      write (iout,*) "itask",itask
6454       do i=1,2
6455         iproc=itask(i)
6456         if (iproc.gt.0) then
6457           do j=1,num_cont_hb(ii)
6458             jjc=jcont_hb(j,ii)
6459 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6460             if (jjc.eq.jj) then
6461               ncont_sent(iproc)=ncont_sent(iproc)+1
6462               nn=ncont_sent(iproc)
6463               zapas(1,nn,iproc)=ii
6464               zapas(2,nn,iproc)=jjc
6465               zapas(3,nn,iproc)=facont_hb(j,ii)
6466               zapas(4,nn,iproc)=ees0p(j,ii)
6467               zapas(5,nn,iproc)=ees0m(j,ii)
6468               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6469               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6470               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6471               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6472               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6473               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6474               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6475               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6476               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6477               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6478               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6479               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6480               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6481               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6482               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6483               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6484               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6485               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6486               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6487               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6488               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6489               exit
6490             endif
6491           enddo
6492         endif
6493       enddo
6494       return
6495       end
6496 c------------------------------------------------------------------------------
6497       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6498      &  n_corr1)
6499 C This subroutine calculates multi-body contributions to hydrogen-bonding
6500       implicit real*8 (a-h,o-z)
6501       include 'DIMENSIONS'
6502       include 'COMMON.IOUNITS'
6503 #ifdef MPI
6504       include "mpif.h"
6505       parameter (max_cont=maxconts)
6506       parameter (max_dim=70)
6507       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6508       double precision zapas(max_dim,maxconts,max_fg_procs),
6509      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6510       common /przechowalnia/ zapas
6511       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6512      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6513 #endif
6514       include 'COMMON.SETUP'
6515       include 'COMMON.FFIELD'
6516       include 'COMMON.DERIV'
6517       include 'COMMON.LOCAL'
6518       include 'COMMON.INTERACT'
6519       include 'COMMON.CONTACTS'
6520       include 'COMMON.CHAIN'
6521       include 'COMMON.CONTROL'
6522       double precision gx(3),gx1(3)
6523       integer num_cont_hb_old(maxres)
6524       logical lprn,ldone
6525       double precision eello4,eello5,eelo6,eello_turn6
6526       external eello4,eello5,eello6,eello_turn6
6527 C Set lprn=.true. for debugging
6528       lprn=.false.
6529       eturn6=0.0d0
6530 #ifdef MPI
6531       do i=1,nres
6532         num_cont_hb_old(i)=num_cont_hb(i)
6533       enddo
6534       n_corr=0
6535       n_corr1=0
6536       if (nfgtasks.le.1) goto 30
6537       if (lprn) then
6538         write (iout,'(a)') 'Contact function values before RECEIVE:'
6539         do i=nnt,nct-2
6540           write (iout,'(2i3,50(1x,i2,f5.2))')
6541      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6542      &    j=1,num_cont_hb(i))
6543         enddo
6544       endif
6545       call flush(iout)
6546       do i=1,ntask_cont_from
6547         ncont_recv(i)=0
6548       enddo
6549       do i=1,ntask_cont_to
6550         ncont_sent(i)=0
6551       enddo
6552 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6553 c     & ntask_cont_to
6554 C Make the list of contacts to send to send to other procesors
6555       do i=iturn3_start,iturn3_end
6556 c        write (iout,*) "make contact list turn3",i," num_cont",
6557 c     &    num_cont_hb(i)
6558         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6559       enddo
6560       do i=iturn4_start,iturn4_end
6561 c        write (iout,*) "make contact list turn4",i," num_cont",
6562 c     &   num_cont_hb(i)
6563         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6564       enddo
6565       do ii=1,nat_sent
6566         i=iat_sent(ii)
6567 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6568 c     &    num_cont_hb(i)
6569         do j=1,num_cont_hb(i)
6570         do k=1,4
6571           jjc=jcont_hb(j,i)
6572           iproc=iint_sent_local(k,jjc,ii)
6573 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6574           if (iproc.ne.0) then
6575             ncont_sent(iproc)=ncont_sent(iproc)+1
6576             nn=ncont_sent(iproc)
6577             zapas(1,nn,iproc)=i
6578             zapas(2,nn,iproc)=jjc
6579             zapas(3,nn,iproc)=d_cont(j,i)
6580             ind=3
6581             do kk=1,3
6582               ind=ind+1
6583               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6584             enddo
6585             do kk=1,2
6586               do ll=1,2
6587                 ind=ind+1
6588                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6589               enddo
6590             enddo
6591             do jj=1,5
6592               do kk=1,3
6593                 do ll=1,2
6594                   do mm=1,2
6595                     ind=ind+1
6596                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6597                   enddo
6598                 enddo
6599               enddo
6600             enddo
6601           endif
6602         enddo
6603         enddo
6604       enddo
6605       if (lprn) then
6606       write (iout,*)
6607      &  "Numbers of contacts to be sent to other processors",
6608      &  (ncont_sent(i),i=1,ntask_cont_to)
6609       write (iout,*) "Contacts sent"
6610       do ii=1,ntask_cont_to
6611         nn=ncont_sent(ii)
6612         iproc=itask_cont_to(ii)
6613         write (iout,*) nn," contacts to processor",iproc,
6614      &   " of CONT_TO_COMM group"
6615         do i=1,nn
6616           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6617         enddo
6618       enddo
6619       call flush(iout)
6620       endif
6621       CorrelType=477
6622       CorrelID=fg_rank+1
6623       CorrelType1=478
6624       CorrelID1=nfgtasks+fg_rank+1
6625       ireq=0
6626 C Receive the numbers of needed contacts from other processors
6627       do ii=1,ntask_cont_from
6628         iproc=itask_cont_from(ii)
6629         ireq=ireq+1
6630         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6631      &    FG_COMM,req(ireq),IERR)
6632       enddo
6633 c      write (iout,*) "IRECV ended"
6634 c      call flush(iout)
6635 C Send the number of contacts needed by other processors
6636       do ii=1,ntask_cont_to
6637         iproc=itask_cont_to(ii)
6638         ireq=ireq+1
6639         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6640      &    FG_COMM,req(ireq),IERR)
6641       enddo
6642 c      write (iout,*) "ISEND ended"
6643 c      write (iout,*) "number of requests (nn)",ireq
6644       call flush(iout)
6645       if (ireq.gt.0)
6646      &  call MPI_Waitall(ireq,req,status_array,ierr)
6647 c      write (iout,*)
6648 c     &  "Numbers of contacts to be received from other processors",
6649 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6650 c      call flush(iout)
6651 C Receive contacts
6652       ireq=0
6653       do ii=1,ntask_cont_from
6654         iproc=itask_cont_from(ii)
6655         nn=ncont_recv(ii)
6656 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6657 c     &   " of CONT_TO_COMM group"
6658         call flush(iout)
6659         if (nn.gt.0) then
6660           ireq=ireq+1
6661           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6662      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6663 c          write (iout,*) "ireq,req",ireq,req(ireq)
6664         endif
6665       enddo
6666 C Send the contacts to processors that need them
6667       do ii=1,ntask_cont_to
6668         iproc=itask_cont_to(ii)
6669         nn=ncont_sent(ii)
6670 c        write (iout,*) nn," contacts to processor",iproc,
6671 c     &   " of CONT_TO_COMM group"
6672         if (nn.gt.0) then
6673           ireq=ireq+1
6674           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6675      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6676 c          write (iout,*) "ireq,req",ireq,req(ireq)
6677 c          do i=1,nn
6678 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6679 c          enddo
6680         endif
6681       enddo
6682 c      write (iout,*) "number of requests (contacts)",ireq
6683 c      write (iout,*) "req",(req(i),i=1,4)
6684 c      call flush(iout)
6685       if (ireq.gt.0)
6686      & call MPI_Waitall(ireq,req,status_array,ierr)
6687       do iii=1,ntask_cont_from
6688         iproc=itask_cont_from(iii)
6689         nn=ncont_recv(iii)
6690         if (lprn) then
6691         write (iout,*) "Received",nn," contacts from processor",iproc,
6692      &   " of CONT_FROM_COMM group"
6693         call flush(iout)
6694         do i=1,nn
6695           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6696         enddo
6697         call flush(iout)
6698         endif
6699         do i=1,nn
6700           ii=zapas_recv(1,i,iii)
6701 c Flag the received contacts to prevent double-counting
6702           jj=-zapas_recv(2,i,iii)
6703 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6704 c          call flush(iout)
6705           nnn=num_cont_hb(ii)+1
6706           num_cont_hb(ii)=nnn
6707           jcont_hb(nnn,ii)=jj
6708           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6709           ind=3
6710           do kk=1,3
6711             ind=ind+1
6712             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6713           enddo
6714           do kk=1,2
6715             do ll=1,2
6716               ind=ind+1
6717               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6718             enddo
6719           enddo
6720           do jj=1,5
6721             do kk=1,3
6722               do ll=1,2
6723                 do mm=1,2
6724                   ind=ind+1
6725                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6726                 enddo
6727               enddo
6728             enddo
6729           enddo
6730         enddo
6731       enddo
6732       call flush(iout)
6733       if (lprn) then
6734         write (iout,'(a)') 'Contact function values after receive:'
6735         do i=nnt,nct-2
6736           write (iout,'(2i3,50(1x,i3,5f6.3))')
6737      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6738      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6739         enddo
6740         call flush(iout)
6741       endif
6742    30 continue
6743 #endif
6744       if (lprn) then
6745         write (iout,'(a)') 'Contact function values:'
6746         do i=nnt,nct-2
6747           write (iout,'(2i3,50(1x,i2,5f6.3))')
6748      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6749      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6750         enddo
6751       endif
6752       ecorr=0.0D0
6753       ecorr5=0.0d0
6754       ecorr6=0.0d0
6755 C Remove the loop below after debugging !!!
6756       do i=nnt,nct
6757         do j=1,3
6758           gradcorr(j,i)=0.0D0
6759           gradxorr(j,i)=0.0D0
6760         enddo
6761       enddo
6762 C Calculate the dipole-dipole interaction energies
6763       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6764       do i=iatel_s,iatel_e+1
6765         num_conti=num_cont_hb(i)
6766         do jj=1,num_conti
6767           j=jcont_hb(jj,i)
6768 #ifdef MOMENT
6769           call dipole(i,j,jj)
6770 #endif
6771         enddo
6772       enddo
6773       endif
6774 C Calculate the local-electrostatic correlation terms
6775 c                write (iout,*) "gradcorr5 in eello5 before loop"
6776 c                do iii=1,nres
6777 c                  write (iout,'(i5,3f10.5)')
6778 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6779 c                enddo
6780       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6781 c        write (iout,*) "corr loop i",i
6782         i1=i+1
6783         num_conti=num_cont_hb(i)
6784         num_conti1=num_cont_hb(i+1)
6785         do jj=1,num_conti
6786           j=jcont_hb(jj,i)
6787           jp=iabs(j)
6788           do kk=1,num_conti1
6789             j1=jcont_hb(kk,i1)
6790             jp1=iabs(j1)
6791 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6792 c     &         ' jj=',jj,' kk=',kk
6793 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6794             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6795      &          .or. j.lt.0 .and. j1.gt.0) .and.
6796      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6797 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6798 C The system gains extra energy.
6799               n_corr=n_corr+1
6800               sqd1=dsqrt(d_cont(jj,i))
6801               sqd2=dsqrt(d_cont(kk,i1))
6802               sred_geom = sqd1*sqd2
6803               IF (sred_geom.lt.cutoff_corr) THEN
6804                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6805      &            ekont,fprimcont)
6806 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6807 cd     &         ' jj=',jj,' kk=',kk
6808                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6809                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6810                 do l=1,3
6811                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6812                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6813                 enddo
6814                 n_corr1=n_corr1+1
6815 cd               write (iout,*) 'sred_geom=',sred_geom,
6816 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6817 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6818 cd               write (iout,*) "g_contij",g_contij
6819 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6820 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6821                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6822                 if (wcorr4.gt.0.0d0)
6823      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6824                   if (energy_dec.and.wcorr4.gt.0.0d0)
6825      1                 write (iout,'(a6,4i5,0pf7.3)')
6826      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6827 c                write (iout,*) "gradcorr5 before eello5"
6828 c                do iii=1,nres
6829 c                  write (iout,'(i5,3f10.5)')
6830 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6831 c                enddo
6832                 if (wcorr5.gt.0.0d0)
6833      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6834 c                write (iout,*) "gradcorr5 after eello5"
6835 c                do iii=1,nres
6836 c                  write (iout,'(i5,3f10.5)')
6837 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6838 c                enddo
6839                   if (energy_dec.and.wcorr5.gt.0.0d0)
6840      1                 write (iout,'(a6,4i5,0pf7.3)')
6841      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6842 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6843 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6844                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6845      &               .or. wturn6.eq.0.0d0))then
6846 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6847                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6848                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6849      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6850 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6851 cd     &            'ecorr6=',ecorr6
6852 cd                write (iout,'(4e15.5)') sred_geom,
6853 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6854 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6855 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6856                 else if (wturn6.gt.0.0d0
6857      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6858 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6859                   eturn6=eturn6+eello_turn6(i,jj,kk)
6860                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6861      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6862 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6863                 endif
6864               ENDIF
6865 1111          continue
6866             endif
6867           enddo ! kk
6868         enddo ! jj
6869       enddo ! i
6870       do i=1,nres
6871         num_cont_hb(i)=num_cont_hb_old(i)
6872       enddo
6873 c                write (iout,*) "gradcorr5 in eello5"
6874 c                do iii=1,nres
6875 c                  write (iout,'(i5,3f10.5)')
6876 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6877 c                enddo
6878       return
6879       end
6880 c------------------------------------------------------------------------------
6881       subroutine add_hb_contact_eello(ii,jj,itask)
6882       implicit real*8 (a-h,o-z)
6883       include "DIMENSIONS"
6884       include "COMMON.IOUNITS"
6885       integer max_cont
6886       integer max_dim
6887       parameter (max_cont=maxconts)
6888       parameter (max_dim=70)
6889       include "COMMON.CONTACTS"
6890       double precision zapas(max_dim,maxconts,max_fg_procs),
6891      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6892       common /przechowalnia/ zapas
6893       integer i,j,ii,jj,iproc,itask(4),nn
6894 c      write (iout,*) "itask",itask
6895       do i=1,2
6896         iproc=itask(i)
6897         if (iproc.gt.0) then
6898           do j=1,num_cont_hb(ii)
6899             jjc=jcont_hb(j,ii)
6900 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6901             if (jjc.eq.jj) then
6902               ncont_sent(iproc)=ncont_sent(iproc)+1
6903               nn=ncont_sent(iproc)
6904               zapas(1,nn,iproc)=ii
6905               zapas(2,nn,iproc)=jjc
6906               zapas(3,nn,iproc)=d_cont(j,ii)
6907               ind=3
6908               do kk=1,3
6909                 ind=ind+1
6910                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6911               enddo
6912               do kk=1,2
6913                 do ll=1,2
6914                   ind=ind+1
6915                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6916                 enddo
6917               enddo
6918               do jj=1,5
6919                 do kk=1,3
6920                   do ll=1,2
6921                     do mm=1,2
6922                       ind=ind+1
6923                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6924                     enddo
6925                   enddo
6926                 enddo
6927               enddo
6928               exit
6929             endif
6930           enddo
6931         endif
6932       enddo
6933       return
6934       end
6935 c------------------------------------------------------------------------------
6936       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6937       implicit real*8 (a-h,o-z)
6938       include 'DIMENSIONS'
6939       include 'COMMON.IOUNITS'
6940       include 'COMMON.DERIV'
6941       include 'COMMON.INTERACT'
6942       include 'COMMON.CONTACTS'
6943       double precision gx(3),gx1(3)
6944       logical lprn
6945       lprn=.false.
6946       eij=facont_hb(jj,i)
6947       ekl=facont_hb(kk,k)
6948       ees0pij=ees0p(jj,i)
6949       ees0pkl=ees0p(kk,k)
6950       ees0mij=ees0m(jj,i)
6951       ees0mkl=ees0m(kk,k)
6952       ekont=eij*ekl
6953       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6954 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6955 C Following 4 lines for diagnostics.
6956 cd    ees0pkl=0.0D0
6957 cd    ees0pij=1.0D0
6958 cd    ees0mkl=0.0D0
6959 cd    ees0mij=1.0D0
6960 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6961 c     & 'Contacts ',i,j,
6962 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6963 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6964 c     & 'gradcorr_long'
6965 C Calculate the multi-body contribution to energy.
6966 c      ecorr=ecorr+ekont*ees
6967 C Calculate multi-body contributions to the gradient.
6968       coeffpees0pij=coeffp*ees0pij
6969       coeffmees0mij=coeffm*ees0mij
6970       coeffpees0pkl=coeffp*ees0pkl
6971       coeffmees0mkl=coeffm*ees0mkl
6972       do ll=1,3
6973 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6974         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6975      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6976      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6977         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6978      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6979      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6980 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6981         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6982      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6983      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6984         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6985      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6986      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6987         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6988      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6989      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6990         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6991         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6992         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6993      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6994      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6995         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6996         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6997 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6998       enddo
6999 c      write (iout,*)
7000 cgrad      do m=i+1,j-1
7001 cgrad        do ll=1,3
7002 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7003 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7004 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7005 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7006 cgrad        enddo
7007 cgrad      enddo
7008 cgrad      do m=k+1,l-1
7009 cgrad        do ll=1,3
7010 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7011 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7012 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7013 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7014 cgrad        enddo
7015 cgrad      enddo
7016 c      write (iout,*) "ehbcorr",ekont*ees
7017       ehbcorr=ekont*ees
7018       return
7019       end
7020 #ifdef MOMENT
7021 C---------------------------------------------------------------------------
7022       subroutine dipole(i,j,jj)
7023       implicit real*8 (a-h,o-z)
7024       include 'DIMENSIONS'
7025       include 'COMMON.IOUNITS'
7026       include 'COMMON.CHAIN'
7027       include 'COMMON.FFIELD'
7028       include 'COMMON.DERIV'
7029       include 'COMMON.INTERACT'
7030       include 'COMMON.CONTACTS'
7031       include 'COMMON.TORSION'
7032       include 'COMMON.VAR'
7033       include 'COMMON.GEO'
7034       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7035      &  auxmat(2,2)
7036       iti1 = itortyp(itype(i+1))
7037       if (j.lt.nres-1) then
7038         itj1 = itortyp(itype(j+1))
7039       else
7040         itj1=ntortyp+1
7041       endif
7042       do iii=1,2
7043         dipi(iii,1)=Ub2(iii,i)
7044         dipderi(iii)=Ub2der(iii,i)
7045         dipi(iii,2)=b1(iii,iti1)
7046         dipj(iii,1)=Ub2(iii,j)
7047         dipderj(iii)=Ub2der(iii,j)
7048         dipj(iii,2)=b1(iii,itj1)
7049       enddo
7050       kkk=0
7051       do iii=1,2
7052         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7053         do jjj=1,2
7054           kkk=kkk+1
7055           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7056         enddo
7057       enddo
7058       do kkk=1,5
7059         do lll=1,3
7060           mmm=0
7061           do iii=1,2
7062             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7063      &        auxvec(1))
7064             do jjj=1,2
7065               mmm=mmm+1
7066               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7067             enddo
7068           enddo
7069         enddo
7070       enddo
7071       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7072       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7073       do iii=1,2
7074         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7075       enddo
7076       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7077       do iii=1,2
7078         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7079       enddo
7080       return
7081       end
7082 #endif
7083 C---------------------------------------------------------------------------
7084       subroutine calc_eello(i,j,k,l,jj,kk)
7085 C
7086 C This subroutine computes matrices and vectors needed to calculate
7087 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7088 C
7089       implicit real*8 (a-h,o-z)
7090       include 'DIMENSIONS'
7091       include 'COMMON.IOUNITS'
7092       include 'COMMON.CHAIN'
7093       include 'COMMON.DERIV'
7094       include 'COMMON.INTERACT'
7095       include 'COMMON.CONTACTS'
7096       include 'COMMON.TORSION'
7097       include 'COMMON.VAR'
7098       include 'COMMON.GEO'
7099       include 'COMMON.FFIELD'
7100       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7101      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7102       logical lprn
7103       common /kutas/ lprn
7104 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7105 cd     & ' jj=',jj,' kk=',kk
7106 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7107 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7108 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7109       do iii=1,2
7110         do jjj=1,2
7111           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7112           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7113         enddo
7114       enddo
7115       call transpose2(aa1(1,1),aa1t(1,1))
7116       call transpose2(aa2(1,1),aa2t(1,1))
7117       do kkk=1,5
7118         do lll=1,3
7119           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7120      &      aa1tder(1,1,lll,kkk))
7121           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7122      &      aa2tder(1,1,lll,kkk))
7123         enddo
7124       enddo
7125       if (l.eq.j+1) then
7126 C parallel orientation of the two CA-CA-CA frames.
7127         if (i.gt.1) then
7128           iti=itortyp(itype(i))
7129         else
7130           iti=ntortyp+1
7131         endif
7132         itk1=itortyp(itype(k+1))
7133         itj=itortyp(itype(j))
7134         if (l.lt.nres-1) then
7135           itl1=itortyp(itype(l+1))
7136         else
7137           itl1=ntortyp+1
7138         endif
7139 C A1 kernel(j+1) A2T
7140 cd        do iii=1,2
7141 cd          write (iout,'(3f10.5,5x,3f10.5)')
7142 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7143 cd        enddo
7144         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7145      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7146      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7147 C Following matrices are needed only for 6-th order cumulants
7148         IF (wcorr6.gt.0.0d0) THEN
7149         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7150      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7151      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7152         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7153      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7154      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7155      &   ADtEAderx(1,1,1,1,1,1))
7156         lprn=.false.
7157         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7158      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7159      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7160      &   ADtEA1derx(1,1,1,1,1,1))
7161         ENDIF
7162 C End 6-th order cumulants
7163 cd        lprn=.false.
7164 cd        if (lprn) then
7165 cd        write (2,*) 'In calc_eello6'
7166 cd        do iii=1,2
7167 cd          write (2,*) 'iii=',iii
7168 cd          do kkk=1,5
7169 cd            write (2,*) 'kkk=',kkk
7170 cd            do jjj=1,2
7171 cd              write (2,'(3(2f10.5),5x)')
7172 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7173 cd            enddo
7174 cd          enddo
7175 cd        enddo
7176 cd        endif
7177         call transpose2(EUgder(1,1,k),auxmat(1,1))
7178         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7179         call transpose2(EUg(1,1,k),auxmat(1,1))
7180         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7181         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7182         do iii=1,2
7183           do kkk=1,5
7184             do lll=1,3
7185               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7186      &          EAEAderx(1,1,lll,kkk,iii,1))
7187             enddo
7188           enddo
7189         enddo
7190 C A1T kernel(i+1) A2
7191         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7192      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7193      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7194 C Following matrices are needed only for 6-th order cumulants
7195         IF (wcorr6.gt.0.0d0) THEN
7196         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7197      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7198      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7199         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7200      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7201      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7202      &   ADtEAderx(1,1,1,1,1,2))
7203         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7204      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7205      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7206      &   ADtEA1derx(1,1,1,1,1,2))
7207         ENDIF
7208 C End 6-th order cumulants
7209         call transpose2(EUgder(1,1,l),auxmat(1,1))
7210         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7211         call transpose2(EUg(1,1,l),auxmat(1,1))
7212         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7213         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7214         do iii=1,2
7215           do kkk=1,5
7216             do lll=1,3
7217               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7218      &          EAEAderx(1,1,lll,kkk,iii,2))
7219             enddo
7220           enddo
7221         enddo
7222 C AEAb1 and AEAb2
7223 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7224 C They are needed only when the fifth- or the sixth-order cumulants are
7225 C indluded.
7226         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7227         call transpose2(AEA(1,1,1),auxmat(1,1))
7228         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7229         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7230         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7231         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7232         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7233         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7234         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7235         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7236         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7237         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7238         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7239         call transpose2(AEA(1,1,2),auxmat(1,1))
7240         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7241         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7242         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7243         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7244         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7245         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7246         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7247         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7248         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7249         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7250         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7251 C Calculate the Cartesian derivatives of the vectors.
7252         do iii=1,2
7253           do kkk=1,5
7254             do lll=1,3
7255               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7256               call matvec2(auxmat(1,1),b1(1,iti),
7257      &          AEAb1derx(1,lll,kkk,iii,1,1))
7258               call matvec2(auxmat(1,1),Ub2(1,i),
7259      &          AEAb2derx(1,lll,kkk,iii,1,1))
7260               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7261      &          AEAb1derx(1,lll,kkk,iii,2,1))
7262               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7263      &          AEAb2derx(1,lll,kkk,iii,2,1))
7264               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7265               call matvec2(auxmat(1,1),b1(1,itj),
7266      &          AEAb1derx(1,lll,kkk,iii,1,2))
7267               call matvec2(auxmat(1,1),Ub2(1,j),
7268      &          AEAb2derx(1,lll,kkk,iii,1,2))
7269               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7270      &          AEAb1derx(1,lll,kkk,iii,2,2))
7271               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7272      &          AEAb2derx(1,lll,kkk,iii,2,2))
7273             enddo
7274           enddo
7275         enddo
7276         ENDIF
7277 C End vectors
7278       else
7279 C Antiparallel orientation of the two CA-CA-CA frames.
7280         if (i.gt.1) then
7281           iti=itortyp(itype(i))
7282         else
7283           iti=ntortyp+1
7284         endif
7285         itk1=itortyp(itype(k+1))
7286         itl=itortyp(itype(l))
7287         itj=itortyp(itype(j))
7288         if (j.lt.nres-1) then
7289           itj1=itortyp(itype(j+1))
7290         else
7291           itj1=ntortyp+1
7292         endif
7293 C A2 kernel(j-1)T A1T
7294         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7295      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7296      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7297 C Following matrices are needed only for 6-th order cumulants
7298         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7299      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7300         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7301      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7302      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7303         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7304      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7305      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7306      &   ADtEAderx(1,1,1,1,1,1))
7307         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7308      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7309      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7310      &   ADtEA1derx(1,1,1,1,1,1))
7311         ENDIF
7312 C End 6-th order cumulants
7313         call transpose2(EUgder(1,1,k),auxmat(1,1))
7314         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7315         call transpose2(EUg(1,1,k),auxmat(1,1))
7316         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7317         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7318         do iii=1,2
7319           do kkk=1,5
7320             do lll=1,3
7321               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7322      &          EAEAderx(1,1,lll,kkk,iii,1))
7323             enddo
7324           enddo
7325         enddo
7326 C A2T kernel(i+1)T A1
7327         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7328      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7329      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7330 C Following matrices are needed only for 6-th order cumulants
7331         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7332      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7333         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7334      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7335      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7336         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7337      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7338      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7339      &   ADtEAderx(1,1,1,1,1,2))
7340         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7341      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7342      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7343      &   ADtEA1derx(1,1,1,1,1,2))
7344         ENDIF
7345 C End 6-th order cumulants
7346         call transpose2(EUgder(1,1,j),auxmat(1,1))
7347         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7348         call transpose2(EUg(1,1,j),auxmat(1,1))
7349         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7350         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7351         do iii=1,2
7352           do kkk=1,5
7353             do lll=1,3
7354               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7355      &          EAEAderx(1,1,lll,kkk,iii,2))
7356             enddo
7357           enddo
7358         enddo
7359 C AEAb1 and AEAb2
7360 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7361 C They are needed only when the fifth- or the sixth-order cumulants are
7362 C indluded.
7363         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7364      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7365         call transpose2(AEA(1,1,1),auxmat(1,1))
7366         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7367         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7368         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7369         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7370         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7371         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7372         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7373         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7374         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7375         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7376         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7377         call transpose2(AEA(1,1,2),auxmat(1,1))
7378         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7379         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7380         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7381         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7382         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7383         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7384         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7385         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7386         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7387         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7388         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7389 C Calculate the Cartesian derivatives of the vectors.
7390         do iii=1,2
7391           do kkk=1,5
7392             do lll=1,3
7393               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7394               call matvec2(auxmat(1,1),b1(1,iti),
7395      &          AEAb1derx(1,lll,kkk,iii,1,1))
7396               call matvec2(auxmat(1,1),Ub2(1,i),
7397      &          AEAb2derx(1,lll,kkk,iii,1,1))
7398               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7399      &          AEAb1derx(1,lll,kkk,iii,2,1))
7400               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7401      &          AEAb2derx(1,lll,kkk,iii,2,1))
7402               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7403               call matvec2(auxmat(1,1),b1(1,itl),
7404      &          AEAb1derx(1,lll,kkk,iii,1,2))
7405               call matvec2(auxmat(1,1),Ub2(1,l),
7406      &          AEAb2derx(1,lll,kkk,iii,1,2))
7407               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7408      &          AEAb1derx(1,lll,kkk,iii,2,2))
7409               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7410      &          AEAb2derx(1,lll,kkk,iii,2,2))
7411             enddo
7412           enddo
7413         enddo
7414         ENDIF
7415 C End vectors
7416       endif
7417       return
7418       end
7419 C---------------------------------------------------------------------------
7420       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7421      &  KK,KKderg,AKA,AKAderg,AKAderx)
7422       implicit none
7423       integer nderg
7424       logical transp
7425       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7426      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7427      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7428       integer iii,kkk,lll
7429       integer jjj,mmm
7430       logical lprn
7431       common /kutas/ lprn
7432       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7433       do iii=1,nderg
7434         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7435      &    AKAderg(1,1,iii))
7436       enddo
7437 cd      if (lprn) write (2,*) 'In kernel'
7438       do kkk=1,5
7439 cd        if (lprn) write (2,*) 'kkk=',kkk
7440         do lll=1,3
7441           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7442      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7443 cd          if (lprn) then
7444 cd            write (2,*) 'lll=',lll
7445 cd            write (2,*) 'iii=1'
7446 cd            do jjj=1,2
7447 cd              write (2,'(3(2f10.5),5x)')
7448 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7449 cd            enddo
7450 cd          endif
7451           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7452      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7453 cd          if (lprn) then
7454 cd            write (2,*) 'lll=',lll
7455 cd            write (2,*) 'iii=2'
7456 cd            do jjj=1,2
7457 cd              write (2,'(3(2f10.5),5x)')
7458 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7459 cd            enddo
7460 cd          endif
7461         enddo
7462       enddo
7463       return
7464       end
7465 C---------------------------------------------------------------------------
7466       double precision function eello4(i,j,k,l,jj,kk)
7467       implicit real*8 (a-h,o-z)
7468       include 'DIMENSIONS'
7469       include 'COMMON.IOUNITS'
7470       include 'COMMON.CHAIN'
7471       include 'COMMON.DERIV'
7472       include 'COMMON.INTERACT'
7473       include 'COMMON.CONTACTS'
7474       include 'COMMON.TORSION'
7475       include 'COMMON.VAR'
7476       include 'COMMON.GEO'
7477       double precision pizda(2,2),ggg1(3),ggg2(3)
7478 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7479 cd        eello4=0.0d0
7480 cd        return
7481 cd      endif
7482 cd      print *,'eello4:',i,j,k,l,jj,kk
7483 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7484 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7485 cold      eij=facont_hb(jj,i)
7486 cold      ekl=facont_hb(kk,k)
7487 cold      ekont=eij*ekl
7488       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7489 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7490       gcorr_loc(k-1)=gcorr_loc(k-1)
7491      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7492       if (l.eq.j+1) then
7493         gcorr_loc(l-1)=gcorr_loc(l-1)
7494      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7495       else
7496         gcorr_loc(j-1)=gcorr_loc(j-1)
7497      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7498       endif
7499       do iii=1,2
7500         do kkk=1,5
7501           do lll=1,3
7502             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7503      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7504 cd            derx(lll,kkk,iii)=0.0d0
7505           enddo
7506         enddo
7507       enddo
7508 cd      gcorr_loc(l-1)=0.0d0
7509 cd      gcorr_loc(j-1)=0.0d0
7510 cd      gcorr_loc(k-1)=0.0d0
7511 cd      eel4=1.0d0
7512 cd      write (iout,*)'Contacts have occurred for peptide groups',
7513 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7514 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7515       if (j.lt.nres-1) then
7516         j1=j+1
7517         j2=j-1
7518       else
7519         j1=j-1
7520         j2=j-2
7521       endif
7522       if (l.lt.nres-1) then
7523         l1=l+1
7524         l2=l-1
7525       else
7526         l1=l-1
7527         l2=l-2
7528       endif
7529       do ll=1,3
7530 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7531 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7532         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7533         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7534 cgrad        ghalf=0.5d0*ggg1(ll)
7535         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7536         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7537         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7538         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7539         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7540         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7541 cgrad        ghalf=0.5d0*ggg2(ll)
7542         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7543         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7544         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7545         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7546         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7547         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7548       enddo
7549 cgrad      do m=i+1,j-1
7550 cgrad        do ll=1,3
7551 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7552 cgrad        enddo
7553 cgrad      enddo
7554 cgrad      do m=k+1,l-1
7555 cgrad        do ll=1,3
7556 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7557 cgrad        enddo
7558 cgrad      enddo
7559 cgrad      do m=i+2,j2
7560 cgrad        do ll=1,3
7561 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7562 cgrad        enddo
7563 cgrad      enddo
7564 cgrad      do m=k+2,l2
7565 cgrad        do ll=1,3
7566 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7567 cgrad        enddo
7568 cgrad      enddo
7569 cd      do iii=1,nres-3
7570 cd        write (2,*) iii,gcorr_loc(iii)
7571 cd      enddo
7572       eello4=ekont*eel4
7573 cd      write (2,*) 'ekont',ekont
7574 cd      write (iout,*) 'eello4',ekont*eel4
7575       return
7576       end
7577 C---------------------------------------------------------------------------
7578       double precision function eello5(i,j,k,l,jj,kk)
7579       implicit real*8 (a-h,o-z)
7580       include 'DIMENSIONS'
7581       include 'COMMON.IOUNITS'
7582       include 'COMMON.CHAIN'
7583       include 'COMMON.DERIV'
7584       include 'COMMON.INTERACT'
7585       include 'COMMON.CONTACTS'
7586       include 'COMMON.TORSION'
7587       include 'COMMON.VAR'
7588       include 'COMMON.GEO'
7589       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7590       double precision ggg1(3),ggg2(3)
7591 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7592 C                                                                              C
7593 C                            Parallel chains                                   C
7594 C                                                                              C
7595 C          o             o                   o             o                   C
7596 C         /l\           / \             \   / \           / \   /              C
7597 C        /   \         /   \             \ /   \         /   \ /               C
7598 C       j| o |l1       | o |              o| o |         | o |o                C
7599 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7600 C      \i/   \         /   \ /             /   \         /   \                 C
7601 C       o    k1             o                                                  C
7602 C         (I)          (II)                (III)          (IV)                 C
7603 C                                                                              C
7604 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7605 C                                                                              C
7606 C                            Antiparallel chains                               C
7607 C                                                                              C
7608 C          o             o                   o             o                   C
7609 C         /j\           / \             \   / \           / \   /              C
7610 C        /   \         /   \             \ /   \         /   \ /               C
7611 C      j1| o |l        | o |              o| o |         | o |o                C
7612 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7613 C      \i/   \         /   \ /             /   \         /   \                 C
7614 C       o     k1            o                                                  C
7615 C         (I)          (II)                (III)          (IV)                 C
7616 C                                                                              C
7617 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7618 C                                                                              C
7619 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7620 C                                                                              C
7621 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7622 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7623 cd        eello5=0.0d0
7624 cd        return
7625 cd      endif
7626 cd      write (iout,*)
7627 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7628 cd     &   ' and',k,l
7629       itk=itortyp(itype(k))
7630       itl=itortyp(itype(l))
7631       itj=itortyp(itype(j))
7632       eello5_1=0.0d0
7633       eello5_2=0.0d0
7634       eello5_3=0.0d0
7635       eello5_4=0.0d0
7636 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7637 cd     &   eel5_3_num,eel5_4_num)
7638       do iii=1,2
7639         do kkk=1,5
7640           do lll=1,3
7641             derx(lll,kkk,iii)=0.0d0
7642           enddo
7643         enddo
7644       enddo
7645 cd      eij=facont_hb(jj,i)
7646 cd      ekl=facont_hb(kk,k)
7647 cd      ekont=eij*ekl
7648 cd      write (iout,*)'Contacts have occurred for peptide groups',
7649 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7650 cd      goto 1111
7651 C Contribution from the graph I.
7652 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7653 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7654       call transpose2(EUg(1,1,k),auxmat(1,1))
7655       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7656       vv(1)=pizda(1,1)-pizda(2,2)
7657       vv(2)=pizda(1,2)+pizda(2,1)
7658       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7659      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7660 C Explicit gradient in virtual-dihedral angles.
7661       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7662      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7663      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7664       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7665       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7666       vv(1)=pizda(1,1)-pizda(2,2)
7667       vv(2)=pizda(1,2)+pizda(2,1)
7668       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7669      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7670      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7671       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7672       vv(1)=pizda(1,1)-pizda(2,2)
7673       vv(2)=pizda(1,2)+pizda(2,1)
7674       if (l.eq.j+1) then
7675         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7676      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7677      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7678       else
7679         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7680      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7681      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7682       endif
7683 C Cartesian gradient
7684       do iii=1,2
7685         do kkk=1,5
7686           do lll=1,3
7687             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7688      &        pizda(1,1))
7689             vv(1)=pizda(1,1)-pizda(2,2)
7690             vv(2)=pizda(1,2)+pizda(2,1)
7691             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7692      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7693      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7694           enddo
7695         enddo
7696       enddo
7697 c      goto 1112
7698 c1111  continue
7699 C Contribution from graph II
7700       call transpose2(EE(1,1,itk),auxmat(1,1))
7701       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7702       vv(1)=pizda(1,1)+pizda(2,2)
7703       vv(2)=pizda(2,1)-pizda(1,2)
7704       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7705      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7706 C Explicit gradient in virtual-dihedral angles.
7707       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7708      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7709       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7710       vv(1)=pizda(1,1)+pizda(2,2)
7711       vv(2)=pizda(2,1)-pizda(1,2)
7712       if (l.eq.j+1) then
7713         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7714      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7715      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7716       else
7717         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7718      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7719      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7720       endif
7721 C Cartesian gradient
7722       do iii=1,2
7723         do kkk=1,5
7724           do lll=1,3
7725             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7726      &        pizda(1,1))
7727             vv(1)=pizda(1,1)+pizda(2,2)
7728             vv(2)=pizda(2,1)-pizda(1,2)
7729             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7730      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7731      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7732           enddo
7733         enddo
7734       enddo
7735 cd      goto 1112
7736 cd1111  continue
7737       if (l.eq.j+1) then
7738 cd        goto 1110
7739 C Parallel orientation
7740 C Contribution from graph III
7741         call transpose2(EUg(1,1,l),auxmat(1,1))
7742         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7743         vv(1)=pizda(1,1)-pizda(2,2)
7744         vv(2)=pizda(1,2)+pizda(2,1)
7745         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7746      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7747 C Explicit gradient in virtual-dihedral angles.
7748         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7749      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7750      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7751         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7752         vv(1)=pizda(1,1)-pizda(2,2)
7753         vv(2)=pizda(1,2)+pizda(2,1)
7754         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7755      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7756      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7757         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7758         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7759         vv(1)=pizda(1,1)-pizda(2,2)
7760         vv(2)=pizda(1,2)+pizda(2,1)
7761         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7762      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7763      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7764 C Cartesian gradient
7765         do iii=1,2
7766           do kkk=1,5
7767             do lll=1,3
7768               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7769      &          pizda(1,1))
7770               vv(1)=pizda(1,1)-pizda(2,2)
7771               vv(2)=pizda(1,2)+pizda(2,1)
7772               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7773      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7774      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7775             enddo
7776           enddo
7777         enddo
7778 cd        goto 1112
7779 C Contribution from graph IV
7780 cd1110    continue
7781         call transpose2(EE(1,1,itl),auxmat(1,1))
7782         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7783         vv(1)=pizda(1,1)+pizda(2,2)
7784         vv(2)=pizda(2,1)-pizda(1,2)
7785         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7786      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7787 C Explicit gradient in virtual-dihedral angles.
7788         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7789      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7790         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7791         vv(1)=pizda(1,1)+pizda(2,2)
7792         vv(2)=pizda(2,1)-pizda(1,2)
7793         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7794      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7795      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7796 C Cartesian gradient
7797         do iii=1,2
7798           do kkk=1,5
7799             do lll=1,3
7800               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7801      &          pizda(1,1))
7802               vv(1)=pizda(1,1)+pizda(2,2)
7803               vv(2)=pizda(2,1)-pizda(1,2)
7804               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7805      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7806      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7807             enddo
7808           enddo
7809         enddo
7810       else
7811 C Antiparallel orientation
7812 C Contribution from graph III
7813 c        goto 1110
7814         call transpose2(EUg(1,1,j),auxmat(1,1))
7815         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7816         vv(1)=pizda(1,1)-pizda(2,2)
7817         vv(2)=pizda(1,2)+pizda(2,1)
7818         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7819      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7820 C Explicit gradient in virtual-dihedral angles.
7821         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7822      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7823      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7824         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7825         vv(1)=pizda(1,1)-pizda(2,2)
7826         vv(2)=pizda(1,2)+pizda(2,1)
7827         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7828      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7829      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7830         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7831         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7832         vv(1)=pizda(1,1)-pizda(2,2)
7833         vv(2)=pizda(1,2)+pizda(2,1)
7834         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7835      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7836      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7837 C Cartesian gradient
7838         do iii=1,2
7839           do kkk=1,5
7840             do lll=1,3
7841               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7842      &          pizda(1,1))
7843               vv(1)=pizda(1,1)-pizda(2,2)
7844               vv(2)=pizda(1,2)+pizda(2,1)
7845               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7846      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7847      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7848             enddo
7849           enddo
7850         enddo
7851 cd        goto 1112
7852 C Contribution from graph IV
7853 1110    continue
7854         call transpose2(EE(1,1,itj),auxmat(1,1))
7855         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7856         vv(1)=pizda(1,1)+pizda(2,2)
7857         vv(2)=pizda(2,1)-pizda(1,2)
7858         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7859      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7860 C Explicit gradient in virtual-dihedral angles.
7861         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7862      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7863         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7864         vv(1)=pizda(1,1)+pizda(2,2)
7865         vv(2)=pizda(2,1)-pizda(1,2)
7866         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7867      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7868      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7869 C Cartesian gradient
7870         do iii=1,2
7871           do kkk=1,5
7872             do lll=1,3
7873               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7874      &          pizda(1,1))
7875               vv(1)=pizda(1,1)+pizda(2,2)
7876               vv(2)=pizda(2,1)-pizda(1,2)
7877               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7878      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7879      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7880             enddo
7881           enddo
7882         enddo
7883       endif
7884 1112  continue
7885       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7886 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7887 cd        write (2,*) 'ijkl',i,j,k,l
7888 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7889 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7890 cd      endif
7891 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7892 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7893 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7894 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7895       if (j.lt.nres-1) then
7896         j1=j+1
7897         j2=j-1
7898       else
7899         j1=j-1
7900         j2=j-2
7901       endif
7902       if (l.lt.nres-1) then
7903         l1=l+1
7904         l2=l-1
7905       else
7906         l1=l-1
7907         l2=l-2
7908       endif
7909 cd      eij=1.0d0
7910 cd      ekl=1.0d0
7911 cd      ekont=1.0d0
7912 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7913 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7914 C        summed up outside the subrouine as for the other subroutines
7915 C        handling long-range interactions. The old code is commented out
7916 C        with "cgrad" to keep track of changes.
7917       do ll=1,3
7918 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7919 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7920         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7921         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7922 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7923 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7924 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7925 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7926 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7927 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7928 c     &   gradcorr5ij,
7929 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7930 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7931 cgrad        ghalf=0.5d0*ggg1(ll)
7932 cd        ghalf=0.0d0
7933         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7934         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7935         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7936         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7937         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7938         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7939 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7940 cgrad        ghalf=0.5d0*ggg2(ll)
7941 cd        ghalf=0.0d0
7942         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7943         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7944         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7945         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7946         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7947         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7948       enddo
7949 cd      goto 1112
7950 cgrad      do m=i+1,j-1
7951 cgrad        do ll=1,3
7952 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7953 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7954 cgrad        enddo
7955 cgrad      enddo
7956 cgrad      do m=k+1,l-1
7957 cgrad        do ll=1,3
7958 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7959 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7960 cgrad        enddo
7961 cgrad      enddo
7962 c1112  continue
7963 cgrad      do m=i+2,j2
7964 cgrad        do ll=1,3
7965 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7966 cgrad        enddo
7967 cgrad      enddo
7968 cgrad      do m=k+2,l2
7969 cgrad        do ll=1,3
7970 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7971 cgrad        enddo
7972 cgrad      enddo
7973 cd      do iii=1,nres-3
7974 cd        write (2,*) iii,g_corr5_loc(iii)
7975 cd      enddo
7976       eello5=ekont*eel5
7977 cd      write (2,*) 'ekont',ekont
7978 cd      write (iout,*) 'eello5',ekont*eel5
7979       return
7980       end
7981 c--------------------------------------------------------------------------
7982       double precision function eello6(i,j,k,l,jj,kk)
7983       implicit real*8 (a-h,o-z)
7984       include 'DIMENSIONS'
7985       include 'COMMON.IOUNITS'
7986       include 'COMMON.CHAIN'
7987       include 'COMMON.DERIV'
7988       include 'COMMON.INTERACT'
7989       include 'COMMON.CONTACTS'
7990       include 'COMMON.TORSION'
7991       include 'COMMON.VAR'
7992       include 'COMMON.GEO'
7993       include 'COMMON.FFIELD'
7994       double precision ggg1(3),ggg2(3)
7995 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7996 cd        eello6=0.0d0
7997 cd        return
7998 cd      endif
7999 cd      write (iout,*)
8000 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8001 cd     &   ' and',k,l
8002       eello6_1=0.0d0
8003       eello6_2=0.0d0
8004       eello6_3=0.0d0
8005       eello6_4=0.0d0
8006       eello6_5=0.0d0
8007       eello6_6=0.0d0
8008 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8009 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8010       do iii=1,2
8011         do kkk=1,5
8012           do lll=1,3
8013             derx(lll,kkk,iii)=0.0d0
8014           enddo
8015         enddo
8016       enddo
8017 cd      eij=facont_hb(jj,i)
8018 cd      ekl=facont_hb(kk,k)
8019 cd      ekont=eij*ekl
8020 cd      eij=1.0d0
8021 cd      ekl=1.0d0
8022 cd      ekont=1.0d0
8023       if (l.eq.j+1) then
8024         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8025         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8026         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8027         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8028         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8029         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8030       else
8031         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8032         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8033         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8034         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8035         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8036           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8037         else
8038           eello6_5=0.0d0
8039         endif
8040         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8041       endif
8042 C If turn contributions are considered, they will be handled separately.
8043       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8044 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8045 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8046 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8047 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8048 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8049 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8050 cd      goto 1112
8051       if (j.lt.nres-1) then
8052         j1=j+1
8053         j2=j-1
8054       else
8055         j1=j-1
8056         j2=j-2
8057       endif
8058       if (l.lt.nres-1) then
8059         l1=l+1
8060         l2=l-1
8061       else
8062         l1=l-1
8063         l2=l-2
8064       endif
8065       do ll=1,3
8066 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8067 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8068 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8069 cgrad        ghalf=0.5d0*ggg1(ll)
8070 cd        ghalf=0.0d0
8071         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8072         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8073         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8074         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8075         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8076         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8077         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8078         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8079 cgrad        ghalf=0.5d0*ggg2(ll)
8080 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8081 cd        ghalf=0.0d0
8082         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8083         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8084         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8085         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8086         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8087         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8088       enddo
8089 cd      goto 1112
8090 cgrad      do m=i+1,j-1
8091 cgrad        do ll=1,3
8092 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8093 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8094 cgrad        enddo
8095 cgrad      enddo
8096 cgrad      do m=k+1,l-1
8097 cgrad        do ll=1,3
8098 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8099 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8100 cgrad        enddo
8101 cgrad      enddo
8102 cgrad1112  continue
8103 cgrad      do m=i+2,j2
8104 cgrad        do ll=1,3
8105 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8106 cgrad        enddo
8107 cgrad      enddo
8108 cgrad      do m=k+2,l2
8109 cgrad        do ll=1,3
8110 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8111 cgrad        enddo
8112 cgrad      enddo
8113 cd      do iii=1,nres-3
8114 cd        write (2,*) iii,g_corr6_loc(iii)
8115 cd      enddo
8116       eello6=ekont*eel6
8117 cd      write (2,*) 'ekont',ekont
8118 cd      write (iout,*) 'eello6',ekont*eel6
8119       return
8120       end
8121 c--------------------------------------------------------------------------
8122       double precision function eello6_graph1(i,j,k,l,imat,swap)
8123       implicit real*8 (a-h,o-z)
8124       include 'DIMENSIONS'
8125       include 'COMMON.IOUNITS'
8126       include 'COMMON.CHAIN'
8127       include 'COMMON.DERIV'
8128       include 'COMMON.INTERACT'
8129       include 'COMMON.CONTACTS'
8130       include 'COMMON.TORSION'
8131       include 'COMMON.VAR'
8132       include 'COMMON.GEO'
8133       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8134       logical swap
8135       logical lprn
8136       common /kutas/ lprn
8137 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8138 C
8139 C      Parallel       Antiparallel
8140 C
8141 C          o             o
8142 C         /l\           /j\
8143 C        /   \         /   \
8144 C       /| o |         | o |\
8145 C     \ j|/k\|  /   \  |/k\|l /
8146 C      \ /   \ /     \ /   \ /
8147 C       o     o       o     o
8148 C       i             i
8149 C
8150 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8151       itk=itortyp(itype(k))
8152       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8153       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8154       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8155       call transpose2(EUgC(1,1,k),auxmat(1,1))
8156       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8157       vv1(1)=pizda1(1,1)-pizda1(2,2)
8158       vv1(2)=pizda1(1,2)+pizda1(2,1)
8159       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8160       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8161       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8162       s5=scalar2(vv(1),Dtobr2(1,i))
8163 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8164       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8165       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8166      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8167      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8168      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8169      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8170      & +scalar2(vv(1),Dtobr2der(1,i)))
8171       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8172       vv1(1)=pizda1(1,1)-pizda1(2,2)
8173       vv1(2)=pizda1(1,2)+pizda1(2,1)
8174       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8175       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8176       if (l.eq.j+1) then
8177         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8178      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8179      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8180      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8181      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8182       else
8183         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8184      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8185      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8186      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8187      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8188       endif
8189       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8190       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8191       vv1(1)=pizda1(1,1)-pizda1(2,2)
8192       vv1(2)=pizda1(1,2)+pizda1(2,1)
8193       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8194      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8195      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8196      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8197       do iii=1,2
8198         if (swap) then
8199           ind=3-iii
8200         else
8201           ind=iii
8202         endif
8203         do kkk=1,5
8204           do lll=1,3
8205             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8206             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8207             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8208             call transpose2(EUgC(1,1,k),auxmat(1,1))
8209             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8210      &        pizda1(1,1))
8211             vv1(1)=pizda1(1,1)-pizda1(2,2)
8212             vv1(2)=pizda1(1,2)+pizda1(2,1)
8213             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8214             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8215      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8216             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8217      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8218             s5=scalar2(vv(1),Dtobr2(1,i))
8219             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8220           enddo
8221         enddo
8222       enddo
8223       return
8224       end
8225 c----------------------------------------------------------------------------
8226       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8227       implicit real*8 (a-h,o-z)
8228       include 'DIMENSIONS'
8229       include 'COMMON.IOUNITS'
8230       include 'COMMON.CHAIN'
8231       include 'COMMON.DERIV'
8232       include 'COMMON.INTERACT'
8233       include 'COMMON.CONTACTS'
8234       include 'COMMON.TORSION'
8235       include 'COMMON.VAR'
8236       include 'COMMON.GEO'
8237       logical swap
8238       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8239      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8240       logical lprn
8241       common /kutas/ lprn
8242 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8243 C                                                                              C
8244 C      Parallel       Antiparallel                                             C
8245 C                                                                              C
8246 C          o             o                                                     C
8247 C     \   /l\           /j\   /                                                C
8248 C      \ /   \         /   \ /                                                 C
8249 C       o| o |         | o |o                                                  C
8250 C     \ j|/k\|      \  |/k\|l                                                  C
8251 C      \ /   \       \ /   \                                                   C
8252 C       o             o                                                        C
8253 C       i             i                                                        C
8254 C                                                                              C
8255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8256 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8257 C AL 7/4/01 s1 would occur in the sixth-order moment,
8258 C           but not in a cluster cumulant
8259 #ifdef MOMENT
8260       s1=dip(1,jj,i)*dip(1,kk,k)
8261 #endif
8262       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8263       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8264       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8265       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8266       call transpose2(EUg(1,1,k),auxmat(1,1))
8267       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8268       vv(1)=pizda(1,1)-pizda(2,2)
8269       vv(2)=pizda(1,2)+pizda(2,1)
8270       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8271 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8272 #ifdef MOMENT
8273       eello6_graph2=-(s1+s2+s3+s4)
8274 #else
8275       eello6_graph2=-(s2+s3+s4)
8276 #endif
8277 c      eello6_graph2=-s3
8278 C Derivatives in gamma(i-1)
8279       if (i.gt.1) then
8280 #ifdef MOMENT
8281         s1=dipderg(1,jj,i)*dip(1,kk,k)
8282 #endif
8283         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8284         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8285         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8286         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8287 #ifdef MOMENT
8288         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8289 #else
8290         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8291 #endif
8292 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8293       endif
8294 C Derivatives in gamma(k-1)
8295 #ifdef MOMENT
8296       s1=dip(1,jj,i)*dipderg(1,kk,k)
8297 #endif
8298       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8299       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8300       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8301       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8302       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8303       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8304       vv(1)=pizda(1,1)-pizda(2,2)
8305       vv(2)=pizda(1,2)+pizda(2,1)
8306       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8307 #ifdef MOMENT
8308       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8309 #else
8310       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8311 #endif
8312 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8313 C Derivatives in gamma(j-1) or gamma(l-1)
8314       if (j.gt.1) then
8315 #ifdef MOMENT
8316         s1=dipderg(3,jj,i)*dip(1,kk,k)
8317 #endif
8318         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8319         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8320         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8321         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8322         vv(1)=pizda(1,1)-pizda(2,2)
8323         vv(2)=pizda(1,2)+pizda(2,1)
8324         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8325 #ifdef MOMENT
8326         if (swap) then
8327           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8328         else
8329           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8330         endif
8331 #endif
8332         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8333 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8334       endif
8335 C Derivatives in gamma(l-1) or gamma(j-1)
8336       if (l.gt.1) then
8337 #ifdef MOMENT
8338         s1=dip(1,jj,i)*dipderg(3,kk,k)
8339 #endif
8340         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8341         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8342         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8343         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8344         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8345         vv(1)=pizda(1,1)-pizda(2,2)
8346         vv(2)=pizda(1,2)+pizda(2,1)
8347         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8348 #ifdef MOMENT
8349         if (swap) then
8350           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8351         else
8352           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8353         endif
8354 #endif
8355         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8356 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8357       endif
8358 C Cartesian derivatives.
8359       if (lprn) then
8360         write (2,*) 'In eello6_graph2'
8361         do iii=1,2
8362           write (2,*) 'iii=',iii
8363           do kkk=1,5
8364             write (2,*) 'kkk=',kkk
8365             do jjj=1,2
8366               write (2,'(3(2f10.5),5x)')
8367      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8368             enddo
8369           enddo
8370         enddo
8371       endif
8372       do iii=1,2
8373         do kkk=1,5
8374           do lll=1,3
8375 #ifdef MOMENT
8376             if (iii.eq.1) then
8377               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8378             else
8379               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8380             endif
8381 #endif
8382             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8383      &        auxvec(1))
8384             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8385             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8386      &        auxvec(1))
8387             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8388             call transpose2(EUg(1,1,k),auxmat(1,1))
8389             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8390      &        pizda(1,1))
8391             vv(1)=pizda(1,1)-pizda(2,2)
8392             vv(2)=pizda(1,2)+pizda(2,1)
8393             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8394 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8395 #ifdef MOMENT
8396             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8397 #else
8398             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8399 #endif
8400             if (swap) then
8401               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8402             else
8403               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8404             endif
8405           enddo
8406         enddo
8407       enddo
8408       return
8409       end
8410 c----------------------------------------------------------------------------
8411       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8412       implicit real*8 (a-h,o-z)
8413       include 'DIMENSIONS'
8414       include 'COMMON.IOUNITS'
8415       include 'COMMON.CHAIN'
8416       include 'COMMON.DERIV'
8417       include 'COMMON.INTERACT'
8418       include 'COMMON.CONTACTS'
8419       include 'COMMON.TORSION'
8420       include 'COMMON.VAR'
8421       include 'COMMON.GEO'
8422       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8423       logical swap
8424 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8425 C                                                                              C
8426 C      Parallel       Antiparallel                                             C
8427 C                                                                              C
8428 C          o             o                                                     C
8429 C         /l\   /   \   /j\                                                    C
8430 C        /   \ /     \ /   \                                                   C
8431 C       /| o |o       o| o |\                                                  C
8432 C       j|/k\|  /      |/k\|l /                                                C
8433 C        /   \ /       /   \ /                                                 C
8434 C       /     o       /     o                                                  C
8435 C       i             i                                                        C
8436 C                                                                              C
8437 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8438 C
8439 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8440 C           energy moment and not to the cluster cumulant.
8441       iti=itortyp(itype(i))
8442       if (j.lt.nres-1) then
8443         itj1=itortyp(itype(j+1))
8444       else
8445         itj1=ntortyp+1
8446       endif
8447       itk=itortyp(itype(k))
8448       itk1=itortyp(itype(k+1))
8449       if (l.lt.nres-1) then
8450         itl1=itortyp(itype(l+1))
8451       else
8452         itl1=ntortyp+1
8453       endif
8454 #ifdef MOMENT
8455       s1=dip(4,jj,i)*dip(4,kk,k)
8456 #endif
8457       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8458       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8459       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8460       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8461       call transpose2(EE(1,1,itk),auxmat(1,1))
8462       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8463       vv(1)=pizda(1,1)+pizda(2,2)
8464       vv(2)=pizda(2,1)-pizda(1,2)
8465       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8466 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8467 cd     & "sum",-(s2+s3+s4)
8468 #ifdef MOMENT
8469       eello6_graph3=-(s1+s2+s3+s4)
8470 #else
8471       eello6_graph3=-(s2+s3+s4)
8472 #endif
8473 c      eello6_graph3=-s4
8474 C Derivatives in gamma(k-1)
8475       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8476       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8477       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8478       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8479 C Derivatives in gamma(l-1)
8480       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8481       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8482       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8483       vv(1)=pizda(1,1)+pizda(2,2)
8484       vv(2)=pizda(2,1)-pizda(1,2)
8485       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8486       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8487 C Cartesian derivatives.
8488       do iii=1,2
8489         do kkk=1,5
8490           do lll=1,3
8491 #ifdef MOMENT
8492             if (iii.eq.1) then
8493               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8494             else
8495               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8496             endif
8497 #endif
8498             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8499      &        auxvec(1))
8500             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8501             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8502      &        auxvec(1))
8503             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8504             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8505      &        pizda(1,1))
8506             vv(1)=pizda(1,1)+pizda(2,2)
8507             vv(2)=pizda(2,1)-pizda(1,2)
8508             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8509 #ifdef MOMENT
8510             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8511 #else
8512             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8513 #endif
8514             if (swap) then
8515               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8516             else
8517               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8518             endif
8519 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8520           enddo
8521         enddo
8522       enddo
8523       return
8524       end
8525 c----------------------------------------------------------------------------
8526       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8527       implicit real*8 (a-h,o-z)
8528       include 'DIMENSIONS'
8529       include 'COMMON.IOUNITS'
8530       include 'COMMON.CHAIN'
8531       include 'COMMON.DERIV'
8532       include 'COMMON.INTERACT'
8533       include 'COMMON.CONTACTS'
8534       include 'COMMON.TORSION'
8535       include 'COMMON.VAR'
8536       include 'COMMON.GEO'
8537       include 'COMMON.FFIELD'
8538       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8539      & auxvec1(2),auxmat1(2,2)
8540       logical swap
8541 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8542 C                                                                              C
8543 C      Parallel       Antiparallel                                             C
8544 C                                                                              C
8545 C          o             o                                                     C
8546 C         /l\   /   \   /j\                                                    C
8547 C        /   \ /     \ /   \                                                   C
8548 C       /| o |o       o| o |\                                                  C
8549 C     \ j|/k\|      \  |/k\|l                                                  C
8550 C      \ /   \       \ /   \                                                   C
8551 C       o     \       o     \                                                  C
8552 C       i             i                                                        C
8553 C                                                                              C
8554 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8555 C
8556 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8557 C           energy moment and not to the cluster cumulant.
8558 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8559       iti=itortyp(itype(i))
8560       itj=itortyp(itype(j))
8561       if (j.lt.nres-1) then
8562         itj1=itortyp(itype(j+1))
8563       else
8564         itj1=ntortyp+1
8565       endif
8566       itk=itortyp(itype(k))
8567       if (k.lt.nres-1) then
8568         itk1=itortyp(itype(k+1))
8569       else
8570         itk1=ntortyp+1
8571       endif
8572       itl=itortyp(itype(l))
8573       if (l.lt.nres-1) then
8574         itl1=itortyp(itype(l+1))
8575       else
8576         itl1=ntortyp+1
8577       endif
8578 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8579 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8580 cd     & ' itl',itl,' itl1',itl1
8581 #ifdef MOMENT
8582       if (imat.eq.1) then
8583         s1=dip(3,jj,i)*dip(3,kk,k)
8584       else
8585         s1=dip(2,jj,j)*dip(2,kk,l)
8586       endif
8587 #endif
8588       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8589       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8590       if (j.eq.l+1) then
8591         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8592         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8593       else
8594         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8595         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8596       endif
8597       call transpose2(EUg(1,1,k),auxmat(1,1))
8598       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8599       vv(1)=pizda(1,1)-pizda(2,2)
8600       vv(2)=pizda(2,1)+pizda(1,2)
8601       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8602 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8603 #ifdef MOMENT
8604       eello6_graph4=-(s1+s2+s3+s4)
8605 #else
8606       eello6_graph4=-(s2+s3+s4)
8607 #endif
8608 C Derivatives in gamma(i-1)
8609       if (i.gt.1) then
8610 #ifdef MOMENT
8611         if (imat.eq.1) then
8612           s1=dipderg(2,jj,i)*dip(3,kk,k)
8613         else
8614           s1=dipderg(4,jj,j)*dip(2,kk,l)
8615         endif
8616 #endif
8617         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8618         if (j.eq.l+1) then
8619           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8620           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8621         else
8622           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8623           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8624         endif
8625         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8626         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8627 cd          write (2,*) 'turn6 derivatives'
8628 #ifdef MOMENT
8629           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8630 #else
8631           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8632 #endif
8633         else
8634 #ifdef MOMENT
8635           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8636 #else
8637           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8638 #endif
8639         endif
8640       endif
8641 C Derivatives in gamma(k-1)
8642 #ifdef MOMENT
8643       if (imat.eq.1) then
8644         s1=dip(3,jj,i)*dipderg(2,kk,k)
8645       else
8646         s1=dip(2,jj,j)*dipderg(4,kk,l)
8647       endif
8648 #endif
8649       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8650       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8651       if (j.eq.l+1) then
8652         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8653         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8654       else
8655         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8656         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8657       endif
8658       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8659       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8660       vv(1)=pizda(1,1)-pizda(2,2)
8661       vv(2)=pizda(2,1)+pizda(1,2)
8662       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8663       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8664 #ifdef MOMENT
8665         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8666 #else
8667         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8668 #endif
8669       else
8670 #ifdef MOMENT
8671         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8672 #else
8673         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8674 #endif
8675       endif
8676 C Derivatives in gamma(j-1) or gamma(l-1)
8677       if (l.eq.j+1 .and. l.gt.1) then
8678         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8679         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8680         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8681         vv(1)=pizda(1,1)-pizda(2,2)
8682         vv(2)=pizda(2,1)+pizda(1,2)
8683         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8684         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8685       else if (j.gt.1) then
8686         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8687         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8688         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8689         vv(1)=pizda(1,1)-pizda(2,2)
8690         vv(2)=pizda(2,1)+pizda(1,2)
8691         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8692         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8693           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8694         else
8695           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8696         endif
8697       endif
8698 C Cartesian derivatives.
8699       do iii=1,2
8700         do kkk=1,5
8701           do lll=1,3
8702 #ifdef MOMENT
8703             if (iii.eq.1) then
8704               if (imat.eq.1) then
8705                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8706               else
8707                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8708               endif
8709             else
8710               if (imat.eq.1) then
8711                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8712               else
8713                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8714               endif
8715             endif
8716 #endif
8717             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8718      &        auxvec(1))
8719             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8720             if (j.eq.l+1) then
8721               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8722      &          b1(1,itj1),auxvec(1))
8723               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8724             else
8725               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8726      &          b1(1,itl1),auxvec(1))
8727               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8728             endif
8729             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8730      &        pizda(1,1))
8731             vv(1)=pizda(1,1)-pizda(2,2)
8732             vv(2)=pizda(2,1)+pizda(1,2)
8733             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8734             if (swap) then
8735               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8736 #ifdef MOMENT
8737                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8738      &             -(s1+s2+s4)
8739 #else
8740                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8741      &             -(s2+s4)
8742 #endif
8743                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8744               else
8745 #ifdef MOMENT
8746                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8747 #else
8748                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8749 #endif
8750                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8751               endif
8752             else
8753 #ifdef MOMENT
8754               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8755 #else
8756               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8757 #endif
8758               if (l.eq.j+1) then
8759                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8760               else
8761                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8762               endif
8763             endif
8764           enddo
8765         enddo
8766       enddo
8767       return
8768       end
8769 c----------------------------------------------------------------------------
8770       double precision function eello_turn6(i,jj,kk)
8771       implicit real*8 (a-h,o-z)
8772       include 'DIMENSIONS'
8773       include 'COMMON.IOUNITS'
8774       include 'COMMON.CHAIN'
8775       include 'COMMON.DERIV'
8776       include 'COMMON.INTERACT'
8777       include 'COMMON.CONTACTS'
8778       include 'COMMON.TORSION'
8779       include 'COMMON.VAR'
8780       include 'COMMON.GEO'
8781       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8782      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8783      &  ggg1(3),ggg2(3)
8784       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8785      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8786 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8787 C           the respective energy moment and not to the cluster cumulant.
8788       s1=0.0d0
8789       s8=0.0d0
8790       s13=0.0d0
8791 c
8792       eello_turn6=0.0d0
8793       j=i+4
8794       k=i+1
8795       l=i+3
8796       iti=itortyp(itype(i))
8797       itk=itortyp(itype(k))
8798       itk1=itortyp(itype(k+1))
8799       itl=itortyp(itype(l))
8800       itj=itortyp(itype(j))
8801 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8802 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8803 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8804 cd        eello6=0.0d0
8805 cd        return
8806 cd      endif
8807 cd      write (iout,*)
8808 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8809 cd     &   ' and',k,l
8810 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8811       do iii=1,2
8812         do kkk=1,5
8813           do lll=1,3
8814             derx_turn(lll,kkk,iii)=0.0d0
8815           enddo
8816         enddo
8817       enddo
8818 cd      eij=1.0d0
8819 cd      ekl=1.0d0
8820 cd      ekont=1.0d0
8821       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8822 cd      eello6_5=0.0d0
8823 cd      write (2,*) 'eello6_5',eello6_5
8824 #ifdef MOMENT
8825       call transpose2(AEA(1,1,1),auxmat(1,1))
8826       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8827       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8828       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8829 #endif
8830       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8831       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8832       s2 = scalar2(b1(1,itk),vtemp1(1))
8833 #ifdef MOMENT
8834       call transpose2(AEA(1,1,2),atemp(1,1))
8835       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8836       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8837       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8838 #endif
8839       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8840       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8841       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8842 #ifdef MOMENT
8843       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8844       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8845       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8846       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8847       ss13 = scalar2(b1(1,itk),vtemp4(1))
8848       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8849 #endif
8850 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8851 c      s1=0.0d0
8852 c      s2=0.0d0
8853 c      s8=0.0d0
8854 c      s12=0.0d0
8855 c      s13=0.0d0
8856       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8857 C Derivatives in gamma(i+2)
8858       s1d =0.0d0
8859       s8d =0.0d0
8860 #ifdef MOMENT
8861       call transpose2(AEA(1,1,1),auxmatd(1,1))
8862       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8863       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8864       call transpose2(AEAderg(1,1,2),atempd(1,1))
8865       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8866       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8867 #endif
8868       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8869       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8870       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8871 c      s1d=0.0d0
8872 c      s2d=0.0d0
8873 c      s8d=0.0d0
8874 c      s12d=0.0d0
8875 c      s13d=0.0d0
8876       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8877 C Derivatives in gamma(i+3)
8878 #ifdef MOMENT
8879       call transpose2(AEA(1,1,1),auxmatd(1,1))
8880       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8881       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8882       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8883 #endif
8884       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8885       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8886       s2d = scalar2(b1(1,itk),vtemp1d(1))
8887 #ifdef MOMENT
8888       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8889       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8890 #endif
8891       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8892 #ifdef MOMENT
8893       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8894       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8895       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8896 #endif
8897 c      s1d=0.0d0
8898 c      s2d=0.0d0
8899 c      s8d=0.0d0
8900 c      s12d=0.0d0
8901 c      s13d=0.0d0
8902 #ifdef MOMENT
8903       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8904      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8905 #else
8906       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8907      &               -0.5d0*ekont*(s2d+s12d)
8908 #endif
8909 C Derivatives in gamma(i+4)
8910       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8911       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8912       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8913 #ifdef MOMENT
8914       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8915       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8916       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8917 #endif
8918 c      s1d=0.0d0
8919 c      s2d=0.0d0
8920 c      s8d=0.0d0
8921 C      s12d=0.0d0
8922 c      s13d=0.0d0
8923 #ifdef MOMENT
8924       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8925 #else
8926       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8927 #endif
8928 C Derivatives in gamma(i+5)
8929 #ifdef MOMENT
8930       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8931       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8932       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8933 #endif
8934       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8935       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8936       s2d = scalar2(b1(1,itk),vtemp1d(1))
8937 #ifdef MOMENT
8938       call transpose2(AEA(1,1,2),atempd(1,1))
8939       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8940       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8941 #endif
8942       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8943       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8944 #ifdef MOMENT
8945       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8946       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8947       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8948 #endif
8949 c      s1d=0.0d0
8950 c      s2d=0.0d0
8951 c      s8d=0.0d0
8952 c      s12d=0.0d0
8953 c      s13d=0.0d0
8954 #ifdef MOMENT
8955       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8956      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8957 #else
8958       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8959      &               -0.5d0*ekont*(s2d+s12d)
8960 #endif
8961 C Cartesian derivatives
8962       do iii=1,2
8963         do kkk=1,5
8964           do lll=1,3
8965 #ifdef MOMENT
8966             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8967             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8968             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8969 #endif
8970             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8971             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8972      &          vtemp1d(1))
8973             s2d = scalar2(b1(1,itk),vtemp1d(1))
8974 #ifdef MOMENT
8975             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8976             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8977             s8d = -(atempd(1,1)+atempd(2,2))*
8978      &           scalar2(cc(1,1,itl),vtemp2(1))
8979 #endif
8980             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8981      &           auxmatd(1,1))
8982             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8983             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8984 c      s1d=0.0d0
8985 c      s2d=0.0d0
8986 c      s8d=0.0d0
8987 c      s12d=0.0d0
8988 c      s13d=0.0d0
8989 #ifdef MOMENT
8990             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8991      &        - 0.5d0*(s1d+s2d)
8992 #else
8993             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8994      &        - 0.5d0*s2d
8995 #endif
8996 #ifdef MOMENT
8997             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8998      &        - 0.5d0*(s8d+s12d)
8999 #else
9000             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9001      &        - 0.5d0*s12d
9002 #endif
9003           enddo
9004         enddo
9005       enddo
9006 #ifdef MOMENT
9007       do kkk=1,5
9008         do lll=1,3
9009           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9010      &      achuj_tempd(1,1))
9011           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9012           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9013           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9014           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9015           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9016      &      vtemp4d(1))
9017           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9018           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9019           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9020         enddo
9021       enddo
9022 #endif
9023 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9024 cd     &  16*eel_turn6_num
9025 cd      goto 1112
9026       if (j.lt.nres-1) then
9027         j1=j+1
9028         j2=j-1
9029       else
9030         j1=j-1
9031         j2=j-2
9032       endif
9033       if (l.lt.nres-1) then
9034         l1=l+1
9035         l2=l-1
9036       else
9037         l1=l-1
9038         l2=l-2
9039       endif
9040       do ll=1,3
9041 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9042 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9043 cgrad        ghalf=0.5d0*ggg1(ll)
9044 cd        ghalf=0.0d0
9045         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9046         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9047         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9048      &    +ekont*derx_turn(ll,2,1)
9049         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9050         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9051      &    +ekont*derx_turn(ll,4,1)
9052         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9053         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9054         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9055 cgrad        ghalf=0.5d0*ggg2(ll)
9056 cd        ghalf=0.0d0
9057         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9058      &    +ekont*derx_turn(ll,2,2)
9059         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9060         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9061      &    +ekont*derx_turn(ll,4,2)
9062         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9063         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9064         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9065       enddo
9066 cd      goto 1112
9067 cgrad      do m=i+1,j-1
9068 cgrad        do ll=1,3
9069 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9070 cgrad        enddo
9071 cgrad      enddo
9072 cgrad      do m=k+1,l-1
9073 cgrad        do ll=1,3
9074 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9075 cgrad        enddo
9076 cgrad      enddo
9077 cgrad1112  continue
9078 cgrad      do m=i+2,j2
9079 cgrad        do ll=1,3
9080 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9081 cgrad        enddo
9082 cgrad      enddo
9083 cgrad      do m=k+2,l2
9084 cgrad        do ll=1,3
9085 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9086 cgrad        enddo
9087 cgrad      enddo
9088 cd      do iii=1,nres-3
9089 cd        write (2,*) iii,g_corr6_loc(iii)
9090 cd      enddo
9091       eello_turn6=ekont*eel_turn6
9092 cd      write (2,*) 'ekont',ekont
9093 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9094       return
9095       end
9096
9097 C-----------------------------------------------------------------------------
9098       double precision function scalar(u,v)
9099 !DIR$ INLINEALWAYS scalar
9100 #ifndef OSF
9101 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9102 #endif
9103       implicit none
9104       double precision u(3),v(3)
9105 cd      double precision sc
9106 cd      integer i
9107 cd      sc=0.0d0
9108 cd      do i=1,3
9109 cd        sc=sc+u(i)*v(i)
9110 cd      enddo
9111 cd      scalar=sc
9112
9113       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9114       return
9115       end
9116 crc-------------------------------------------------
9117       SUBROUTINE MATVEC2(A1,V1,V2)
9118 !DIR$ INLINEALWAYS MATVEC2
9119 #ifndef OSF
9120 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9121 #endif
9122       implicit real*8 (a-h,o-z)
9123       include 'DIMENSIONS'
9124       DIMENSION A1(2,2),V1(2),V2(2)
9125 c      DO 1 I=1,2
9126 c        VI=0.0
9127 c        DO 3 K=1,2
9128 c    3     VI=VI+A1(I,K)*V1(K)
9129 c        Vaux(I)=VI
9130 c    1 CONTINUE
9131
9132       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9133       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9134
9135       v2(1)=vaux1
9136       v2(2)=vaux2
9137       END
9138 C---------------------------------------
9139       SUBROUTINE MATMAT2(A1,A2,A3)
9140 #ifndef OSF
9141 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9142 #endif
9143       implicit real*8 (a-h,o-z)
9144       include 'DIMENSIONS'
9145       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9146 c      DIMENSION AI3(2,2)
9147 c        DO  J=1,2
9148 c          A3IJ=0.0
9149 c          DO K=1,2
9150 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9151 c          enddo
9152 c          A3(I,J)=A3IJ
9153 c       enddo
9154 c      enddo
9155
9156       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9157       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9158       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9159       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9160
9161       A3(1,1)=AI3_11
9162       A3(2,1)=AI3_21
9163       A3(1,2)=AI3_12
9164       A3(2,2)=AI3_22
9165       END
9166
9167 c-------------------------------------------------------------------------
9168       double precision function scalar2(u,v)
9169 !DIR$ INLINEALWAYS scalar2
9170       implicit none
9171       double precision u(2),v(2)
9172       double precision sc
9173       integer i
9174       scalar2=u(1)*v(1)+u(2)*v(2)
9175       return
9176       end
9177
9178 C-----------------------------------------------------------------------------
9179
9180       subroutine transpose2(a,at)
9181 !DIR$ INLINEALWAYS transpose2
9182 #ifndef OSF
9183 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9184 #endif
9185       implicit none
9186       double precision a(2,2),at(2,2)
9187       at(1,1)=a(1,1)
9188       at(1,2)=a(2,1)
9189       at(2,1)=a(1,2)
9190       at(2,2)=a(2,2)
9191       return
9192       end
9193 c--------------------------------------------------------------------------
9194       subroutine transpose(n,a,at)
9195       implicit none
9196       integer n,i,j
9197       double precision a(n,n),at(n,n)
9198       do i=1,n
9199         do j=1,n
9200           at(j,i)=a(i,j)
9201         enddo
9202       enddo
9203       return
9204       end
9205 C---------------------------------------------------------------------------
9206       subroutine prodmat3(a1,a2,kk,transp,prod)
9207 !DIR$ INLINEALWAYS prodmat3
9208 #ifndef OSF
9209 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9210 #endif
9211       implicit none
9212       integer i,j
9213       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9214       logical transp
9215 crc      double precision auxmat(2,2),prod_(2,2)
9216
9217       if (transp) then
9218 crc        call transpose2(kk(1,1),auxmat(1,1))
9219 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9220 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9221
9222            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9223      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9224            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9225      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9226            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9227      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9228            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9229      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9230
9231       else
9232 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9233 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9234
9235            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9236      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9237            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9238      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9239            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9240      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9241            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9242      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9243
9244       endif
9245 c      call transpose2(a2(1,1),a2t(1,1))
9246
9247 crc      print *,transp
9248 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9249 crc      print *,((prod(i,j),i=1,2),j=1,2)
9250
9251       return
9252       end
9253