source/unres/src_CSA/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         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57           weights_(22)=wsct
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84           wsct=weights(22)
  85         endif
  86         time_Bcast=time_Bcast+MPI_Wtime()-time00
  87         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  88 c        call chainbuild_cart
  89       endif
  90 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  91 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  92 #else
  93 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  94 c        call int_from_cart1(.false.)
  95 c      endif
  96 #endif
  97 #ifdef TIMING
  98       time00=MPI_Wtime()
  99 #endif
 100 C
 101 C Compute the side-chain and electrostatic interaction energy
 102 C
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw,evdw_p,evdw_m)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw,evdw_p,evdw_m)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw,evdw_p,evdw_m)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw,evdw_p,evdw_m)
 116       goto 107
 117 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 118   105 call egbv(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Soft-sphere potential
 121   106 call e_softsphere(evdw)
 122 C
 123 C Calculate electrostatic (H-bonding) energy of the main chain.
 124 C
 125   107 continue
 126
 127 C     JUYONG for dfa test!
 128       if (wdfa_dist.gt.0) call edfad(edfadis)
 129 c      print*, 'edfad is finished!', edfadis
 130       if (wdfa_tor.gt.0) call edfat(edfator)
 131 c      print*, 'edfat is finished!', edfator
 132       if (wdfa_nei.gt.0) call edfan(edfanei)
 133 c      print*, 'edfan is finished!', edfanei
 134       if (wdfa_beta.gt.0) call edfab(edfabet)
 135 c      print*, 'edfab is finished!', edfabet
 136 C      stop
 137 C     JUYONG
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141       time01=MPI_Wtime()
 142 #endif
 143       call vec_and_deriv
 144 #ifdef TIMING
 145       time_vec=time_vec+MPI_Wtime()-time01
 146 #endif
 147 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 148       if (ipot.lt.6) then
 149 #ifdef SPLITELE
 150          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 151      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 152      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 153      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 154 #else
 155          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 156      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 157      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 158      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 159 #endif
 160             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 161          else
 162             ees=0.0d0
 163             evdw1=0.0d0
 164             eel_loc=0.0d0
 165             eello_turn3=0.0d0
 166             eello_turn4=0.0d0
 167          endif
 168       else
 169 c        write (iout,*) "Soft-spheer ELEC potential"
 170         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 171      &   eello_turn4)
 172       endif
 173 c      print *,"Processor",myrank," computed UELEC"
 174 C
 175 C Calculate excluded-volume interaction energy between peptide groups
 176 C and side chains.
 177 C
 178       if (ipot.lt.6) then
 179        if(wscp.gt.0d0) then
 180         call escp(evdw2,evdw2_14)
 181        else
 182         evdw2=0
 183         evdw2_14=0
 184        endif
 185       else
 186 c        write (iout,*) "Soft-sphere SCP potential"
 187         call escp_soft_sphere(evdw2,evdw2_14)
 188       endif
 189 c
 190 c Calculate the bond-stretching energy
 191 c
 192       call ebond(estr)
 193 C
 194 C Calculate the disulfide-bridge and other energy and the contributions
 195 C from other distance constraints.
 196 cd    print *,'Calling EHPB'
 197       call edis(ehpb)
 198 cd    print *,'EHPB exitted succesfully.'
 199 C
 200 C Calculate the virtual-bond-angle energy.
 201 C
 202       if (wang.gt.0d0) then
 203         call ebend(ebe)
 204       else
 205         ebe=0
 206       endif
 207 c      print *,"Processor",myrank," computed UB"
 208 C
 209 C Calculate the SC local energy.
 210 C
 211       call esc(escloc)
 212 c      print *,"Processor",myrank," computed USC"
 213 C
 214 C Calculate the virtual-bond torsional energy.
 215 C
 216 cd    print *,'nterm=',nterm
 217       if (wtor.gt.0) then
 218        call etor(etors,edihcnstr)
 219       else
 220        etors=0
 221        edihcnstr=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utor"
 224 C
 225 C 6/23/01 Calculate double-torsional energy
 226 C
 227       if (wtor_d.gt.0) then
 228        call etor_d(etors_d)
 229       else
 230        etors_d=0
 231       endif
 232 c      print *,"Processor",myrank," computed Utord"
 233 C
 234 C 21/5/07 Calculate local sicdechain correlation energy
 235 C
 236       if (wsccor.gt.0.0d0) then
 237         call eback_sc_corr(esccor)
 238       else
 239         esccor=0.0d0
 240       endif
 241 c      print *,"Processor",myrank," computed Usccorr"
 242 C
 243 C 12/1/95 Multi-body terms
 244 C
 245       n_corr=0
 246       n_corr1=0
 247       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 248      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 250 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 251 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 252       else
 253          ecorr=0.0d0
 254          ecorr5=0.0d0
 255          ecorr6=0.0d0
 256          eturn6=0.0d0
 257       endif
 258       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 259          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 260 cd         write (iout,*) "multibody_hb ecorr",ecorr
 261       endif
 262 c      print *,"Processor",myrank," computed Ucorr"
 263 C
 264 C If performing constraint dynamics, call the constraint energy
 265 C  after the equilibration time
 266       if(usampl.and.totT.gt.eq_time) then
 267 c         call EconstrQ
 268          call Econstr_back
 269       else
 270          Uconst=0.0d0
 271          Uconst_back=0.0d0
 272       endif
 273 #ifdef TIMING
 274       time_enecalc=time_enecalc+MPI_Wtime()-time00
 275 #endif
 276 c      print *,"Processor",myrank," computed Uconstr"
 277 #ifdef TIMING
 278       time00=MPI_Wtime()
 279 #endif
 280 c
 281 C Sum the energies
 282 C
 283       energia(1)=evdw
 284 #ifdef SCP14
 285       energia(2)=evdw2-evdw2_14
 286       energia(18)=evdw2_14
 287 #else
 288       energia(2)=evdw2
 289       energia(18)=0.0d0
 290 #endif
 291 #ifdef SPLITELE
 292       energia(3)=ees
 293       energia(16)=evdw1
 294 #else
 295       energia(3)=ees+evdw1
 296       energia(16)=0.0d0
 297 #endif
 298       energia(4)=ecorr
 299       energia(5)=ecorr5
 300       energia(6)=ecorr6
 301       energia(7)=eel_loc
 302       energia(8)=eello_turn3
 303       energia(9)=eello_turn4
 304       energia(10)=eturn6
 305       energia(11)=ebe
 306       energia(12)=escloc
 307       energia(13)=etors
 308       energia(14)=etors_d
 309       energia(15)=ehpb
 310       energia(19)=edihcnstr
 311       energia(17)=estr
 312       energia(20)=Uconst+Uconst_back
 313       energia(21)=esccor
 314       energia(22)=evdw_p
 315       energia(23)=evdw_m
 316       energia(24)=edfadis
 317       energia(25)=edfator
 318       energia(26)=edfanei
 319       energia(27)=edfabet
 320 c      print *," Processor",myrank," calls SUM_ENERGY"
 321       call sum_energy(energia,.true.)
 322 c      print *," Processor",myrank," left SUM_ENERGY"
 323 #ifdef TIMING
 324       time_sumene=time_sumene+MPI_Wtime()-time00
 325 #endif
 326
 327 c      print*, 'etot:',energia(0)
 328
 329       return
 330       end
 331 c-------------------------------------------------------------------------------
 332       subroutine sum_energy(energia,reduce)
 333       implicit real*8 (a-h,o-z)
 334       include 'DIMENSIONS'
 335 #ifndef ISNAN
 336       external proc_proc
 337 #ifdef WINPGI
 338 cMS$ATTRIBUTES C ::  proc_proc
 339 #endif
 340 #endif
 341 #ifdef MPI
 342       include "mpif.h"
 343 #endif
 344       include 'COMMON.SETUP'
 345       include 'COMMON.IOUNITS'
 346       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 347       include 'COMMON.FFIELD'
 348       include 'COMMON.DERIV'
 349       include 'COMMON.INTERACT'
 350       include 'COMMON.SBRIDGE'
 351       include 'COMMON.CHAIN'
 352       include 'COMMON.VAR'
 353       include 'COMMON.CONTROL'
 354       include 'COMMON.TIME1'
 355       logical reduce
 356 #ifdef MPI
 357       if (nfgtasks.gt.1 .and. reduce) then
 358 #ifdef DEBUG
 359         write (iout,*) "energies before REDUCE"
 360         call enerprint(energia)
 361         call flush(iout)
 362 #endif
 363         do i=0,n_ene
 364           enebuff(i)=energia(i)
 365         enddo
 366         time00=MPI_Wtime()
 367         call MPI_Barrier(FG_COMM,IERR)
 368         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 369         time00=MPI_Wtime()
 370         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 371      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 372 #ifdef DEBUG
 373         write (iout,*) "energies after REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         time_Reduce=time_Reduce+MPI_Wtime()-time00
 378       endif
 379       if (fg_rank.eq.0) then
 380 #endif
 381 #ifdef TSCSC
 382       evdw=energia(22)+wsct*energia(23)
 383 #else
 384       evdw=energia(1)
 385 #endif
 386 #ifdef SCP14
 387       evdw2=energia(2)+energia(18)
 388       evdw2_14=energia(18)
 389 #else
 390       evdw2=energia(2)
 391 #endif
 392 #ifdef SPLITELE
 393       ees=energia(3)
 394       evdw1=energia(16)
 395 #else
 396       ees=energia(3)
 397       evdw1=0.0d0
 398 #endif
 399       ecorr=energia(4)
 400       ecorr5=energia(5)
 401       ecorr6=energia(6)
 402       eel_loc=energia(7)
 403       eello_turn3=energia(8)
 404       eello_turn4=energia(9)
 405       eturn6=energia(10)
 406       ebe=energia(11)
 407       escloc=energia(12)
 408       etors=energia(13)
 409       etors_d=energia(14)
 410       ehpb=energia(15)
 411       edihcnstr=energia(19)
 412       estr=energia(17)
 413       Uconst=energia(20)
 414       esccor=energia(21)
 415       edfadis=energia(24)
 416       edfator=energia(25)
 417       edfanei=energia(26)
 418       edfabet=energia(27)
 419 #ifdef SPLITELE
 420       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 421      & +wang*ebe+wtor*etors+wscloc*escloc
 422      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 423      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 424      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 425      & +wbond*estr+Uconst+wsccor*esccor
 426      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 427      & +wdfa_beta*edfabet
 428 #else
 429       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor
 435      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 436      & +wdfa_beta*edfabet
 437
 438 #endif
 439       energia(0)=etot
 440 c detecting NaNQ
 441 #ifdef ISNAN
 442 #ifdef AIX
 443       if (isnan(etot).ne.0) energia(0)=1.0d+99
 444 #else
 445       if (isnan(etot)) energia(0)=1.0d+99
 446 #endif
 447 #else
 448       i=0
 449 #ifdef WINPGI
 450       idumm=proc_proc(etot,i)
 451 #else
 452       call proc_proc(etot,i)
 453 #endif
 454       if(i.eq.1)energia(0)=1.0d+99
 455 #endif
 456 #ifdef MPI
 457       endif
 458 #endif
 459       return
 460       end
 461 c-------------------------------------------------------------------------------
 462       subroutine sum_gradient
 463       implicit real*8 (a-h,o-z)
 464       include 'DIMENSIONS'
 465 #ifndef ISNAN
 466       external proc_proc
 467 #ifdef WINPGI
 468 cMS$ATTRIBUTES C ::  proc_proc
 469 #endif
 470 #endif
 471 #ifdef MPI
 472       include 'mpif.h'
 473       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 474      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 475 #else
 476       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 477      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 478 #endif
 479       include 'COMMON.SETUP'
 480       include 'COMMON.IOUNITS'
 481       include 'COMMON.FFIELD'
 482       include 'COMMON.DERIV'
 483       include 'COMMON.INTERACT'
 484       include 'COMMON.SBRIDGE'
 485       include 'COMMON.CHAIN'
 486       include 'COMMON.VAR'
 487       include 'COMMON.CONTROL'
 488       include 'COMMON.TIME1'
 489       include 'COMMON.MAXGRAD'
 490 #ifdef TIMING
 491       time01=MPI_Wtime()
 492 #endif
 493 #ifdef DEBUG
 494       write (iout,*) "sum_gradient gvdwc, gvdwx"
 495       do i=1,nres
 496         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 497      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 498      &   (gvdwcT(j,i),j=1,3)
 499       enddo
 500       call flush(iout)
 501 #endif
 502 #ifdef MPI
 503 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 504         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 505      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 506 #endif
 507 C
 508 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 509 C            in virtual-bond-vector coordinates
 510 C
 511 #ifdef DEBUG
 512 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 513 c      do i=1,nres-1
 514 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 515 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 516 c      enddo
 517 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 518 c      do i=1,nres-1
 519 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 520 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 521 c      enddo
 522       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 523       do i=1,nres
 524         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 525      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 526      &   g_corr5_loc(i)
 527       enddo
 528       call flush(iout)
 529 #endif
 530 #ifdef SPLITELE
 531 #ifdef TSCSC
 532       do i=1,nct
 533         do j=1,3
 534           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 535      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 536      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 537      &                wel_loc*gel_loc_long(j,i)+
 538      &                wcorr*gradcorr_long(j,i)+
 539      &                wcorr5*gradcorr5_long(j,i)+
 540      &                wcorr6*gradcorr6_long(j,i)+
 541      &                wturn6*gcorr6_turn_long(j,i)+
 542      &                wstrain*ghpbc(j,i)+
 543      &                wdfa_dist*gdfad(j,i)+
 544      &                wdfa_tor*gdfat(j,i)+
 545      &                wdfa_nei*gdfan(j,i)+
 546      &                wdfa_beta*gdfab(j,i)
 547
 548         enddo
 549       enddo
 550 #else
 551       do i=1,nct
 552         do j=1,3
 553           gradbufc(j,i)=wsc*gvdwc(j,i)+
 554      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 555      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 556      &                wel_loc*gel_loc_long(j,i)+
 557      &                wcorr*gradcorr_long(j,i)+
 558      &                wcorr5*gradcorr5_long(j,i)+
 559      &                wcorr6*gradcorr6_long(j,i)+
 560      &                wturn6*gcorr6_turn_long(j,i)+
 561      &                wstrain*ghpbc(j,i)+
 562      &                wdfa_dist*gdfad(j,i)+
 563      &                wdfa_tor*gdfat(j,i)+
 564      &                wdfa_nei*gdfan(j,i)+
 565      &                wdfa_beta*gdfab(j,i)
 566
 567         enddo
 568       enddo
 569 #endif
 570 #else
 571       do i=1,nct
 572         do j=1,3
 573           gradbufc(j,i)=wsc*gvdwc(j,i)+
 574      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 575      &                welec*gelc_long(j,i)+
 576      &                wbond*gradb(j,i)+
 577      &                wel_loc*gel_loc_long(j,i)+
 578      &                wcorr*gradcorr_long(j,i)+
 579      &                wcorr5*gradcorr5_long(j,i)+
 580      &                wcorr6*gradcorr6_long(j,i)+
 581      &                wturn6*gcorr6_turn_long(j,i)+
 582      &                wstrain*ghpbc(j,i)+
 583      &                wdfa_dist*gdfad(j,i)+
 584      &                wdfa_tor*gdfat(j,i)+
 585      &                wdfa_nei*gdfan(j,i)+
 586      &                wdfa_beta*gdfab(j,i)
 587
 588
 589         enddo
 590       enddo
 591 #endif
 592 #ifdef MPI
 593       if (nfgtasks.gt.1) then
 594       time00=MPI_Wtime()
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc before allreduce"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 603      &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 604       time_reduce=time_reduce+MPI_Wtime()-time00
 605 #ifdef DEBUG
 606       write (iout,*) "gradbufc_sum after allreduce"
 607       do i=1,nres
 608         write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 609       enddo
 610       call flush(iout)
 611 #endif
 612 #ifdef TIMING
 613       time_allreduce=time_allreduce+MPI_Wtime()-time00
 614 #endif
 615       do i=nnt,nres
 616         do k=1,3
 617           gradbufc(k,i)=0.0d0
 618         enddo
 619       enddo
 620       do i=igrad_start,igrad_end
 621         do j=jgrad_start(i),jgrad_end(i)
 622           do k=1,3
 623             gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 624           enddo
 625         enddo
 626       enddo
 627       else
 628 #endif
 629 #ifdef DEBUG
 630       write (iout,*) "gradbufc"
 631       do i=1,nres
 632         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 633       enddo
 634       call flush(iout)
 635 #endif
 636       do i=nnt,nres-1
 637         do k=1,3
 638           gradbufc(k,i)=0.0d0
 639         enddo
 640         do j=i+1,nres
 641           do k=1,3
 642             gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 643           enddo
 644         enddo
 645       enddo
 646 #ifdef MPI
 647       endif
 648 #endif
 649       do k=1,3
 650         gradbufc(k,nres)=0.0d0
 651       enddo
 652       do i=1,nct
 653         do j=1,3
 654 #ifdef SPLITELE
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gradcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #else
 674           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 675      &                wel_loc*gel_loc(j,i)+
 676      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 677      &                welec*gelc_long(j,i)
 678      &                wel_loc*gel_loc_long(j,i)+
 679      &                wcorr*gcorr_long(j,i)+
 680      &                wcorr5*gradcorr5_long(j,i)+
 681      &                wcorr6*gradcorr6_long(j,i)+
 682      &                wturn6*gcorr6_turn_long(j,i))+
 683      &                wbond*gradb(j,i)+
 684      &                wcorr*gradcorr(j,i)+
 685      &                wturn3*gcorr3_turn(j,i)+
 686      &                wturn4*gcorr4_turn(j,i)+
 687      &                wcorr5*gradcorr5(j,i)+
 688      &                wcorr6*gradcorr6(j,i)+
 689      &                wturn6*gcorr6_turn(j,i)+
 690      &                wsccor*gsccorc(j,i)
 691      &               +wscloc*gscloc(j,i)
 692 #endif
 693 #ifdef TSCSC
 694           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 695      &                  wscp*gradx_scp(j,i)+
 696      &                  wbond*gradbx(j,i)+
 697      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 698      &                  wsccor*gsccorx(j,i)
 699      &                 +wscloc*gsclocx(j,i)
 700 #else
 701           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 702      &                  wbond*gradbx(j,i)+
 703      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 704      &                  wsccor*gsccorx(j,i)
 705      &                 +wscloc*gsclocx(j,i)
 706 #endif
 707         enddo
 708       enddo
 709 #ifdef DEBUG
 710       write (iout,*) "gloc before adding corr"
 711       do i=1,4*nres
 712         write (iout,*) i,gloc(i,icg)
 713       enddo
 714 #endif
 715       do i=1,nres-3
 716         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 717      &   +wcorr5*g_corr5_loc(i)
 718      &   +wcorr6*g_corr6_loc(i)
 719      &   +wturn4*gel_loc_turn4(i)
 720      &   +wturn3*gel_loc_turn3(i)
 721      &   +wturn6*gel_loc_turn6(i)
 722      &   +wel_loc*gel_loc_loc(i)
 723      &   +wsccor*gsccor_loc(i)
 724       enddo
 725 #ifdef DEBUG
 726       write (iout,*) "gloc after adding corr"
 727       do i=1,4*nres
 728         write (iout,*) i,gloc(i,icg)
 729       enddo
 730 #endif
 731 #ifdef MPI
 732       if (nfgtasks.gt.1) then
 733         do j=1,3
 734           do i=1,nres
 735             gradbufc(j,i)=gradc(j,i,icg)
 736             gradbufx(j,i)=gradx(j,i,icg)
 737           enddo
 738         enddo
 739         do i=1,4*nres
 740           glocbuf(i)=gloc(i,icg)
 741         enddo
 742         time00=MPI_Wtime()
 743         call MPI_Barrier(FG_COMM,IERR)
 744         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 745         time00=MPI_Wtime()
 746         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 749      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 750         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 751      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 752         time_reduce=time_reduce+MPI_Wtime()-time00
 753 #ifdef DEBUG
 754       write (iout,*) "gloc after reduce"
 755       do i=1,4*nres
 756         write (iout,*) i,gloc(i,icg)
 757       enddo
 758 #endif
 759       endif
 760 #endif
 761       if (gnorm_check) then
 762 c
 763 c Compute the maximum elements of the gradient
 764 c
 765       gvdwc_max=0.0d0
 766       gvdwc_scp_max=0.0d0
 767       gelc_max=0.0d0
 768       gvdwpp_max=0.0d0
 769       gradb_max=0.0d0
 770       ghpbc_max=0.0d0
 771       gradcorr_max=0.0d0
 772       gel_loc_max=0.0d0
 773       gcorr3_turn_max=0.0d0
 774       gcorr4_turn_max=0.0d0
 775       gradcorr5_max=0.0d0
 776       gradcorr6_max=0.0d0
 777       gcorr6_turn_max=0.0d0
 778       gsccorc_max=0.0d0
 779       gscloc_max=0.0d0
 780       gvdwx_max=0.0d0
 781       gradx_scp_max=0.0d0
 782       ghpbx_max=0.0d0
 783       gradxorr_max=0.0d0
 784       gsccorx_max=0.0d0
 785       gsclocx_max=0.0d0
 786       do i=1,nct
 787         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 788         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 789 #ifdef TSCSC
 790         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 791         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 792 #endif
 793         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 794         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 795      &   gvdwc_scp_max=gvdwc_scp_norm
 796         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 797         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 798         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 799         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 800         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 801         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 802         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 803         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 804         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 805         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 806         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 807         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 808         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 809      &    gcorr3_turn(1,i)))
 810         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 811      &    gcorr3_turn_max=gcorr3_turn_norm
 812         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 813      &    gcorr4_turn(1,i)))
 814         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 815      &    gcorr4_turn_max=gcorr4_turn_norm
 816         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 817         if (gradcorr5_norm.gt.gradcorr5_max)
 818      &    gradcorr5_max=gradcorr5_norm
 819         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 820         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 821         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 822      &    gcorr6_turn(1,i)))
 823         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 824      &    gcorr6_turn_max=gcorr6_turn_norm
 825         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 826         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 827         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 828         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 829         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 830         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 831 #ifdef TSCSC
 832         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 833         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 834 #endif
 835         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 836         if (gradx_scp_norm.gt.gradx_scp_max)
 837      &    gradx_scp_max=gradx_scp_norm
 838         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 839         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 840         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 841         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 842         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 843         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 844         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 845         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 846       enddo
 847       if (gradout) then
 848 #ifdef AIX
 849         open(istat,file=statname,position="append")
 850 #else
 851         open(istat,file=statname,access="append")
 852 #endif
 853         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 854      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 855      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 856      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 857      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 858      &     gsccorx_max,gsclocx_max
 859         close(istat)
 860         if (gvdwc_max.gt.1.0d4) then
 861           write (iout,*) "gvdwc gvdwx gradb gradbx"
 862           do i=nnt,nct
 863             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 864      &        gradb(j,i),gradbx(j,i),j=1,3)
 865           enddo
 866           call pdbout(0.0d0,'cipiszcze',iout)
 867           call flush(iout)
 868         endif
 869       endif
 870       endif
 871 #ifdef DEBUG
 872       write (iout,*) "gradc gradx gloc"
 873       do i=1,nres
 874         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 875      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 876       enddo
 877 #endif
 878 #ifdef TIMING
 879       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 880 #endif
 881       return
 882       end
 883 c-------------------------------------------------------------------------------
 884       subroutine rescale_weights(t_bath)
 885       implicit real*8 (a-h,o-z)
 886       include 'DIMENSIONS'
 887       include 'COMMON.IOUNITS'
 888       include 'COMMON.FFIELD'
 889       include 'COMMON.SBRIDGE'
 890       double precision kfac /2.4d0/
 891       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 892 c      facT=temp0/t_bath
 893 c      facT=2*temp0/(t_bath+temp0)
 894       if (rescale_mode.eq.0) then
 895         facT=1.0d0
 896         facT2=1.0d0
 897         facT3=1.0d0
 898         facT4=1.0d0
 899         facT5=1.0d0
 900       else if (rescale_mode.eq.1) then
 901         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 902         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 903         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 904         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 905         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 906       else if (rescale_mode.eq.2) then
 907         x=t_bath/temp0
 908         x2=x*x
 909         x3=x2*x
 910         x4=x3*x
 911         x5=x4*x
 912         facT=licznik/dlog(dexp(x)+dexp(-x))
 913         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 914         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 915         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 916         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 917       else
 918         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 919         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 920 #ifdef MPI
 921        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 922 #endif
 923        stop 555
 924       endif
 925       welec=weights(3)*fact
 926       wcorr=weights(4)*fact3
 927       wcorr5=weights(5)*fact4
 928       wcorr6=weights(6)*fact5
 929       wel_loc=weights(7)*fact2
 930       wturn3=weights(8)*fact2
 931       wturn4=weights(9)*fact3
 932       wturn6=weights(10)*fact5
 933       wtor=weights(13)*fact
 934       wtor_d=weights(14)*fact2
 935       wsccor=weights(21)*fact
 936 #ifdef TSCSC
 937 c      wsct=t_bath/temp0
 938       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 939 #endif
 940       return
 941       end
 942 C------------------------------------------------------------------------
 943       subroutine enerprint(energia)
 944       implicit real*8 (a-h,o-z)
 945       include 'DIMENSIONS'
 946       include 'COMMON.IOUNITS'
 947       include 'COMMON.FFIELD'
 948       include 'COMMON.SBRIDGE'
 949       include 'COMMON.MD_'
 950       double precision energia(0:n_ene)
 951       etot=energia(0)
 952 #ifdef TSCSC
 953       evdw=energia(22)+wsct*energia(23)
 954 #else
 955       evdw=energia(1)
 956 #endif
 957       evdw2=energia(2)
 958 #ifdef SCP14
 959       evdw2=energia(2)+energia(18)
 960 #else
 961       evdw2=energia(2)
 962 #endif
 963       ees=energia(3)
 964 #ifdef SPLITELE
 965       evdw1=energia(16)
 966 #endif
 967       ecorr=energia(4)
 968       ecorr5=energia(5)
 969       ecorr6=energia(6)
 970       eel_loc=energia(7)
 971       eello_turn3=energia(8)
 972       eello_turn4=energia(9)
 973       eello_turn6=energia(10)
 974       ebe=energia(11)
 975       escloc=energia(12)
 976       etors=energia(13)
 977       etors_d=energia(14)
 978       ehpb=energia(15)
 979       edihcnstr=energia(19)
 980       estr=energia(17)
 981       Uconst=energia(20)
 982       esccor=energia(21)
 983 C     Juyong
 984       edfadis = energia(24)
 985       edfator = energia(25)
 986       edfanei = energia(26)
 987       edfabet = energia(27)
 988 C
 989 #ifdef SPLITELE
 990       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 991      &  estr,wbond,ebe,wang,
 992      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 993      &  ecorr,wcorr,
 994      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 995      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 996      &  edihcnstr,ebr*nss,
 997      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
 998    10 format (/'Virtual-chain energies:'//
 999      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1000      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1001      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1002      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1003      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1004      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1005      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1006      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1007      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1008      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1009      & ' (SS bridges & dist. cnstr.)'/
1010      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1011      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1012      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1013      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1014      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1015      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1016      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1017      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1018      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1019      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1020      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1021      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1022      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1023      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1024      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1025      & 'ETOT=  ',1pE16.6,' (total)')
1026 #else
1027       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1028      &  estr,wbond,ebe,wang,
1029      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1030      &  ecorr,wcorr,
1031      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1032      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1033      &  ebr*nss,
1034      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
1035    10 format (/'Virtual-chain energies:'//
1036      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1037      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1038      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1039      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1040      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1041      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1042      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1043      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1044      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1045      & ' (SS bridges & dist. cnstr.)'/
1046      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1047      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1048      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1049      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1050      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1051      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1052      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1053      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1054      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1055      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1056      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1057      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1058      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1059      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1060      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1061      & 'ETOT=  ',1pE16.6,' (total)')
1062 #endif
1063       return
1064       end
1065 C-----------------------------------------------------------------------
1066       subroutine elj(evdw,evdw_p,evdw_m)
1067 C
1068 C This subroutine calculates the interaction energy of nonbonded side chains
1069 C assuming the LJ potential of interaction.
1070 C
1071       implicit real*8 (a-h,o-z)
1072       include 'DIMENSIONS'
1073       parameter (accur=1.0d-10)
1074       include 'COMMON.GEO'
1075       include 'COMMON.VAR'
1076       include 'COMMON.LOCAL'
1077       include 'COMMON.CHAIN'
1078       include 'COMMON.DERIV'
1079       include 'COMMON.INTERACT'
1080       include 'COMMON.TORSION'
1081       include 'COMMON.SBRIDGE'
1082       include 'COMMON.NAMES'
1083       include 'COMMON.IOUNITS'
1084       include 'COMMON.CONTACTS'
1085 #ifdef MOMENT
1086       include 'COMMON.CONTACTS.MOMENT'
1087 #endif
1088       dimension gg(3)
1089 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1090       evdw=0.0D0
1091       do i=iatsc_s,iatsc_e
1092         itypi=itype(i)
1093         itypi1=itype(i+1)
1094         xi=c(1,nres+i)
1095         yi=c(2,nres+i)
1096         zi=c(3,nres+i)
1097 C Change 12/1/95
1098         num_conti=0
1099 C
1100 C Calculate SC interaction energy.
1101 C
1102         do iint=1,nint_gr(i)
1103 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1104 cd   &                  'iend=',iend(i,iint)
1105           do j=istart(i,iint),iend(i,iint)
1106             itypj=itype(j)
1107             xj=c(1,nres+j)-xi
1108             yj=c(2,nres+j)-yi
1109             zj=c(3,nres+j)-zi
1110 C Change 12/1/95 to calculate four-body interactions
1111             rij=xj*xj+yj*yj+zj*zj
1112             rrij=1.0D0/rij
1113 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1114             eps0ij=eps(itypi,itypj)
1115             fac=rrij**expon2
1116             e1=fac*fac*aa(itypi,itypj)
1117             e2=fac*bb(itypi,itypj)
1118             evdwij=e1+e2
1119 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1120 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1121 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1122 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1123 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1124 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1125 #ifdef TSCSC
1126             if (bb(itypi,itypj).gt.0) then
1127                evdw_p=evdw_p+evdwij
1128             else
1129                evdw_m=evdw_m+evdwij
1130             endif
1131 #else
1132             evdw=evdw+evdwij
1133 #endif
1134 C
1135 C Calculate the components of the gradient in DC and X
1136 C
1137             fac=-rrij*(e1+evdwij)
1138             gg(1)=xj*fac
1139             gg(2)=yj*fac
1140             gg(3)=zj*fac
1141 #ifdef TSCSC
1142             if (bb(itypi,itypj).gt.0.0d0) then
1143               do k=1,3
1144                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1145                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1146                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1147                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1148               enddo
1149             else
1150               do k=1,3
1151                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1152                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1153                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1154                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1155               enddo
1156             endif
1157 #else
1158             do k=1,3
1159               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1160               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1161               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1162               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1163             enddo
1164 #endif
1165 cgrad            do k=i,j-1
1166 cgrad              do l=1,3
1167 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1168 cgrad              enddo
1169 cgrad            enddo
1170 C
1171 C 12/1/95, revised on 5/20/97
1172 C
1173 C Calculate the contact function. The ith column of the array JCONT will
1174 C contain the numbers of atoms that make contacts with the atom I (of numbers
1175 C greater than I). The arrays FACONT and GACONT will contain the values of
1176 C the contact function and its derivative.
1177 C
1178 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1179 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1180 C Uncomment next line, if the correlation interactions are contact function only
1181             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1182               rij=dsqrt(rij)
1183               sigij=sigma(itypi,itypj)
1184               r0ij=rs0(itypi,itypj)
1185 C
1186 C Check whether the SC's are not too far to make a contact.
1187 C
1188               rcut=1.5d0*r0ij
1189               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1190 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1191 C
1192               if (fcont.gt.0.0D0) then
1193 C If the SC-SC distance if close to sigma, apply spline.
1194 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1195 cAdam &             fcont1,fprimcont1)
1196 cAdam           fcont1=1.0d0-fcont1
1197 cAdam           if (fcont1.gt.0.0d0) then
1198 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1199 cAdam             fcont=fcont*fcont1
1200 cAdam           endif
1201 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1202 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1203 cga             do k=1,3
1204 cga               gg(k)=gg(k)*eps0ij
1205 cga             enddo
1206 cga             eps0ij=-evdwij*eps0ij
1207 C Uncomment for AL's type of SC correlation interactions.
1208 cadam           eps0ij=-evdwij
1209                 num_conti=num_conti+1
1210                 jcont(num_conti,i)=j
1211                 facont(num_conti,i)=fcont*eps0ij
1212                 fprimcont=eps0ij*fprimcont/rij
1213                 fcont=expon*fcont
1214 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1215 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1216 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1217 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1218                 gacont(1,num_conti,i)=-fprimcont*xj
1219                 gacont(2,num_conti,i)=-fprimcont*yj
1220                 gacont(3,num_conti,i)=-fprimcont*zj
1221 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1222 cd              write (iout,'(2i3,3f10.5)')
1223 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1224               endif
1225             endif
1226           enddo      ! j
1227         enddo        ! iint
1228 C Change 12/1/95
1229         num_cont(i)=num_conti
1230       enddo          ! i
1231       do i=1,nct
1232         do j=1,3
1233           gvdwc(j,i)=expon*gvdwc(j,i)
1234           gvdwx(j,i)=expon*gvdwx(j,i)
1235         enddo
1236       enddo
1237 C******************************************************************************
1238 C
1239 C                              N O T E !!!
1240 C
1241 C To save time, the factor of EXPON has been extracted from ALL components
1242 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1243 C use!
1244 C
1245 C******************************************************************************
1246       return
1247       end
1248 C-----------------------------------------------------------------------------
1249       subroutine eljk(evdw,evdw_p,evdw_m)
1250 C
1251 C This subroutine calculates the interaction energy of nonbonded side chains
1252 C assuming the LJK potential of interaction.
1253 C
1254       implicit real*8 (a-h,o-z)
1255       include 'DIMENSIONS'
1256       include 'COMMON.GEO'
1257       include 'COMMON.VAR'
1258       include 'COMMON.LOCAL'
1259       include 'COMMON.CHAIN'
1260       include 'COMMON.DERIV'
1261       include 'COMMON.INTERACT'
1262       include 'COMMON.IOUNITS'
1263       include 'COMMON.NAMES'
1264       dimension gg(3)
1265       logical scheck
1266 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1267       evdw=0.0D0
1268       do i=iatsc_s,iatsc_e
1269         itypi=itype(i)
1270         itypi1=itype(i+1)
1271         xi=c(1,nres+i)
1272         yi=c(2,nres+i)
1273         zi=c(3,nres+i)
1274 C
1275 C Calculate SC interaction energy.
1276 C
1277         do iint=1,nint_gr(i)
1278           do j=istart(i,iint),iend(i,iint)
1279             itypj=itype(j)
1280             xj=c(1,nres+j)-xi
1281             yj=c(2,nres+j)-yi
1282             zj=c(3,nres+j)-zi
1283             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1284             fac_augm=rrij**expon
1285             e_augm=augm(itypi,itypj)*fac_augm
1286             r_inv_ij=dsqrt(rrij)
1287             rij=1.0D0/r_inv_ij
1288             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1289             fac=r_shift_inv**expon
1290             e1=fac*fac*aa(itypi,itypj)
1291             e2=fac*bb(itypi,itypj)
1292             evdwij=e_augm+e1+e2
1293 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1294 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1295 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1296 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1297 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1298 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1299 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1300 #ifdef TSCSC
1301             if (bb(itypi,itypj).gt.0) then
1302                evdw_p=evdw_p+evdwij
1303             else
1304                evdw_m=evdw_m+evdwij
1305             endif
1306 #else
1307             evdw=evdw+evdwij
1308 #endif
1309 C
1310 C Calculate the components of the gradient in DC and X
1311 C
1312             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1313             gg(1)=xj*fac
1314             gg(2)=yj*fac
1315             gg(3)=zj*fac
1316 #ifdef TSCSC
1317             if (bb(itypi,itypj).gt.0.0d0) then
1318               do k=1,3
1319                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1320                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1321                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1322                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1323               enddo
1324             else
1325               do k=1,3
1326                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1327                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1328                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1329                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1330               enddo
1331             endif
1332 #else
1333             do k=1,3
1334               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1335               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1336               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1337               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1338             enddo
1339 #endif
1340 cgrad            do k=i,j-1
1341 cgrad              do l=1,3
1342 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1343 cgrad              enddo
1344 cgrad            enddo
1345           enddo      ! j
1346         enddo        ! iint
1347       enddo          ! i
1348       do i=1,nct
1349         do j=1,3
1350           gvdwc(j,i)=expon*gvdwc(j,i)
1351           gvdwx(j,i)=expon*gvdwx(j,i)
1352         enddo
1353       enddo
1354       return
1355       end
1356 C-----------------------------------------------------------------------------
1357       subroutine ebp(evdw,evdw_p,evdw_m)
1358 C
1359 C This subroutine calculates the interaction energy of nonbonded side chains
1360 C assuming the Berne-Pechukas potential of interaction.
1361 C
1362       implicit real*8 (a-h,o-z)
1363       include 'DIMENSIONS'
1364       include 'COMMON.GEO'
1365       include 'COMMON.VAR'
1366       include 'COMMON.LOCAL'
1367       include 'COMMON.CHAIN'
1368       include 'COMMON.DERIV'
1369       include 'COMMON.NAMES'
1370       include 'COMMON.INTERACT'
1371       include 'COMMON.IOUNITS'
1372       include 'COMMON.CALC'
1373       common /srutu/ icall
1374 c     double precision rrsave(maxdim)
1375       logical lprn
1376       evdw=0.0D0
1377 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1378       evdw=0.0D0
1379 c     if (icall.eq.0) then
1380 c       lprn=.true.
1381 c     else
1382         lprn=.false.
1383 c     endif
1384       ind=0
1385       do i=iatsc_s,iatsc_e
1386         itypi=itype(i)
1387         itypi1=itype(i+1)
1388         xi=c(1,nres+i)
1389         yi=c(2,nres+i)
1390         zi=c(3,nres+i)
1391         dxi=dc_norm(1,nres+i)
1392         dyi=dc_norm(2,nres+i)
1393         dzi=dc_norm(3,nres+i)
1394 c        dsci_inv=dsc_inv(itypi)
1395         dsci_inv=vbld_inv(i+nres)
1396 C
1397 C Calculate SC interaction energy.
1398 C
1399         do iint=1,nint_gr(i)
1400           do j=istart(i,iint),iend(i,iint)
1401             ind=ind+1
1402             itypj=itype(j)
1403 c            dscj_inv=dsc_inv(itypj)
1404             dscj_inv=vbld_inv(j+nres)
1405             chi1=chi(itypi,itypj)
1406             chi2=chi(itypj,itypi)
1407             chi12=chi1*chi2
1408             chip1=chip(itypi)
1409             chip2=chip(itypj)
1410             chip12=chip1*chip2
1411             alf1=alp(itypi)
1412             alf2=alp(itypj)
1413             alf12=0.5D0*(alf1+alf2)
1414 C For diagnostics only!!!
1415 c           chi1=0.0D0
1416 c           chi2=0.0D0
1417 c           chi12=0.0D0
1418 c           chip1=0.0D0
1419 c           chip2=0.0D0
1420 c           chip12=0.0D0
1421 c           alf1=0.0D0
1422 c           alf2=0.0D0
1423 c           alf12=0.0D0
1424             xj=c(1,nres+j)-xi
1425             yj=c(2,nres+j)-yi
1426             zj=c(3,nres+j)-zi
1427             dxj=dc_norm(1,nres+j)
1428             dyj=dc_norm(2,nres+j)
1429             dzj=dc_norm(3,nres+j)
1430             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1431 cd          if (icall.eq.0) then
1432 cd            rrsave(ind)=rrij
1433 cd          else
1434 cd            rrij=rrsave(ind)
1435 cd          endif
1436             rij=dsqrt(rrij)
1437 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1438             call sc_angular
1439 C Calculate whole angle-dependent part of epsilon and contributions
1440 C to its derivatives
1441             fac=(rrij*sigsq)**expon2
1442             e1=fac*fac*aa(itypi,itypj)
1443             e2=fac*bb(itypi,itypj)
1444             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1445             eps2der=evdwij*eps3rt
1446             eps3der=evdwij*eps2rt
1447             evdwij=evdwij*eps2rt*eps3rt
1448 #ifdef TSCSC
1449             if (bb(itypi,itypj).gt.0) then
1450                evdw_p=evdw_p+evdwij
1451             else
1452                evdw_m=evdw_m+evdwij
1453             endif
1454 #else
1455             evdw=evdw+evdwij
1456 #endif
1457             if (lprn) then
1458             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1459             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1460 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1461 cd     &        restyp(itypi),i,restyp(itypj),j,
1462 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1463 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1464 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1465 cd     &        evdwij
1466             endif
1467 C Calculate gradient components.
1468             e1=e1*eps1*eps2rt**2*eps3rt**2
1469             fac=-expon*(e1+evdwij)
1470             sigder=fac/sigsq
1471             fac=rrij*fac
1472 C Calculate radial part of the gradient
1473             gg(1)=xj*fac
1474             gg(2)=yj*fac
1475             gg(3)=zj*fac
1476 C Calculate the angular part of the gradient and sum add the contributions
1477 C to the appropriate components of the Cartesian gradient.
1478 #ifdef TSCSC
1479             if (bb(itypi,itypj).gt.0) then
1480                call sc_grad
1481             else
1482                call sc_grad_T
1483             endif
1484 #else
1485             call sc_grad
1486 #endif
1487           enddo      ! j
1488         enddo        ! iint
1489       enddo          ! i
1490 c     stop
1491       return
1492       end
1493 C-----------------------------------------------------------------------------
1494       subroutine egb(evdw,evdw_p,evdw_m)
1495 C
1496 C This subroutine calculates the interaction energy of nonbonded side chains
1497 C assuming the Gay-Berne potential of interaction.
1498 C
1499       implicit real*8 (a-h,o-z)
1500       include 'DIMENSIONS'
1501       include 'COMMON.GEO'
1502       include 'COMMON.VAR'
1503       include 'COMMON.LOCAL'
1504       include 'COMMON.CHAIN'
1505       include 'COMMON.DERIV'
1506       include 'COMMON.NAMES'
1507       include 'COMMON.INTERACT'
1508       include 'COMMON.IOUNITS'
1509       include 'COMMON.CALC'
1510       include 'COMMON.CONTROL'
1511       logical lprn
1512       evdw=0.0D0
1513 ccccc      energy_dec=.false.
1514 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1515       evdw=0.0D0
1516       evdw_p=0.0D0
1517       evdw_m=0.0D0
1518       lprn=.false.
1519 c     if (icall.eq.0) lprn=.false.
1520       ind=0
1521       do i=iatsc_s,iatsc_e
1522         itypi=itype(i)
1523         itypi1=itype(i+1)
1524         xi=c(1,nres+i)
1525         yi=c(2,nres+i)
1526         zi=c(3,nres+i)
1527         dxi=dc_norm(1,nres+i)
1528         dyi=dc_norm(2,nres+i)
1529         dzi=dc_norm(3,nres+i)
1530 c        dsci_inv=dsc_inv(itypi)
1531         dsci_inv=vbld_inv(i+nres)
1532 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1533 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1534 C
1535 C Calculate SC interaction energy.
1536 C
1537         do iint=1,nint_gr(i)
1538           do j=istart(i,iint),iend(i,iint)
1539             ind=ind+1
1540             itypj=itype(j)
1541 c            dscj_inv=dsc_inv(itypj)
1542             dscj_inv=vbld_inv(j+nres)
1543 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1544 c     &       1.0d0/vbld(j+nres)
1545 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1546             sig0ij=sigma(itypi,itypj)
1547             chi1=chi(itypi,itypj)
1548             chi2=chi(itypj,itypi)
1549             chi12=chi1*chi2
1550             chip1=chip(itypi)
1551             chip2=chip(itypj)
1552             chip12=chip1*chip2
1553             alf1=alp(itypi)
1554             alf2=alp(itypj)
1555             alf12=0.5D0*(alf1+alf2)
1556 C For diagnostics only!!!
1557 c           chi1=0.0D0
1558 c           chi2=0.0D0
1559 c           chi12=0.0D0
1560 c           chip1=0.0D0
1561 c           chip2=0.0D0
1562 c           chip12=0.0D0
1563 c           alf1=0.0D0
1564 c           alf2=0.0D0
1565 c           alf12=0.0D0
1566             xj=c(1,nres+j)-xi
1567             yj=c(2,nres+j)-yi
1568             zj=c(3,nres+j)-zi
1569             dxj=dc_norm(1,nres+j)
1570             dyj=dc_norm(2,nres+j)
1571             dzj=dc_norm(3,nres+j)
1572 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1573 c            write (iout,*) "j",j," dc_norm",
1574 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1575             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1576             rij=dsqrt(rrij)
1577 C Calculate angle-dependent terms of energy and contributions to their
1578 C derivatives.
1579             call sc_angular
1580             sigsq=1.0D0/sigsq
1581             sig=sig0ij*dsqrt(sigsq)
1582             rij_shift=1.0D0/rij-sig+sig0ij
1583 c for diagnostics; uncomment
1584 c            rij_shift=1.2*sig0ij
1585 C I hate to put IF's in the loops, but here don't have another choice!!!!
1586             if (rij_shift.le.0.0D0) then
1587               evdw=1.0D20
1588 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1589 cd     &        restyp(itypi),i,restyp(itypj),j,
1590 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1591               return
1592             endif
1593             sigder=-sig*sigsq
1594 c---------------------------------------------------------------
1595             rij_shift=1.0D0/rij_shift
1596             fac=rij_shift**expon
1597             e1=fac*fac*aa(itypi,itypj)
1598             e2=fac*bb(itypi,itypj)
1599             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1600             eps2der=evdwij*eps3rt
1601             eps3der=evdwij*eps2rt
1602 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1603 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1604             evdwij=evdwij*eps2rt*eps3rt
1605 #ifdef TSCSC
1606             if (bb(itypi,itypj).gt.0) then
1607                evdw_p=evdw_p+evdwij
1608             else
1609                evdw_m=evdw_m+evdwij
1610             endif
1611 #else
1612             evdw=evdw+evdwij
1613 #endif
1614             if (lprn) then
1615             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1616             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1617             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1618      &        restyp(itypi),i,restyp(itypj),j,
1619      &        epsi,sigm,chi1,chi2,chip1,chip2,
1620      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1621      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1622      &        evdwij
1623             endif
1624
1625             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1626      &                        'evdw',i,j,evdwij
1627
1628 C Calculate gradient components.
1629             e1=e1*eps1*eps2rt**2*eps3rt**2
1630             fac=-expon*(e1+evdwij)*rij_shift
1631             sigder=fac*sigder
1632             fac=rij*fac
1633 c            fac=0.0d0
1634 C Calculate the radial part of the gradient
1635             gg(1)=xj*fac
1636             gg(2)=yj*fac
1637             gg(3)=zj*fac
1638 C Calculate angular part of the gradient.
1639 #ifdef TSCSC
1640             if (bb(itypi,itypj).gt.0) then
1641                call sc_grad
1642             else
1643                call sc_grad_T
1644             endif
1645 #else
1646             call sc_grad
1647 #endif
1648           enddo      ! j
1649         enddo        ! iint
1650       enddo          ! i
1651 c      write (iout,*) "Number of loop steps in EGB:",ind
1652 cccc      energy_dec=.false.
1653       return
1654       end
1655 C-----------------------------------------------------------------------------
1656       subroutine egbv(evdw,evdw_p,evdw_m)
1657 C
1658 C This subroutine calculates the interaction energy of nonbonded side chains
1659 C assuming the Gay-Berne-Vorobjev potential of interaction.
1660 C
1661       implicit real*8 (a-h,o-z)
1662       include 'DIMENSIONS'
1663       include 'COMMON.GEO'
1664       include 'COMMON.VAR'
1665       include 'COMMON.LOCAL'
1666       include 'COMMON.CHAIN'
1667       include 'COMMON.DERIV'
1668       include 'COMMON.NAMES'
1669       include 'COMMON.INTERACT'
1670       include 'COMMON.IOUNITS'
1671       include 'COMMON.CALC'
1672       common /srutu/ icall
1673       logical lprn
1674       evdw=0.0D0
1675 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1676       evdw=0.0D0
1677       lprn=.false.
1678 c     if (icall.eq.0) lprn=.true.
1679       ind=0
1680       do i=iatsc_s,iatsc_e
1681         itypi=itype(i)
1682         itypi1=itype(i+1)
1683         xi=c(1,nres+i)
1684         yi=c(2,nres+i)
1685         zi=c(3,nres+i)
1686         dxi=dc_norm(1,nres+i)
1687         dyi=dc_norm(2,nres+i)
1688         dzi=dc_norm(3,nres+i)
1689 c        dsci_inv=dsc_inv(itypi)
1690         dsci_inv=vbld_inv(i+nres)
1691 C
1692 C Calculate SC interaction energy.
1693 C
1694         do iint=1,nint_gr(i)
1695           do j=istart(i,iint),iend(i,iint)
1696             ind=ind+1
1697             itypj=itype(j)
1698 c            dscj_inv=dsc_inv(itypj)
1699             dscj_inv=vbld_inv(j+nres)
1700             sig0ij=sigma(itypi,itypj)
1701             r0ij=r0(itypi,itypj)
1702             chi1=chi(itypi,itypj)
1703             chi2=chi(itypj,itypi)
1704             chi12=chi1*chi2
1705             chip1=chip(itypi)
1706             chip2=chip(itypj)
1707             chip12=chip1*chip2
1708             alf1=alp(itypi)
1709             alf2=alp(itypj)
1710             alf12=0.5D0*(alf1+alf2)
1711 C For diagnostics only!!!
1712 c           chi1=0.0D0
1713 c           chi2=0.0D0
1714 c           chi12=0.0D0
1715 c           chip1=0.0D0
1716 c           chip2=0.0D0
1717 c           chip12=0.0D0
1718 c           alf1=0.0D0
1719 c           alf2=0.0D0
1720 c           alf12=0.0D0
1721             xj=c(1,nres+j)-xi
1722             yj=c(2,nres+j)-yi
1723             zj=c(3,nres+j)-zi
1724             dxj=dc_norm(1,nres+j)
1725             dyj=dc_norm(2,nres+j)
1726             dzj=dc_norm(3,nres+j)
1727             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1728             rij=dsqrt(rrij)
1729 C Calculate angle-dependent terms of energy and contributions to their
1730 C derivatives.
1731             call sc_angular
1732             sigsq=1.0D0/sigsq
1733             sig=sig0ij*dsqrt(sigsq)
1734             rij_shift=1.0D0/rij-sig+r0ij
1735 C I hate to put IF's in the loops, but here don't have another choice!!!!
1736             if (rij_shift.le.0.0D0) then
1737               evdw=1.0D20
1738               return
1739             endif
1740             sigder=-sig*sigsq
1741 c---------------------------------------------------------------
1742             rij_shift=1.0D0/rij_shift
1743             fac=rij_shift**expon
1744             e1=fac*fac*aa(itypi,itypj)
1745             e2=fac*bb(itypi,itypj)
1746             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1747             eps2der=evdwij*eps3rt
1748             eps3der=evdwij*eps2rt
1749             fac_augm=rrij**expon
1750             e_augm=augm(itypi,itypj)*fac_augm
1751             evdwij=evdwij*eps2rt*eps3rt
1752 #ifdef TSCSC
1753             if (bb(itypi,itypj).gt.0) then
1754                evdw_p=evdw_p+evdwij+e_augm
1755             else
1756                evdw_m=evdw_m+evdwij+e_augm
1757             endif
1758 #else
1759             evdw=evdw+evdwij+e_augm
1760 #endif
1761             if (lprn) then
1762             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1763             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1764             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1765      &        restyp(itypi),i,restyp(itypj),j,
1766      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1767      &        chi1,chi2,chip1,chip2,
1768      &        eps1,eps2rt**2,eps3rt**2,
1769      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1770      &        evdwij+e_augm
1771             endif
1772 C Calculate gradient components.
1773             e1=e1*eps1*eps2rt**2*eps3rt**2
1774             fac=-expon*(e1+evdwij)*rij_shift
1775             sigder=fac*sigder
1776             fac=rij*fac-2*expon*rrij*e_augm
1777 C Calculate the radial part of the gradient
1778             gg(1)=xj*fac
1779             gg(2)=yj*fac
1780             gg(3)=zj*fac
1781 C Calculate angular part of the gradient.
1782 #ifdef TSCSC
1783             if (bb(itypi,itypj).gt.0) then
1784                call sc_grad
1785             else
1786                call sc_grad_T
1787             endif
1788 #else
1789             call sc_grad
1790 #endif
1791           enddo      ! j
1792         enddo        ! iint
1793       enddo          ! i
1794       end
1795 C-----------------------------------------------------------------------------
1796       subroutine sc_angular
1797 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1798 C om12. Called by ebp, egb, and egbv.
1799       implicit none
1800       include 'COMMON.CALC'
1801       include 'COMMON.IOUNITS'
1802       erij(1)=xj*rij
1803       erij(2)=yj*rij
1804       erij(3)=zj*rij
1805       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1806       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1807       om12=dxi*dxj+dyi*dyj+dzi*dzj
1808       chiom12=chi12*om12
1809 C Calculate eps1(om12) and its derivative in om12
1810       faceps1=1.0D0-om12*chiom12
1811       faceps1_inv=1.0D0/faceps1
1812       eps1=dsqrt(faceps1_inv)
1813 C Following variable is eps1*deps1/dom12
1814       eps1_om12=faceps1_inv*chiom12
1815 c diagnostics only
1816 c      faceps1_inv=om12
1817 c      eps1=om12
1818 c      eps1_om12=1.0d0
1819 c      write (iout,*) "om12",om12," eps1",eps1
1820 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1821 C and om12.
1822       om1om2=om1*om2
1823       chiom1=chi1*om1
1824       chiom2=chi2*om2
1825       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1826       sigsq=1.0D0-facsig*faceps1_inv
1827       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1828       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1829       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1830 c diagnostics only
1831 c      sigsq=1.0d0
1832 c      sigsq_om1=0.0d0
1833 c      sigsq_om2=0.0d0
1834 c      sigsq_om12=0.0d0
1835 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1836 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1837 c     &    " eps1",eps1
1838 C Calculate eps2 and its derivatives in om1, om2, and om12.
1839       chipom1=chip1*om1
1840       chipom2=chip2*om2
1841       chipom12=chip12*om12
1842       facp=1.0D0-om12*chipom12
1843       facp_inv=1.0D0/facp
1844       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1845 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1846 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1847 C Following variable is the square root of eps2
1848       eps2rt=1.0D0-facp1*facp_inv
1849 C Following three variables are the derivatives of the square root of eps
1850 C in om1, om2, and om12.
1851       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1852       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1853       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1854 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1855       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1856 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1857 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1858 c     &  " eps2rt_om12",eps2rt_om12
1859 C Calculate whole angle-dependent part of epsilon and contributions
1860 C to its derivatives
1861       return
1862       end
1863
1864 C----------------------------------------------------------------------------
1865       subroutine sc_grad_T
1866       implicit real*8 (a-h,o-z)
1867       include 'DIMENSIONS'
1868       include 'COMMON.CHAIN'
1869       include 'COMMON.DERIV'
1870       include 'COMMON.CALC'
1871       include 'COMMON.IOUNITS'
1872       double precision dcosom1(3),dcosom2(3)
1873       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1874       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1875       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1876      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1877 c diagnostics only
1878 c      eom1=0.0d0
1879 c      eom2=0.0d0
1880 c      eom12=evdwij*eps1_om12
1881 c end diagnostics
1882 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1883 c     &  " sigder",sigder
1884 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1885 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1886       do k=1,3
1887         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1888         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1889       enddo
1890       do k=1,3
1891         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1892       enddo
1893 c      write (iout,*) "gg",(gg(k),k=1,3)
1894       do k=1,3
1895         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1896      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1897      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1898         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1899      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1900      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1901 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1902 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1903 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1904 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1905       enddo
1906 C
1907 C Calculate the components of the gradient in DC and X
1908 C
1909 cgrad      do k=i,j-1
1910 cgrad        do l=1,3
1911 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1912 cgrad        enddo
1913 cgrad      enddo
1914       do l=1,3
1915         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1916         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1917       enddo
1918       return
1919       end
1920
1921 C----------------------------------------------------------------------------
1922       subroutine sc_grad
1923       implicit real*8 (a-h,o-z)
1924       include 'DIMENSIONS'
1925       include 'COMMON.CHAIN'
1926       include 'COMMON.DERIV'
1927       include 'COMMON.CALC'
1928       include 'COMMON.IOUNITS'
1929       double precision dcosom1(3),dcosom2(3)
1930       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1931       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1932       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1933      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1934 c diagnostics only
1935 c      eom1=0.0d0
1936 c      eom2=0.0d0
1937 c      eom12=evdwij*eps1_om12
1938 c end diagnostics
1939 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1940 c     &  " sigder",sigder
1941 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1942 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1943       do k=1,3
1944         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1945         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1946       enddo
1947       do k=1,3
1948         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1949       enddo
1950 c      write (iout,*) "gg",(gg(k),k=1,3)
1951       do k=1,3
1952         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1953      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1954      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1955         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1956      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1957      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1958 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1959 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1960 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1961 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1962       enddo
1963 C
1964 C Calculate the components of the gradient in DC and X
1965 C
1966 cgrad      do k=i,j-1
1967 cgrad        do l=1,3
1968 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1969 cgrad        enddo
1970 cgrad      enddo
1971       do l=1,3
1972         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1973         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1974       enddo
1975       return
1976       end
1977 C-----------------------------------------------------------------------
1978       subroutine e_softsphere(evdw)
1979 C
1980 C This subroutine calculates the interaction energy of nonbonded side chains
1981 C assuming the LJ potential of interaction.
1982 C
1983       implicit real*8 (a-h,o-z)
1984       include 'DIMENSIONS'
1985       parameter (accur=1.0d-10)
1986       include 'COMMON.GEO'
1987       include 'COMMON.VAR'
1988       include 'COMMON.LOCAL'
1989       include 'COMMON.CHAIN'
1990       include 'COMMON.DERIV'
1991       include 'COMMON.INTERACT'
1992       include 'COMMON.TORSION'
1993       include 'COMMON.SBRIDGE'
1994       include 'COMMON.NAMES'
1995       include 'COMMON.IOUNITS'
1996       include 'COMMON.CONTACTS'
1997 #ifdef MOMENT
1998       include 'COMMON.CONTACTS.MOMENT'
1999 #endif
2000       dimension gg(3)
2001 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2002       evdw=0.0D0
2003       do i=iatsc_s,iatsc_e
2004         itypi=itype(i)
2005         itypi1=itype(i+1)
2006         xi=c(1,nres+i)
2007         yi=c(2,nres+i)
2008         zi=c(3,nres+i)
2009 C
2010 C Calculate SC interaction energy.
2011 C
2012         do iint=1,nint_gr(i)
2013 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2014 cd   &                  'iend=',iend(i,iint)
2015           do j=istart(i,iint),iend(i,iint)
2016             itypj=itype(j)
2017             xj=c(1,nres+j)-xi
2018             yj=c(2,nres+j)-yi
2019             zj=c(3,nres+j)-zi
2020             rij=xj*xj+yj*yj+zj*zj
2021 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2022             r0ij=r0(itypi,itypj)
2023             r0ijsq=r0ij*r0ij
2024 c            print *,i,j,r0ij,dsqrt(rij)
2025             if (rij.lt.r0ijsq) then
2026               evdwij=0.25d0*(rij-r0ijsq)**2
2027               fac=rij-r0ijsq
2028             else
2029               evdwij=0.0d0
2030               fac=0.0d0
2031             endif
2032             evdw=evdw+evdwij
2033 C
2034 C Calculate the components of the gradient in DC and X
2035 C
2036             gg(1)=xj*fac
2037             gg(2)=yj*fac
2038             gg(3)=zj*fac
2039             do k=1,3
2040               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2041               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2042               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2043               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2044             enddo
2045 cgrad            do k=i,j-1
2046 cgrad              do l=1,3
2047 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2048 cgrad              enddo
2049 cgrad            enddo
2050           enddo ! j
2051         enddo ! iint
2052       enddo ! i
2053       return
2054       end
2055 C--------------------------------------------------------------------------
2056       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2057      &              eello_turn4)
2058 C
2059 C Soft-sphere potential of p-p interaction
2060 C
2061       implicit real*8 (a-h,o-z)
2062       include 'DIMENSIONS'
2063       include 'COMMON.CONTROL'
2064       include 'COMMON.IOUNITS'
2065       include 'COMMON.GEO'
2066       include 'COMMON.VAR'
2067       include 'COMMON.LOCAL'
2068       include 'COMMON.CHAIN'
2069       include 'COMMON.DERIV'
2070       include 'COMMON.INTERACT'
2071       include 'COMMON.CONTACTS'
2072 #ifdef MOMENT
2073       include 'COMMON.CONTACTS.MOMENT'
2074 #endif
2075       include 'COMMON.TORSION'
2076       include 'COMMON.VECTORS'
2077       include 'COMMON.FFIELD'
2078       dimension ggg(3)
2079 cd      write(iout,*) 'In EELEC_soft_sphere'
2080       ees=0.0D0
2081       evdw1=0.0D0
2082       eel_loc=0.0d0
2083       eello_turn3=0.0d0
2084       eello_turn4=0.0d0
2085       ind=0
2086       do i=iatel_s,iatel_e
2087         dxi=dc(1,i)
2088         dyi=dc(2,i)
2089         dzi=dc(3,i)
2090         xmedi=c(1,i)+0.5d0*dxi
2091         ymedi=c(2,i)+0.5d0*dyi
2092         zmedi=c(3,i)+0.5d0*dzi
2093         num_conti=0
2094 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2095         do j=ielstart(i),ielend(i)
2096           ind=ind+1
2097           iteli=itel(i)
2098           itelj=itel(j)
2099           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2100           r0ij=rpp(iteli,itelj)
2101           r0ijsq=r0ij*r0ij
2102           dxj=dc(1,j)
2103           dyj=dc(2,j)
2104           dzj=dc(3,j)
2105           xj=c(1,j)+0.5D0*dxj-xmedi
2106           yj=c(2,j)+0.5D0*dyj-ymedi
2107           zj=c(3,j)+0.5D0*dzj-zmedi
2108           rij=xj*xj+yj*yj+zj*zj
2109           if (rij.lt.r0ijsq) then
2110             evdw1ij=0.25d0*(rij-r0ijsq)**2
2111             fac=rij-r0ijsq
2112           else
2113             evdw1ij=0.0d0
2114             fac=0.0d0
2115           endif
2116           evdw1=evdw1+evdw1ij
2117 C
2118 C Calculate contributions to the Cartesian gradient.
2119 C
2120           ggg(1)=fac*xj
2121           ggg(2)=fac*yj
2122           ggg(3)=fac*zj
2123           do k=1,3
2124             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2125             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2126           enddo
2127 *
2128 * Loop over residues i+1 thru j-1.
2129 *
2130 cgrad          do k=i+1,j-1
2131 cgrad            do l=1,3
2132 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2133 cgrad            enddo
2134 cgrad          enddo
2135         enddo ! j
2136       enddo   ! i
2137 cgrad      do i=nnt,nct-1
2138 cgrad        do k=1,3
2139 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2140 cgrad        enddo
2141 cgrad        do j=i+1,nct-1
2142 cgrad          do k=1,3
2143 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2144 cgrad          enddo
2145 cgrad        enddo
2146 cgrad      enddo
2147       return
2148       end
2149 c------------------------------------------------------------------------------
2150       subroutine vec_and_deriv
2151       implicit real*8 (a-h,o-z)
2152       include 'DIMENSIONS'
2153 #ifdef MPI
2154       include 'mpif.h'
2155 #endif
2156       include 'COMMON.IOUNITS'
2157       include 'COMMON.GEO'
2158       include 'COMMON.VAR'
2159       include 'COMMON.LOCAL'
2160       include 'COMMON.CHAIN'
2161       include 'COMMON.VECTORS'
2162       include 'COMMON.SETUP'
2163       include 'COMMON.TIME1'
2164       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2165 C Compute the local reference systems. For reference system (i), the
2166 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2167 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2168 #ifdef PARVEC
2169       do i=ivec_start,ivec_end
2170 #else
2171       do i=1,nres-1
2172 #endif
2173           if (i.eq.nres-1) then
2174 C Case of the last full residue
2175 C Compute the Z-axis
2176             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2177             costh=dcos(pi-theta(nres))
2178             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2179             do k=1,3
2180               uz(k,i)=fac*uz(k,i)
2181             enddo
2182 C Compute the derivatives of uz
2183             uzder(1,1,1)= 0.0d0
2184             uzder(2,1,1)=-dc_norm(3,i-1)
2185             uzder(3,1,1)= dc_norm(2,i-1)
2186             uzder(1,2,1)= dc_norm(3,i-1)
2187             uzder(2,2,1)= 0.0d0
2188             uzder(3,2,1)=-dc_norm(1,i-1)
2189             uzder(1,3,1)=-dc_norm(2,i-1)
2190             uzder(2,3,1)= dc_norm(1,i-1)
2191             uzder(3,3,1)= 0.0d0
2192             uzder(1,1,2)= 0.0d0
2193             uzder(2,1,2)= dc_norm(3,i)
2194             uzder(3,1,2)=-dc_norm(2,i)
2195             uzder(1,2,2)=-dc_norm(3,i)
2196             uzder(2,2,2)= 0.0d0
2197             uzder(3,2,2)= dc_norm(1,i)
2198             uzder(1,3,2)= dc_norm(2,i)
2199             uzder(2,3,2)=-dc_norm(1,i)
2200             uzder(3,3,2)= 0.0d0
2201 C Compute the Y-axis
2202             facy=fac
2203             do k=1,3
2204               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2205             enddo
2206 C Compute the derivatives of uy
2207             do j=1,3
2208               do k=1,3
2209                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2210      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2211                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2212               enddo
2213               uyder(j,j,1)=uyder(j,j,1)-costh
2214               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2215             enddo
2216             do j=1,2
2217               do k=1,3
2218                 do l=1,3
2219                   uygrad(l,k,j,i)=uyder(l,k,j)
2220                   uzgrad(l,k,j,i)=uzder(l,k,j)
2221                 enddo
2222               enddo
2223             enddo
2224             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2225             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2226             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2227             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2228           else
2229 C Other residues
2230 C Compute the Z-axis
2231             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2232             costh=dcos(pi-theta(i+2))
2233             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2234             do k=1,3
2235               uz(k,i)=fac*uz(k,i)
2236             enddo
2237 C Compute the derivatives of uz
2238             uzder(1,1,1)= 0.0d0
2239             uzder(2,1,1)=-dc_norm(3,i+1)
2240             uzder(3,1,1)= dc_norm(2,i+1)
2241             uzder(1,2,1)= dc_norm(3,i+1)
2242             uzder(2,2,1)= 0.0d0
2243             uzder(3,2,1)=-dc_norm(1,i+1)
2244             uzder(1,3,1)=-dc_norm(2,i+1)
2245             uzder(2,3,1)= dc_norm(1,i+1)
2246             uzder(3,3,1)= 0.0d0
2247             uzder(1,1,2)= 0.0d0
2248             uzder(2,1,2)= dc_norm(3,i)
2249             uzder(3,1,2)=-dc_norm(2,i)
2250             uzder(1,2,2)=-dc_norm(3,i)
2251             uzder(2,2,2)= 0.0d0
2252             uzder(3,2,2)= dc_norm(1,i)
2253             uzder(1,3,2)= dc_norm(2,i)
2254             uzder(2,3,2)=-dc_norm(1,i)
2255             uzder(3,3,2)= 0.0d0
2256 C Compute the Y-axis
2257             facy=fac
2258             do k=1,3
2259               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2260             enddo
2261 C Compute the derivatives of uy
2262             do j=1,3
2263               do k=1,3
2264                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2265      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2266                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2267               enddo
2268               uyder(j,j,1)=uyder(j,j,1)-costh
2269               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2270             enddo
2271             do j=1,2
2272               do k=1,3
2273                 do l=1,3
2274                   uygrad(l,k,j,i)=uyder(l,k,j)
2275                   uzgrad(l,k,j,i)=uzder(l,k,j)
2276                 enddo
2277               enddo
2278             enddo
2279             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2280             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2281             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2282             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2283           endif
2284       enddo
2285       do i=1,nres-1
2286         vbld_inv_temp(1)=vbld_inv(i+1)
2287         if (i.lt.nres-1) then
2288           vbld_inv_temp(2)=vbld_inv(i+2)
2289           else
2290           vbld_inv_temp(2)=vbld_inv(i)
2291           endif
2292         do j=1,2
2293           do k=1,3
2294             do l=1,3
2295               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2296               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2297             enddo
2298           enddo
2299         enddo
2300       enddo
2301 #if defined(PARVEC) && defined(MPI)
2302       if (nfgtasks1.gt.1) then
2303         time00=MPI_Wtime()
2304 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2305 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2306 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2307         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2308      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2309      &   FG_COMM1,IERR)
2310         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2311      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2312      &   FG_COMM1,IERR)
2313         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2314      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2315      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2316         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2317      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2318      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2319         time_gather=time_gather+MPI_Wtime()-time00
2320       endif
2321 c      if (fg_rank.eq.0) then
2322 c        write (iout,*) "Arrays UY and UZ"
2323 c        do i=1,nres-1
2324 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2325 c     &     (uz(k,i),k=1,3)
2326 c        enddo
2327 c      endif
2328 #endif
2329       return
2330       end
2331 C-----------------------------------------------------------------------------
2332       subroutine check_vecgrad
2333       implicit real*8 (a-h,o-z)
2334       include 'DIMENSIONS'
2335       include 'COMMON.IOUNITS'
2336       include 'COMMON.GEO'
2337       include 'COMMON.VAR'
2338       include 'COMMON.LOCAL'
2339       include 'COMMON.CHAIN'
2340       include 'COMMON.VECTORS'
2341       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2342       dimension uyt(3,maxres),uzt(3,maxres)
2343       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2344       double precision delta /1.0d-7/
2345       call vec_and_deriv
2346 cd      do i=1,nres
2347 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2348 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2349 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2350 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2351 cd     &     (dc_norm(if90,i),if90=1,3)
2352 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2353 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2354 cd          write(iout,'(a)')
2355 cd      enddo
2356       do i=1,nres
2357         do j=1,2
2358           do k=1,3
2359             do l=1,3
2360               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2361               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2362             enddo
2363           enddo
2364         enddo
2365       enddo
2366       call vec_and_deriv
2367       do i=1,nres
2368         do j=1,3
2369           uyt(j,i)=uy(j,i)
2370           uzt(j,i)=uz(j,i)
2371         enddo
2372       enddo
2373       do i=1,nres
2374 cd        write (iout,*) 'i=',i
2375         do k=1,3
2376           erij(k)=dc_norm(k,i)
2377         enddo
2378         do j=1,3
2379           do k=1,3
2380             dc_norm(k,i)=erij(k)
2381           enddo
2382           dc_norm(j,i)=dc_norm(j,i)+delta
2383 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2384 c          do k=1,3
2385 c            dc_norm(k,i)=dc_norm(k,i)/fac
2386 c          enddo
2387 c          write (iout,*) (dc_norm(k,i),k=1,3)
2388 c          write (iout,*) (erij(k),k=1,3)
2389           call vec_and_deriv
2390           do k=1,3
2391             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2392             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2393             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2394             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2395           enddo
2396 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2397 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2398 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2399         enddo
2400         do k=1,3
2401           dc_norm(k,i)=erij(k)
2402         enddo
2403 cd        do k=1,3
2404 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2405 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2406 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2407 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2408 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2409 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2410 cd          write (iout,'(a)')
2411 cd        enddo
2412       enddo
2413       return
2414       end
2415 C--------------------------------------------------------------------------
2416       subroutine set_matrices
2417       implicit real*8 (a-h,o-z)
2418       include 'DIMENSIONS'
2419 #ifdef MPI
2420       include "mpif.h"
2421       include "COMMON.SETUP"
2422       integer IERR
2423       integer status(MPI_STATUS_SIZE)
2424 #endif
2425       include 'COMMON.IOUNITS'
2426       include 'COMMON.GEO'
2427       include 'COMMON.VAR'
2428       include 'COMMON.LOCAL'
2429       include 'COMMON.CHAIN'
2430       include 'COMMON.DERIV'
2431       include 'COMMON.INTERACT'
2432       include 'COMMON.CONTACTS'
2433 #ifdef MOMENT
2434       include 'COMMON.CONTACTS.MOMENT'
2435 #endif
2436       include 'COMMON.TORSION'
2437       include 'COMMON.VECTORS'
2438       include 'COMMON.FFIELD'
2439       double precision auxvec(2),auxmat(2,2)
2440 C
2441 C Compute the virtual-bond-torsional-angle dependent quantities needed
2442 C to calculate the el-loc multibody terms of various order.
2443 C
2444 #ifdef PARMAT
2445       do i=ivec_start+2,ivec_end+2
2446 #else
2447       do i=3,nres+1
2448 #endif
2449         if (i .lt. nres+1) then
2450           sin1=dsin(phi(i))
2451           cos1=dcos(phi(i))
2452           sintab(i-2)=sin1
2453           costab(i-2)=cos1
2454           obrot(1,i-2)=cos1
2455           obrot(2,i-2)=sin1
2456           sin2=dsin(2*phi(i))
2457           cos2=dcos(2*phi(i))
2458           sintab2(i-2)=sin2
2459           costab2(i-2)=cos2
2460           obrot2(1,i-2)=cos2
2461           obrot2(2,i-2)=sin2
2462           Ug(1,1,i-2)=-cos1
2463           Ug(1,2,i-2)=-sin1
2464           Ug(2,1,i-2)=-sin1
2465           Ug(2,2,i-2)= cos1
2466           Ug2(1,1,i-2)=-cos2
2467           Ug2(1,2,i-2)=-sin2
2468           Ug2(2,1,i-2)=-sin2
2469           Ug2(2,2,i-2)= cos2
2470         else
2471           costab(i-2)=1.0d0
2472           sintab(i-2)=0.0d0
2473           obrot(1,i-2)=1.0d0
2474           obrot(2,i-2)=0.0d0
2475           obrot2(1,i-2)=0.0d0
2476           obrot2(2,i-2)=0.0d0
2477           Ug(1,1,i-2)=1.0d0
2478           Ug(1,2,i-2)=0.0d0
2479           Ug(2,1,i-2)=0.0d0
2480           Ug(2,2,i-2)=1.0d0
2481           Ug2(1,1,i-2)=0.0d0
2482           Ug2(1,2,i-2)=0.0d0
2483           Ug2(2,1,i-2)=0.0d0
2484           Ug2(2,2,i-2)=0.0d0
2485         endif
2486         if (i .gt. 3 .and. i .lt. nres+1) then
2487           obrot_der(1,i-2)=-sin1
2488           obrot_der(2,i-2)= cos1
2489           Ugder(1,1,i-2)= sin1
2490           Ugder(1,2,i-2)=-cos1
2491           Ugder(2,1,i-2)=-cos1
2492           Ugder(2,2,i-2)=-sin1
2493           dwacos2=cos2+cos2
2494           dwasin2=sin2+sin2
2495           obrot2_der(1,i-2)=-dwasin2
2496           obrot2_der(2,i-2)= dwacos2
2497           Ug2der(1,1,i-2)= dwasin2
2498           Ug2der(1,2,i-2)=-dwacos2
2499           Ug2der(2,1,i-2)=-dwacos2
2500           Ug2der(2,2,i-2)=-dwasin2
2501         else
2502           obrot_der(1,i-2)=0.0d0
2503           obrot_der(2,i-2)=0.0d0
2504           Ugder(1,1,i-2)=0.0d0
2505           Ugder(1,2,i-2)=0.0d0
2506           Ugder(2,1,i-2)=0.0d0
2507           Ugder(2,2,i-2)=0.0d0
2508           obrot2_der(1,i-2)=0.0d0
2509           obrot2_der(2,i-2)=0.0d0
2510           Ug2der(1,1,i-2)=0.0d0
2511           Ug2der(1,2,i-2)=0.0d0
2512           Ug2der(2,1,i-2)=0.0d0
2513           Ug2der(2,2,i-2)=0.0d0
2514         endif
2515 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2516         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2517           iti = itortyp(itype(i-2))
2518         else
2519           iti=ntortyp+1
2520         endif
2521 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2522         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2523           iti1 = itortyp(itype(i-1))
2524         else
2525           iti1=ntortyp+1
2526         endif
2527 cd        write (iout,*) '*******i',i,' iti1',iti
2528 cd        write (iout,*) 'b1',b1(:,iti)
2529 cd        write (iout,*) 'b2',b2(:,iti)
2530 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2531 c        if (i .gt. iatel_s+2) then
2532         if (i .gt. nnt+2) then
2533           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2534           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2535           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2536      &    then
2537           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2538           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2539           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2540           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2541           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2542           endif
2543         else
2544           do k=1,2
2545             Ub2(k,i-2)=0.0d0
2546             Ctobr(k,i-2)=0.0d0
2547             Dtobr2(k,i-2)=0.0d0
2548             do l=1,2
2549               EUg(l,k,i-2)=0.0d0
2550               CUg(l,k,i-2)=0.0d0
2551               DUg(l,k,i-2)=0.0d0
2552               DtUg2(l,k,i-2)=0.0d0
2553             enddo
2554           enddo
2555         endif
2556         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2557         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2558         do k=1,2
2559           muder(k,i-2)=Ub2der(k,i-2)
2560         enddo
2561 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2562         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2563           iti1 = itortyp(itype(i-1))
2564         else
2565           iti1=ntortyp+1
2566         endif
2567         do k=1,2
2568           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2569         enddo
2570 cd        write (iout,*) 'mu ',mu(:,i-2)
2571 cd        write (iout,*) 'mu1',mu1(:,i-2)
2572 cd        write (iout,*) 'mu2',mu2(:,i-2)
2573         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2574      &  then
2575         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2576         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2577         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2578         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2579         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2580 C Vectors and matrices dependent on a single virtual-bond dihedral.
2581         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2582         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2583         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2584         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2585         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2586         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2587         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2588         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2589         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2590         endif
2591       enddo
2592 C Matrices dependent on two consecutive virtual-bond dihedrals.
2593 C The order of matrices is from left to right.
2594       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2595      &then
2596 c      do i=max0(ivec_start,2),ivec_end
2597       do i=2,nres-1
2598         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2599         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2600         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2601         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2602         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2603         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2604         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2605         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2606       enddo
2607       endif
2608 #if defined(MPI) && defined(PARMAT)
2609 #ifdef DEBUG
2610 c      if (fg_rank.eq.0) then
2611         write (iout,*) "Arrays UG and UGDER before GATHER"
2612         do i=1,nres-1
2613           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2614      &     ((ug(l,k,i),l=1,2),k=1,2),
2615      &     ((ugder(l,k,i),l=1,2),k=1,2)
2616         enddo
2617         write (iout,*) "Arrays UG2 and UG2DER"
2618         do i=1,nres-1
2619           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2620      &     ((ug2(l,k,i),l=1,2),k=1,2),
2621      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2622         enddo
2623         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2624         do i=1,nres-1
2625           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2626      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2627      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2628         enddo
2629         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2630         do i=1,nres-1
2631           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2632      &     costab(i),sintab(i),costab2(i),sintab2(i)
2633         enddo
2634         write (iout,*) "Array MUDER"
2635         do i=1,nres-1
2636           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2637         enddo
2638 c      endif
2639 #endif
2640       if (nfgtasks.gt.1) then
2641         time00=MPI_Wtime()
2642 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2643 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2644 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2645 #ifdef MATGATHER
2646         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2647      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2648      &   FG_COMM1,IERR)
2649         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2650      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2651      &   FG_COMM1,IERR)
2652         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2653      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2654      &   FG_COMM1,IERR)
2655         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2656      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2657      &   FG_COMM1,IERR)
2658         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2659      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2660      &   FG_COMM1,IERR)
2661         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2662      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2663      &   FG_COMM1,IERR)
2664         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2665      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2666      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2667         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2668      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2669      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2670         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2671      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2672      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2673         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2674      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2675      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2676         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2677      &  then
2678         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2679      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2680      &   FG_COMM1,IERR)
2681         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2682      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2683      &   FG_COMM1,IERR)
2684         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2685      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2686      &   FG_COMM1,IERR)
2687        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2688      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2689      &   FG_COMM1,IERR)
2690         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2691      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2692      &   FG_COMM1,IERR)
2693         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2694      &   ivec_count(fg_rank1),
2695      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2704      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2705      &   FG_COMM1,IERR)
2706         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2707      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2708      &   FG_COMM1,IERR)
2709         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2710      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2711      &   FG_COMM1,IERR)
2712         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2713      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2714      &   FG_COMM1,IERR)
2715         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2716      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2717      &   FG_COMM1,IERR)
2718         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2719      &   ivec_count(fg_rank1),
2720      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2721      &   FG_COMM1,IERR)
2722         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2723      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2724      &   FG_COMM1,IERR)
2725        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2730      &   FG_COMM1,IERR)
2731        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2735      &   ivec_count(fg_rank1),
2736      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2737      &   FG_COMM1,IERR)
2738         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2739      &   ivec_count(fg_rank1),
2740      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2743      &   ivec_count(fg_rank1),
2744      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2745      &   MPI_MAT2,FG_COMM1,IERR)
2746         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2747      &   ivec_count(fg_rank1),
2748      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2749      &   MPI_MAT2,FG_COMM1,IERR)
2750         endif
2751 #else
2752 c Passes matrix info through the ring
2753       isend=fg_rank1
2754       irecv=fg_rank1-1
2755       if (irecv.lt.0) irecv=nfgtasks1-1
2756       iprev=irecv
2757       inext=fg_rank1+1
2758       if (inext.ge.nfgtasks1) inext=0
2759       do i=1,nfgtasks1-1
2760 c        write (iout,*) "isend",isend," irecv",irecv
2761 c        call flush(iout)
2762         lensend=lentyp(isend)
2763         lenrecv=lentyp(irecv)
2764 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2765 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2766 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2767 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2768 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2769 c        write (iout,*) "Gather ROTAT1"
2770 c        call flush(iout)
2771 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2772 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2773 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2774 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2775 c        write (iout,*) "Gather ROTAT2"
2776 c        call flush(iout)
2777         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2778      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2779      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2780      &   iprev,4400+irecv,FG_COMM,status,IERR)
2781 c        write (iout,*) "Gather ROTAT_OLD"
2782 c        call flush(iout)
2783         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2784      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2785      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2786      &   iprev,5500+irecv,FG_COMM,status,IERR)
2787 c        write (iout,*) "Gather PRECOMP11"
2788 c        call flush(iout)
2789         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2790      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2791      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2792      &   iprev,6600+irecv,FG_COMM,status,IERR)
2793 c        write (iout,*) "Gather PRECOMP12"
2794 c        call flush(iout)
2795         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2796      &  then
2797         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2798      &   MPI_ROTAT2(lensend),inext,7700+isend,
2799      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2800      &   iprev,7700+irecv,FG_COMM,status,IERR)
2801 c        write (iout,*) "Gather PRECOMP21"
2802 c        call flush(iout)
2803         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2804      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2805      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2806      &   iprev,8800+irecv,FG_COMM,status,IERR)
2807 c        write (iout,*) "Gather PRECOMP22"
2808 c        call flush(iout)
2809         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2810      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2811      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2812      &   MPI_PRECOMP23(lenrecv),
2813      &   iprev,9900+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather PRECOMP23"
2815 c        call flush(iout)
2816         endif
2817         isend=irecv
2818         irecv=irecv-1
2819         if (irecv.lt.0) irecv=nfgtasks1-1
2820       enddo
2821 #endif
2822         time_gather=time_gather+MPI_Wtime()-time00
2823       endif
2824 #ifdef DEBUG
2825 c      if (fg_rank.eq.0) then
2826         write (iout,*) "Arrays UG and UGDER"
2827         do i=1,nres-1
2828           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2829      &     ((ug(l,k,i),l=1,2),k=1,2),
2830      &     ((ugder(l,k,i),l=1,2),k=1,2)
2831         enddo
2832         write (iout,*) "Arrays UG2 and UG2DER"
2833         do i=1,nres-1
2834           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2835      &     ((ug2(l,k,i),l=1,2),k=1,2),
2836      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2837         enddo
2838         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2839         do i=1,nres-1
2840           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2841      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2842      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2843         enddo
2844         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2845         do i=1,nres-1
2846           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2847      &     costab(i),sintab(i),costab2(i),sintab2(i)
2848         enddo
2849         write (iout,*) "Array MUDER"
2850         do i=1,nres-1
2851           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2852         enddo
2853 c      endif
2854 #endif
2855 #endif
2856 cd      do i=1,nres
2857 cd        iti = itortyp(itype(i))
2858 cd        write (iout,*) i
2859 cd        do j=1,2
2860 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2861 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2862 cd        enddo
2863 cd      enddo
2864       return
2865       end
2866 C--------------------------------------------------------------------------
2867       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2868 C
2869 C This subroutine calculates the average interaction energy and its gradient
2870 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2871 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2872 C The potential depends both on the distance of peptide-group centers and on
2873 C the orientation of the CA-CA virtual bonds.
2874 C
2875       implicit real*8 (a-h,o-z)
2876 #ifdef MPI
2877       include 'mpif.h'
2878 #endif
2879       include 'DIMENSIONS'
2880       include 'COMMON.CONTROL'
2881       include 'COMMON.SETUP'
2882       include 'COMMON.IOUNITS'
2883       include 'COMMON.GEO'
2884       include 'COMMON.VAR'
2885       include 'COMMON.LOCAL'
2886       include 'COMMON.CHAIN'
2887       include 'COMMON.DERIV'
2888       include 'COMMON.INTERACT'
2889       include 'COMMON.CONTACTS'
2890 #ifdef MOMENT
2891       include 'COMMON.CONTACTS.MOMENT'
2892 #endif
2893       include 'COMMON.TORSION'
2894       include 'COMMON.VECTORS'
2895       include 'COMMON.FFIELD'
2896       include 'COMMON.TIME1'
2897       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2898      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2899       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2900      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2901       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2902      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2903      &    num_conti,j1,j2
2904 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2905 #ifdef MOMENT
2906       double precision scal_el /1.0d0/
2907 #else
2908       double precision scal_el /0.5d0/
2909 #endif
2910 C 12/13/98
2911 C 13-go grudnia roku pamietnego...
2912       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2913      &                   0.0d0,1.0d0,0.0d0,
2914      &                   0.0d0,0.0d0,1.0d0/
2915 cd      write(iout,*) 'In EELEC'
2916 cd      do i=1,nloctyp
2917 cd        write(iout,*) 'Type',i
2918 cd        write(iout,*) 'B1',B1(:,i)
2919 cd        write(iout,*) 'B2',B2(:,i)
2920 cd        write(iout,*) 'CC',CC(:,:,i)
2921 cd        write(iout,*) 'DD',DD(:,:,i)
2922 cd        write(iout,*) 'EE',EE(:,:,i)
2923 cd      enddo
2924 cd      call check_vecgrad
2925 cd      stop
2926       if (icheckgrad.eq.1) then
2927         do i=1,nres-1
2928           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2929           do k=1,3
2930             dc_norm(k,i)=dc(k,i)*fac
2931           enddo
2932 c          write (iout,*) 'i',i,' fac',fac
2933         enddo
2934       endif
2935       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2936      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2937      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2938 c        call vec_and_deriv
2939 #ifdef TIMING
2940         time01=MPI_Wtime()
2941 #endif
2942         call set_matrices
2943 #ifdef TIMING
2944         time_mat=time_mat+MPI_Wtime()-time01
2945 #endif
2946       endif
2947 cd      do i=1,nres-1
2948 cd        write (iout,*) 'i=',i
2949 cd        do k=1,3
2950 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2951 cd        enddo
2952 cd        do k=1,3
2953 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2954 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2955 cd        enddo
2956 cd      enddo
2957       t_eelecij=0.0d0
2958       ees=0.0D0
2959       evdw1=0.0D0
2960       eel_loc=0.0d0
2961       eello_turn3=0.0d0
2962       eello_turn4=0.0d0
2963       ind=0
2964       do i=1,nres
2965         num_cont_hb(i)=0
2966       enddo
2967 cd      print '(a)','Enter EELEC'
2968 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2969       do i=1,nres
2970         gel_loc_loc(i)=0.0d0
2971         gcorr_loc(i)=0.0d0
2972       enddo
2973 c
2974 c
2975 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2976 C
2977 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2978 C
2979       do i=iturn3_start,iturn3_end
2980         dxi=dc(1,i)
2981         dyi=dc(2,i)
2982         dzi=dc(3,i)
2983         dx_normi=dc_norm(1,i)
2984         dy_normi=dc_norm(2,i)
2985         dz_normi=dc_norm(3,i)
2986         xmedi=c(1,i)+0.5d0*dxi
2987         ymedi=c(2,i)+0.5d0*dyi
2988         zmedi=c(3,i)+0.5d0*dzi
2989         num_conti=0
2990         call eelecij(i,i+2,ees,evdw1,eel_loc)
2991         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2992         num_cont_hb(i)=num_conti
2993       enddo
2994       do i=iturn4_start,iturn4_end
2995         dxi=dc(1,i)
2996         dyi=dc(2,i)
2997         dzi=dc(3,i)
2998         dx_normi=dc_norm(1,i)
2999         dy_normi=dc_norm(2,i)
3000         dz_normi=dc_norm(3,i)
3001         xmedi=c(1,i)+0.5d0*dxi
3002         ymedi=c(2,i)+0.5d0*dyi
3003         zmedi=c(3,i)+0.5d0*dzi
3004         num_conti=num_cont_hb(i)
3005         call eelecij(i,i+3,ees,evdw1,eel_loc)
3006         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3007         num_cont_hb(i)=num_conti
3008       enddo   ! i
3009 c
3010 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3011 c
3012       do i=iatel_s,iatel_e
3013         dxi=dc(1,i)
3014         dyi=dc(2,i)
3015         dzi=dc(3,i)
3016         dx_normi=dc_norm(1,i)
3017         dy_normi=dc_norm(2,i)
3018         dz_normi=dc_norm(3,i)
3019         xmedi=c(1,i)+0.5d0*dxi
3020         ymedi=c(2,i)+0.5d0*dyi
3021         zmedi=c(3,i)+0.5d0*dzi
3022 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3023         num_conti=num_cont_hb(i)
3024         do j=ielstart(i),ielend(i)
3025           call eelecij(i,j,ees,evdw1,eel_loc)
3026         enddo ! j
3027         num_cont_hb(i)=num_conti
3028       enddo   ! i
3029 c      write (iout,*) "Number of loop steps in EELEC:",ind
3030 cd      do i=1,nres
3031 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3032 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3033 cd      enddo
3034 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3035 ccc      eel_loc=eel_loc+eello_turn3
3036 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3037       return
3038       end
3039 C-------------------------------------------------------------------------------
3040       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3041       implicit real*8 (a-h,o-z)
3042       include 'DIMENSIONS'
3043 #ifdef MPI
3044       include "mpif.h"
3045 #endif
3046       include 'COMMON.CONTROL'
3047       include 'COMMON.IOUNITS'
3048       include 'COMMON.GEO'
3049       include 'COMMON.VAR'
3050       include 'COMMON.LOCAL'
3051       include 'COMMON.CHAIN'
3052       include 'COMMON.DERIV'
3053       include 'COMMON.INTERACT'
3054       include 'COMMON.CONTACTS'
3055 #ifdef MOMENT
3056       include 'COMMON.CONTACTS.MOMENT'
3057 #endif
3058       include 'COMMON.TORSION'
3059       include 'COMMON.VECTORS'
3060       include 'COMMON.FFIELD'
3061       include 'COMMON.TIME1'
3062       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3063      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3064       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3065      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3066       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3067      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3068      &    num_conti,j1,j2
3069 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3070 #ifdef MOMENT
3071       double precision scal_el /1.0d0/
3072 #else
3073       double precision scal_el /0.5d0/
3074 #endif
3075 C 12/13/98
3076 C 13-go grudnia roku pamietnego...
3077       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3078      &                   0.0d0,1.0d0,0.0d0,
3079      &                   0.0d0,0.0d0,1.0d0/
3080 c          time00=MPI_Wtime()
3081 cd      write (iout,*) "eelecij",i,j
3082 c          ind=ind+1
3083           iteli=itel(i)
3084           itelj=itel(j)
3085           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3086           aaa=app(iteli,itelj)
3087           bbb=bpp(iteli,itelj)
3088           ael6i=ael6(iteli,itelj)
3089           ael3i=ael3(iteli,itelj)
3090           dxj=dc(1,j)
3091           dyj=dc(2,j)
3092           dzj=dc(3,j)
3093           dx_normj=dc_norm(1,j)
3094           dy_normj=dc_norm(2,j)
3095           dz_normj=dc_norm(3,j)
3096           xj=c(1,j)+0.5D0*dxj-xmedi
3097           yj=c(2,j)+0.5D0*dyj-ymedi
3098           zj=c(3,j)+0.5D0*dzj-zmedi
3099           rij=xj*xj+yj*yj+zj*zj
3100           rrmij=1.0D0/rij
3101           rij=dsqrt(rij)
3102           rmij=1.0D0/rij
3103           r3ij=rrmij*rmij
3104           r6ij=r3ij*r3ij
3105           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3106           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3107           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3108           fac=cosa-3.0D0*cosb*cosg
3109           ev1=aaa*r6ij*r6ij
3110 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3111           if (j.eq.i+2) ev1=scal_el*ev1
3112           ev2=bbb*r6ij
3113           fac3=ael6i*r6ij
3114           fac4=ael3i*r3ij
3115           evdwij=ev1+ev2
3116           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3117           el2=fac4*fac
3118           eesij=el1+el2
3119 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3120           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3121           ees=ees+eesij
3122           evdw1=evdw1+evdwij
3123 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3124 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3125 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3126 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3127
3128           if (energy_dec) then
3129               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3130               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3131           endif
3132
3133 C
3134 C Calculate contributions to the Cartesian gradient.
3135 C
3136 #ifdef SPLITELE
3137           facvdw=-6*rrmij*(ev1+evdwij)
3138           facel=-3*rrmij*(el1+eesij)
3139           fac1=fac
3140           erij(1)=xj*rmij
3141           erij(2)=yj*rmij
3142           erij(3)=zj*rmij
3143 *
3144 * Radial derivatives. First process both termini of the fragment (i,j)
3145 *
3146           ggg(1)=facel*xj
3147           ggg(2)=facel*yj
3148           ggg(3)=facel*zj
3149 c          do k=1,3
3150 c            ghalf=0.5D0*ggg(k)
3151 c            gelc(k,i)=gelc(k,i)+ghalf
3152 c            gelc(k,j)=gelc(k,j)+ghalf
3153 c          enddo
3154 c 9/28/08 AL Gradient compotents will be summed only at the end
3155           do k=1,3
3156             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3157             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3158           enddo
3159 *
3160 * Loop over residues i+1 thru j-1.
3161 *
3162 cgrad          do k=i+1,j-1
3163 cgrad            do l=1,3
3164 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3165 cgrad            enddo
3166 cgrad          enddo
3167           ggg(1)=facvdw*xj
3168           ggg(2)=facvdw*yj
3169           ggg(3)=facvdw*zj
3170 c          do k=1,3
3171 c            ghalf=0.5D0*ggg(k)
3172 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3173 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3174 c          enddo
3175 c 9/28/08 AL Gradient compotents will be summed only at the end
3176           do k=1,3
3177             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3178             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3179           enddo
3180 *
3181 * Loop over residues i+1 thru j-1.
3182 *
3183 cgrad          do k=i+1,j-1
3184 cgrad            do l=1,3
3185 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3186 cgrad            enddo
3187 cgrad          enddo
3188 #else
3189           facvdw=ev1+evdwij
3190           facel=el1+eesij
3191           fac1=fac
3192           fac=-3*rrmij*(facvdw+facvdw+facel)
3193           erij(1)=xj*rmij
3194           erij(2)=yj*rmij
3195           erij(3)=zj*rmij
3196 *
3197 * Radial derivatives. First process both termini of the fragment (i,j)
3198 *
3199           ggg(1)=fac*xj
3200           ggg(2)=fac*yj
3201           ggg(3)=fac*zj
3202 c          do k=1,3
3203 c            ghalf=0.5D0*ggg(k)
3204 c            gelc(k,i)=gelc(k,i)+ghalf
3205 c            gelc(k,j)=gelc(k,j)+ghalf
3206 c          enddo
3207 c 9/28/08 AL Gradient compotents will be summed only at the end
3208           do k=1,3
3209             gelc_long(k,j)=gelc(k,j)+ggg(k)
3210             gelc_long(k,i)=gelc(k,i)-ggg(k)
3211           enddo
3212 *
3213 * Loop over residues i+1 thru j-1.
3214 *
3215 cgrad          do k=i+1,j-1
3216 cgrad            do l=1,3
3217 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3218 cgrad            enddo
3219 cgrad          enddo
3220 c 9/28/08 AL Gradient compotents will be summed only at the end
3221           ggg(1)=facvdw*xj
3222           ggg(2)=facvdw*yj
3223           ggg(3)=facvdw*zj
3224           do k=1,3
3225             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3226             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3227           enddo
3228 #endif
3229 *
3230 * Angular part
3231 *
3232           ecosa=2.0D0*fac3*fac1+fac4
3233           fac4=-3.0D0*fac4
3234           fac3=-6.0D0*fac3
3235           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3236           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3237           do k=1,3
3238             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3239             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3240           enddo
3241 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3242 cd   &          (dcosg(k),k=1,3)
3243           do k=1,3
3244             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3245           enddo
3246 c          do k=1,3
3247 c            ghalf=0.5D0*ggg(k)
3248 c            gelc(k,i)=gelc(k,i)+ghalf
3249 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3250 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3251 c            gelc(k,j)=gelc(k,j)+ghalf
3252 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3253 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3254 c          enddo
3255 cgrad          do k=i+1,j-1
3256 cgrad            do l=1,3
3257 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3258 cgrad            enddo
3259 cgrad          enddo
3260           do k=1,3
3261             gelc(k,i)=gelc(k,i)
3262      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3263      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3264             gelc(k,j)=gelc(k,j)
3265      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3266      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3267             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3268             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3269           enddo
3270           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3271      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3272      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3273 C
3274 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3275 C   energy of a peptide unit is assumed in the form of a second-order
3276 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3277 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3278 C   are computed for EVERY pair of non-contiguous peptide groups.
3279 C
3280           if (j.lt.nres-1) then
3281             j1=j+1
3282             j2=j-1
3283           else
3284             j1=j-1
3285             j2=j-2
3286           endif
3287           kkk=0
3288           do k=1,2
3289             do l=1,2
3290               kkk=kkk+1
3291               muij(kkk)=mu(k,i)*mu(l,j)
3292             enddo
3293           enddo
3294 cd         write (iout,*) 'EELEC: i',i,' j',j
3295 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3296 cd          write(iout,*) 'muij',muij
3297           ury=scalar(uy(1,i),erij)
3298           urz=scalar(uz(1,i),erij)
3299           vry=scalar(uy(1,j),erij)
3300           vrz=scalar(uz(1,j),erij)
3301           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3302           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3303           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3304           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3305           fac=dsqrt(-ael6i)*r3ij
3306           a22=a22*fac
3307           a23=a23*fac
3308           a32=a32*fac
3309           a33=a33*fac
3310 cd          write (iout,'(4i5,4f10.5)')
3311 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3312 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3313 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3314 cd     &      uy(:,j),uz(:,j)
3315 cd          write (iout,'(4f10.5)')
3316 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3317 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3318 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3319 cd           write (iout,'(9f10.5/)')
3320 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3321 C Derivatives of the elements of A in virtual-bond vectors
3322           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3323           do k=1,3
3324             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3325             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3326             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3327             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3328             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3329             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3330             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3331             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3332             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3333             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3334             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3335             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3336           enddo
3337 C Compute radial contributions to the gradient
3338           facr=-3.0d0*rrmij
3339           a22der=a22*facr
3340           a23der=a23*facr
3341           a32der=a32*facr
3342           a33der=a33*facr
3343           agg(1,1)=a22der*xj
3344           agg(2,1)=a22der*yj
3345           agg(3,1)=a22der*zj
3346           agg(1,2)=a23der*xj
3347           agg(2,2)=a23der*yj
3348           agg(3,2)=a23der*zj
3349           agg(1,3)=a32der*xj
3350           agg(2,3)=a32der*yj
3351           agg(3,3)=a32der*zj
3352           agg(1,4)=a33der*xj
3353           agg(2,4)=a33der*yj
3354           agg(3,4)=a33der*zj
3355 C Add the contributions coming from er
3356           fac3=-3.0d0*fac
3357           do k=1,3
3358             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3359             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3360             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3361             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3362           enddo
3363           do k=1,3
3364 C Derivatives in DC(i)
3365 cgrad            ghalf1=0.5d0*agg(k,1)
3366 cgrad            ghalf2=0.5d0*agg(k,2)
3367 cgrad            ghalf3=0.5d0*agg(k,3)
3368 cgrad            ghalf4=0.5d0*agg(k,4)
3369             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3370      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3371             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3372      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3373             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3374      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3375             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3376      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3377 C Derivatives in DC(i+1)
3378             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3379      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3380             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3381      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3382             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3383      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3384             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3385      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3386 C Derivatives in DC(j)
3387             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3388      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3389             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3390      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3391             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3392      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3393             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3394      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3395 C Derivatives in DC(j+1) or DC(nres-1)
3396             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3397      &      -3.0d0*vryg(k,3)*ury)
3398             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3399      &      -3.0d0*vrzg(k,3)*ury)
3400             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3401      &      -3.0d0*vryg(k,3)*urz)
3402             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3403      &      -3.0d0*vrzg(k,3)*urz)
3404 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3405 cgrad              do l=1,4
3406 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3407 cgrad              enddo
3408 cgrad            endif
3409           enddo
3410           acipa(1,1)=a22
3411           acipa(1,2)=a23
3412           acipa(2,1)=a32
3413           acipa(2,2)=a33
3414           a22=-a22
3415           a23=-a23
3416           do l=1,2
3417             do k=1,3
3418               agg(k,l)=-agg(k,l)
3419               aggi(k,l)=-aggi(k,l)
3420               aggi1(k,l)=-aggi1(k,l)
3421               aggj(k,l)=-aggj(k,l)
3422               aggj1(k,l)=-aggj1(k,l)
3423             enddo
3424           enddo
3425           if (j.lt.nres-1) then
3426             a22=-a22
3427             a32=-a32
3428             do l=1,3,2
3429               do k=1,3
3430                 agg(k,l)=-agg(k,l)
3431                 aggi(k,l)=-aggi(k,l)
3432                 aggi1(k,l)=-aggi1(k,l)
3433                 aggj(k,l)=-aggj(k,l)
3434                 aggj1(k,l)=-aggj1(k,l)
3435               enddo
3436             enddo
3437           else
3438             a22=-a22
3439             a23=-a23
3440             a32=-a32
3441             a33=-a33
3442             do l=1,4
3443               do k=1,3
3444                 agg(k,l)=-agg(k,l)
3445                 aggi(k,l)=-aggi(k,l)
3446                 aggi1(k,l)=-aggi1(k,l)
3447                 aggj(k,l)=-aggj(k,l)
3448                 aggj1(k,l)=-aggj1(k,l)
3449               enddo
3450             enddo
3451           endif
3452           ENDIF ! WCORR
3453           IF (wel_loc.gt.0.0d0) THEN
3454 C Contribution to the local-electrostatic energy coming from the i-j pair
3455           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3456      &     +a33*muij(4)
3457 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3458
3459           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3460      &            'eelloc',i,j,eel_loc_ij
3461
3462           eel_loc=eel_loc+eel_loc_ij
3463 C Partial derivatives in virtual-bond dihedral angles gamma
3464           if (i.gt.1)
3465      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3466      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3467      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3468           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3469      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3470      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3471 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3472           do l=1,3
3473             ggg(l)=agg(l,1)*muij(1)+
3474      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3475             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3476             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3477 cgrad            ghalf=0.5d0*ggg(l)
3478 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3479 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3480           enddo
3481 cgrad          do k=i+1,j2
3482 cgrad            do l=1,3
3483 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3484 cgrad            enddo
3485 cgrad          enddo
3486 C Remaining derivatives of eello
3487           do l=1,3
3488             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3489      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3490             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3491      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3492             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3493      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3494             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3495      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3496           enddo
3497           ENDIF
3498 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3499 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3500           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3501      &       .and. num_conti.le.maxconts) then
3502 c            write (iout,*) i,j," entered corr"
3503 C
3504 C Calculate the contact function. The ith column of the array JCONT will
3505 C contain the numbers of atoms that make contacts with the atom I (of numbers
3506 C greater than I). The arrays FACONT and GACONT will contain the values of
3507 C the contact function and its derivative.
3508 c           r0ij=1.02D0*rpp(iteli,itelj)
3509 c           r0ij=1.11D0*rpp(iteli,itelj)
3510             r0ij=2.20D0*rpp(iteli,itelj)
3511 c           r0ij=1.55D0*rpp(iteli,itelj)
3512             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3513             if (fcont.gt.0.0D0) then
3514               num_conti=num_conti+1
3515               if (num_conti.gt.maxconts) then
3516                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3517      &                         ' will skip next contacts for this conf.'
3518               else
3519                 jcont_hb(num_conti,i)=j
3520 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3521 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3522                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3523      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3524 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3525 C  terms.
3526                 d_cont(num_conti,i)=rij
3527 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3528 C     --- Electrostatic-interaction matrix ---
3529                 a_chuj(1,1,num_conti,i)=a22
3530                 a_chuj(1,2,num_conti,i)=a23
3531                 a_chuj(2,1,num_conti,i)=a32
3532                 a_chuj(2,2,num_conti,i)=a33
3533 C     --- Gradient of rij
3534                 do kkk=1,3
3535                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3536                 enddo
3537                 kkll=0
3538                 do k=1,2
3539                   do l=1,2
3540                     kkll=kkll+1
3541                     do m=1,3
3542                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3543                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3544                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3545                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3546                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3547                     enddo
3548                   enddo
3549                 enddo
3550                 ENDIF
3551                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3552 C Calculate contact energies
3553                 cosa4=4.0D0*cosa
3554                 wij=cosa-3.0D0*cosb*cosg
3555                 cosbg1=cosb+cosg
3556                 cosbg2=cosb-cosg
3557 c               fac3=dsqrt(-ael6i)/r0ij**3
3558                 fac3=dsqrt(-ael6i)*r3ij
3559 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3560                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3561                 if (ees0tmp.gt.0) then
3562                   ees0pij=dsqrt(ees0tmp)
3563                 else
3564                   ees0pij=0
3565                 endif
3566 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3567                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3568                 if (ees0tmp.gt.0) then
3569                   ees0mij=dsqrt(ees0tmp)
3570                 else
3571                   ees0mij=0
3572                 endif
3573 c               ees0mij=0.0D0
3574                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3575                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3576 C Diagnostics. Comment out or remove after debugging!
3577 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3578 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3579 c               ees0m(num_conti,i)=0.0D0
3580 C End diagnostics.
3581 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3582 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3583 C Angular derivatives of the contact function
3584                 ees0pij1=fac3/ees0pij
3585                 ees0mij1=fac3/ees0mij
3586                 fac3p=-3.0D0*fac3*rrmij
3587                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3588                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3589 c               ees0mij1=0.0D0
3590                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3591                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3592                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3593                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3594                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3595                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3596                 ecosap=ecosa1+ecosa2
3597                 ecosbp=ecosb1+ecosb2
3598                 ecosgp=ecosg1+ecosg2
3599                 ecosam=ecosa1-ecosa2
3600                 ecosbm=ecosb1-ecosb2
3601                 ecosgm=ecosg1-ecosg2
3602 C Diagnostics
3603 c               ecosap=ecosa1
3604 c               ecosbp=ecosb1
3605 c               ecosgp=ecosg1
3606 c               ecosam=0.0D0
3607 c               ecosbm=0.0D0
3608 c               ecosgm=0.0D0
3609 C End diagnostics
3610                 facont_hb(num_conti,i)=fcont
3611                 fprimcont=fprimcont/rij
3612 cd              facont_hb(num_conti,i)=1.0D0
3613 C Following line is for diagnostics.
3614 cd              fprimcont=0.0D0
3615                 do k=1,3
3616                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3617                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3618                 enddo
3619                 do k=1,3
3620                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3621                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3622                 enddo
3623                 gggp(1)=gggp(1)+ees0pijp*xj
3624                 gggp(2)=gggp(2)+ees0pijp*yj
3625                 gggp(3)=gggp(3)+ees0pijp*zj
3626                 gggm(1)=gggm(1)+ees0mijp*xj
3627                 gggm(2)=gggm(2)+ees0mijp*yj
3628                 gggm(3)=gggm(3)+ees0mijp*zj
3629 C Derivatives due to the contact function
3630                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3631                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3632                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3633                 do k=1,3
3634 c
3635 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3636 c          following the change of gradient-summation algorithm.
3637 c
3638 cgrad                  ghalfp=0.5D0*gggp(k)
3639 cgrad                  ghalfm=0.5D0*gggm(k)
3640                   gacontp_hb1(k,num_conti,i)=!ghalfp
3641      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3642      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3643                   gacontp_hb2(k,num_conti,i)=!ghalfp
3644      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3645      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3646                   gacontp_hb3(k,num_conti,i)=gggp(k)
3647                   gacontm_hb1(k,num_conti,i)=!ghalfm
3648      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3649      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3650                   gacontm_hb2(k,num_conti,i)=!ghalfm
3651      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3652      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3653                   gacontm_hb3(k,num_conti,i)=gggm(k)
3654                 enddo
3655 C Diagnostics. Comment out or remove after debugging!
3656 cdiag           do k=1,3
3657 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3658 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3659 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3660 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3661 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3662 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3663 cdiag           enddo
3664               ENDIF ! wcorr
3665               endif  ! num_conti.le.maxconts
3666             endif  ! fcont.gt.0
3667           endif    ! j.gt.i+1
3668           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3669             do k=1,4
3670               do l=1,3
3671                 ghalf=0.5d0*agg(l,k)
3672                 aggi(l,k)=aggi(l,k)+ghalf
3673                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3674                 aggj(l,k)=aggj(l,k)+ghalf
3675               enddo
3676             enddo
3677             if (j.eq.nres-1 .and. i.lt.j-2) then
3678               do k=1,4
3679                 do l=1,3
3680                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3681                 enddo
3682               enddo
3683             endif
3684           endif
3685 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3686       return
3687       end
3688 C-----------------------------------------------------------------------------
3689       subroutine eturn3(i,eello_turn3)
3690 C Third- and fourth-order contributions from turns
3691       implicit real*8 (a-h,o-z)
3692       include 'DIMENSIONS'
3693       include 'COMMON.IOUNITS'
3694       include 'COMMON.GEO'
3695       include 'COMMON.VAR'
3696       include 'COMMON.LOCAL'
3697       include 'COMMON.CHAIN'
3698       include 'COMMON.DERIV'
3699       include 'COMMON.INTERACT'
3700       include 'COMMON.CONTACTS'
3701 #ifdef MOMENT
3702       include 'COMMON.CONTACTS.MOMENT'
3703 #endif
3704       include 'COMMON.TORSION'
3705       include 'COMMON.VECTORS'
3706       include 'COMMON.FFIELD'
3707       include 'COMMON.CONTROL'
3708       dimension ggg(3)
3709       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3710      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3711      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3712       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3713      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3714       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3715      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3716      &    num_conti,j1,j2
3717       j=i+2
3718 c      write (iout,*) "eturn3",i,j,j1,j2
3719       a_temp(1,1)=a22
3720       a_temp(1,2)=a23
3721       a_temp(2,1)=a32
3722       a_temp(2,2)=a33
3723 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3724 C
3725 C               Third-order contributions
3726 C
3727 C                 (i+2)o----(i+3)
3728 C                      | |
3729 C                      | |
3730 C                 (i+1)o----i
3731 C
3732 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3733 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3734         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3735         call transpose2(auxmat(1,1),auxmat1(1,1))
3736         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3737         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3738         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3739      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3740 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3741 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3742 cd     &    ' eello_turn3_num',4*eello_turn3_num
3743 C Derivatives in gamma(i)
3744         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3745         call transpose2(auxmat2(1,1),auxmat3(1,1))
3746         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3747         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3748 C Derivatives in gamma(i+1)
3749         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3750         call transpose2(auxmat2(1,1),auxmat3(1,1))
3751         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3752         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3753      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3754 C Cartesian derivatives
3755         do l=1,3
3756 c            ghalf1=0.5d0*agg(l,1)
3757 c            ghalf2=0.5d0*agg(l,2)
3758 c            ghalf3=0.5d0*agg(l,3)
3759 c            ghalf4=0.5d0*agg(l,4)
3760           a_temp(1,1)=aggi(l,1)!+ghalf1
3761           a_temp(1,2)=aggi(l,2)!+ghalf2
3762           a_temp(2,1)=aggi(l,3)!+ghalf3
3763           a_temp(2,2)=aggi(l,4)!+ghalf4
3764           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3765           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3766      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3767           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3768           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3769           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3770           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3771           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3772           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3773      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3774           a_temp(1,1)=aggj(l,1)!+ghalf1
3775           a_temp(1,2)=aggj(l,2)!+ghalf2
3776           a_temp(2,1)=aggj(l,3)!+ghalf3
3777           a_temp(2,2)=aggj(l,4)!+ghalf4
3778           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3779           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3780      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3781           a_temp(1,1)=aggj1(l,1)
3782           a_temp(1,2)=aggj1(l,2)
3783           a_temp(2,1)=aggj1(l,3)
3784           a_temp(2,2)=aggj1(l,4)
3785           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3786           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3787      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3788         enddo
3789       return
3790       end
3791 C-------------------------------------------------------------------------------
3792       subroutine eturn4(i,eello_turn4)
3793 C Third- and fourth-order contributions from turns
3794       implicit real*8 (a-h,o-z)
3795       include 'DIMENSIONS'
3796       include 'COMMON.IOUNITS'
3797       include 'COMMON.GEO'
3798       include 'COMMON.VAR'
3799       include 'COMMON.LOCAL'
3800       include 'COMMON.CHAIN'
3801       include 'COMMON.DERIV'
3802       include 'COMMON.INTERACT'
3803       include 'COMMON.CONTACTS'
3804 #ifdef MOMENT
3805       include 'COMMON.CONTACTS.MOMENT'
3806 #endif
3807       include 'COMMON.TORSION'
3808       include 'COMMON.VECTORS'
3809       include 'COMMON.FFIELD'
3810       include 'COMMON.CONTROL'
3811       dimension ggg(3)
3812       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3813      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3814      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3815       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3816      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3817       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3818      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3819      &    num_conti,j1,j2
3820       j=i+3
3821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3822 C
3823 C               Fourth-order contributions
3824 C
3825 C                 (i+3)o----(i+4)
3826 C                     /  |
3827 C               (i+2)o   |
3828 C                     \  |
3829 C                 (i+1)o----i
3830 C
3831 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3832 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3833 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3834         a_temp(1,1)=a22
3835         a_temp(1,2)=a23
3836         a_temp(2,1)=a32
3837         a_temp(2,2)=a33
3838         iti1=itortyp(itype(i+1))
3839         iti2=itortyp(itype(i+2))
3840         iti3=itortyp(itype(i+3))
3841 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3842         call transpose2(EUg(1,1,i+1),e1t(1,1))
3843         call transpose2(Eug(1,1,i+2),e2t(1,1))
3844         call transpose2(Eug(1,1,i+3),e3t(1,1))
3845         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3846         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3847         s1=scalar2(b1(1,iti2),auxvec(1))
3848         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3849         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3850         s2=scalar2(b1(1,iti1),auxvec(1))
3851         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3852         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3853         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3854         eello_turn4=eello_turn4-(s1+s2+s3)
3855         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3856      &      'eturn4',i,j,-(s1+s2+s3)
3857 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3858 cd     &    ' eello_turn4_num',8*eello_turn4_num
3859 C Derivatives in gamma(i)
3860         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3861         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3862         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3863         s1=scalar2(b1(1,iti2),auxvec(1))
3864         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3865         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3866         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3867 C Derivatives in gamma(i+1)
3868         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3869         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3870         s2=scalar2(b1(1,iti1),auxvec(1))
3871         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3872         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3873         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3874         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3875 C Derivatives in gamma(i+2)
3876         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3877         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3878         s1=scalar2(b1(1,iti2),auxvec(1))
3879         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3880         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3881         s2=scalar2(b1(1,iti1),auxvec(1))
3882         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3883         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3884         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3885         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3886 C Cartesian derivatives
3887 C Derivatives of this turn contributions in DC(i+2)
3888         if (j.lt.nres-1) then
3889           do l=1,3
3890             a_temp(1,1)=agg(l,1)
3891             a_temp(1,2)=agg(l,2)
3892             a_temp(2,1)=agg(l,3)
3893             a_temp(2,2)=agg(l,4)
3894             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3895             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3896             s1=scalar2(b1(1,iti2),auxvec(1))
3897             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3898             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3899             s2=scalar2(b1(1,iti1),auxvec(1))
3900             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3901             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3902             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3903             ggg(l)=-(s1+s2+s3)
3904             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3905           enddo
3906         endif
3907 C Remaining derivatives of this turn contribution
3908         do l=1,3
3909           a_temp(1,1)=aggi(l,1)
3910           a_temp(1,2)=aggi(l,2)
3911           a_temp(2,1)=aggi(l,3)
3912           a_temp(2,2)=aggi(l,4)
3913           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3914           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3915           s1=scalar2(b1(1,iti2),auxvec(1))
3916           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3917           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3918           s2=scalar2(b1(1,iti1),auxvec(1))
3919           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3920           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3921           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3922           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3923           a_temp(1,1)=aggi1(l,1)
3924           a_temp(1,2)=aggi1(l,2)
3925           a_temp(2,1)=aggi1(l,3)
3926           a_temp(2,2)=aggi1(l,4)
3927           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3928           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3929           s1=scalar2(b1(1,iti2),auxvec(1))
3930           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3931           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3932           s2=scalar2(b1(1,iti1),auxvec(1))
3933           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3934           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3935           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3936           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3937           a_temp(1,1)=aggj(l,1)
3938           a_temp(1,2)=aggj(l,2)
3939           a_temp(2,1)=aggj(l,3)
3940           a_temp(2,2)=aggj(l,4)
3941           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3942           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3943           s1=scalar2(b1(1,iti2),auxvec(1))
3944           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3945           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3946           s2=scalar2(b1(1,iti1),auxvec(1))
3947           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3948           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3949           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3950           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3951           a_temp(1,1)=aggj1(l,1)
3952           a_temp(1,2)=aggj1(l,2)
3953           a_temp(2,1)=aggj1(l,3)
3954           a_temp(2,2)=aggj1(l,4)
3955           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3956           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3957           s1=scalar2(b1(1,iti2),auxvec(1))
3958           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3959           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3960           s2=scalar2(b1(1,iti1),auxvec(1))
3961           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3962           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3963           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3964 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3965           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3966         enddo
3967       return
3968       end
3969 C-----------------------------------------------------------------------------
3970       subroutine vecpr(u,v,w)
3971       implicit real*8(a-h,o-z)
3972       dimension u(3),v(3),w(3)
3973       w(1)=u(2)*v(3)-u(3)*v(2)
3974       w(2)=-u(1)*v(3)+u(3)*v(1)
3975       w(3)=u(1)*v(2)-u(2)*v(1)
3976       return
3977       end
3978 C-----------------------------------------------------------------------------
3979       subroutine unormderiv(u,ugrad,unorm,ungrad)
3980 C This subroutine computes the derivatives of a normalized vector u, given
3981 C the derivatives computed without normalization conditions, ugrad. Returns
3982 C ungrad.
3983       implicit none
3984       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3985       double precision vec(3)
3986       double precision scalar
3987       integer i,j
3988 c      write (2,*) 'ugrad',ugrad
3989 c      write (2,*) 'u',u
3990       do i=1,3
3991         vec(i)=scalar(ugrad(1,i),u(1))
3992       enddo
3993 c      write (2,*) 'vec',vec
3994       do i=1,3
3995         do j=1,3
3996           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3997         enddo
3998       enddo
3999 c      write (2,*) 'ungrad',ungrad
4000       return
4001       end
4002 C-----------------------------------------------------------------------------
4003       subroutine escp_soft_sphere(evdw2,evdw2_14)
4004 C
4005 C This subroutine calculates the excluded-volume interaction energy between
4006 C peptide-group centers and side chains and its gradient in virtual-bond and
4007 C side-chain vectors.
4008 C
4009       implicit real*8 (a-h,o-z)
4010       include 'DIMENSIONS'
4011       include 'COMMON.GEO'
4012       include 'COMMON.VAR'
4013       include 'COMMON.LOCAL'
4014       include 'COMMON.CHAIN'
4015       include 'COMMON.DERIV'
4016       include 'COMMON.INTERACT'
4017       include 'COMMON.FFIELD'
4018       include 'COMMON.IOUNITS'
4019       include 'COMMON.CONTROL'
4020       dimension ggg(3)
4021       evdw2=0.0D0
4022       evdw2_14=0.0d0
4023       r0_scp=4.5d0
4024 cd    print '(a)','Enter ESCP'
4025 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4026       do i=iatscp_s,iatscp_e
4027         iteli=itel(i)
4028         xi=0.5D0*(c(1,i)+c(1,i+1))
4029         yi=0.5D0*(c(2,i)+c(2,i+1))
4030         zi=0.5D0*(c(3,i)+c(3,i+1))
4031
4032         do iint=1,nscp_gr(i)
4033
4034         do j=iscpstart(i,iint),iscpend(i,iint)
4035           itypj=itype(j)
4036 C Uncomment following three lines for SC-p interactions
4037 c         xj=c(1,nres+j)-xi
4038 c         yj=c(2,nres+j)-yi
4039 c         zj=c(3,nres+j)-zi
4040 C Uncomment following three lines for Ca-p interactions
4041           xj=c(1,j)-xi
4042           yj=c(2,j)-yi
4043           zj=c(3,j)-zi
4044           rij=xj*xj+yj*yj+zj*zj
4045           r0ij=r0_scp
4046           r0ijsq=r0ij*r0ij
4047           if (rij.lt.r0ijsq) then
4048             evdwij=0.25d0*(rij-r0ijsq)**2
4049             fac=rij-r0ijsq
4050           else
4051             evdwij=0.0d0
4052             fac=0.0d0
4053           endif
4054           evdw2=evdw2+evdwij
4055 C
4056 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4057 C
4058           ggg(1)=xj*fac
4059           ggg(2)=yj*fac
4060           ggg(3)=zj*fac
4061 cgrad          if (j.lt.i) then
4062 cd          write (iout,*) 'j<i'
4063 C Uncomment following three lines for SC-p interactions
4064 c           do k=1,3
4065 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4066 c           enddo
4067 cgrad          else
4068 cd          write (iout,*) 'j>i'
4069 cgrad            do k=1,3
4070 cgrad              ggg(k)=-ggg(k)
4071 C Uncomment following line for SC-p interactions
4072 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4073 cgrad            enddo
4074 cgrad          endif
4075 cgrad          do k=1,3
4076 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4077 cgrad          enddo
4078 cgrad          kstart=min0(i+1,j)
4079 cgrad          kend=max0(i-1,j-1)
4080 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4081 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4082 cgrad          do k=kstart,kend
4083 cgrad            do l=1,3
4084 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4085 cgrad            enddo
4086 cgrad          enddo
4087           do k=1,3
4088             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4089             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4090           enddo
4091         enddo
4092
4093         enddo ! iint
4094       enddo ! i
4095       return
4096       end
4097 C-----------------------------------------------------------------------------
4098       subroutine escp(evdw2,evdw2_14)
4099 C
4100 C This subroutine calculates the excluded-volume interaction energy between
4101 C peptide-group centers and side chains and its gradient in virtual-bond and
4102 C side-chain vectors.
4103 C
4104       implicit real*8 (a-h,o-z)
4105       include 'DIMENSIONS'
4106       include 'COMMON.GEO'
4107       include 'COMMON.VAR'
4108       include 'COMMON.LOCAL'
4109       include 'COMMON.CHAIN'
4110       include 'COMMON.DERIV'
4111       include 'COMMON.INTERACT'
4112       include 'COMMON.FFIELD'
4113       include 'COMMON.IOUNITS'
4114       include 'COMMON.CONTROL'
4115       dimension ggg(3)
4116       evdw2=0.0D0
4117       evdw2_14=0.0d0
4118 cd    print '(a)','Enter ESCP'
4119 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4120       do i=iatscp_s,iatscp_e
4121         iteli=itel(i)
4122         xi=0.5D0*(c(1,i)+c(1,i+1))
4123         yi=0.5D0*(c(2,i)+c(2,i+1))
4124         zi=0.5D0*(c(3,i)+c(3,i+1))
4125
4126         do iint=1,nscp_gr(i)
4127
4128         do j=iscpstart(i,iint),iscpend(i,iint)
4129           itypj=itype(j)
4130 C Uncomment following three lines for SC-p interactions
4131 c         xj=c(1,nres+j)-xi
4132 c         yj=c(2,nres+j)-yi
4133 c         zj=c(3,nres+j)-zi
4134 C Uncomment following three lines for Ca-p interactions
4135           xj=c(1,j)-xi
4136           yj=c(2,j)-yi
4137           zj=c(3,j)-zi
4138           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4139           fac=rrij**expon2
4140           e1=fac*fac*aad(itypj,iteli)
4141           e2=fac*bad(itypj,iteli)
4142           if (iabs(j-i) .le. 2) then
4143             e1=scal14*e1
4144             e2=scal14*e2
4145             evdw2_14=evdw2_14+e1+e2
4146           endif
4147           evdwij=e1+e2
4148           evdw2=evdw2+evdwij
4149           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4150      &        'evdw2',i,j,evdwij
4151 C
4152 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4153 C
4154           fac=-(evdwij+e1)*rrij
4155           ggg(1)=xj*fac
4156           ggg(2)=yj*fac
4157           ggg(3)=zj*fac
4158 cgrad          if (j.lt.i) then
4159 cd          write (iout,*) 'j<i'
4160 C Uncomment following three lines for SC-p interactions
4161 c           do k=1,3
4162 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4163 c           enddo
4164 cgrad          else
4165 cd          write (iout,*) 'j>i'
4166 cgrad            do k=1,3
4167 cgrad              ggg(k)=-ggg(k)
4168 C Uncomment following line for SC-p interactions
4169 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4170 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4171 cgrad            enddo
4172 cgrad          endif
4173 cgrad          do k=1,3
4174 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4175 cgrad          enddo
4176 cgrad          kstart=min0(i+1,j)
4177 cgrad          kend=max0(i-1,j-1)
4178 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4179 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4180 cgrad          do k=kstart,kend
4181 cgrad            do l=1,3
4182 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4183 cgrad            enddo
4184 cgrad          enddo
4185           do k=1,3
4186             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4187             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4188           enddo
4189         enddo
4190
4191         enddo ! iint
4192       enddo ! i
4193       do i=1,nct
4194         do j=1,3
4195           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4196           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4197           gradx_scp(j,i)=expon*gradx_scp(j,i)
4198         enddo
4199       enddo
4200 C******************************************************************************
4201 C
4202 C                              N O T E !!!
4203 C
4204 C To save time the factor EXPON has been extracted from ALL components
4205 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4206 C use!
4207 C
4208 C******************************************************************************
4209       return
4210       end
4211 C--------------------------------------------------------------------------
4212       subroutine edis(ehpb)
4213 C
4214 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4215 C
4216       implicit real*8 (a-h,o-z)
4217       include 'DIMENSIONS'
4218       include 'COMMON.SBRIDGE'
4219       include 'COMMON.CHAIN'
4220       include 'COMMON.DERIV'
4221       include 'COMMON.VAR'
4222       include 'COMMON.INTERACT'
4223       include 'COMMON.IOUNITS'
4224       dimension ggg(3)
4225       ehpb=0.0D0
4226 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4227 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4228       if (link_end.eq.0) return
4229       do i=link_start,link_end
4230 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4231 C CA-CA distance used in regularization of structure.
4232         ii=ihpb(i)
4233         jj=jhpb(i)
4234 C iii and jjj point to the residues for which the distance is assigned.
4235         if (ii.gt.nres) then
4236           iii=ii-nres
4237           jjj=jj-nres
4238         else
4239           iii=ii
4240           jjj=jj
4241         endif
4242 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4243 c     &    dhpb(i),dhpb1(i),forcon(i)
4244 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4245 C    distance and angle dependent SS bond potential.
4246 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4247 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4248         if (i.le.nss) then
4249          if (ii.gt.nres
4250      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4251           call ssbond_ene(iii,jjj,eij)
4252           ehpb=ehpb+2*eij
4253          endif
4254 cd          write (iout,*) "eij",eij
4255         else if (ii.gt.nres .and. jj.gt.nres) then
4256 c Restraints from contact prediction
4257           dd=dist(ii,jj)
4258           if (dhpb1(i).gt.0.0d0) then
4259             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4260             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4261 c            write (iout,*) "beta nmr",
4262 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4263           else
4264             dd=dist(ii,jj)
4265             rdis=dd-dhpb(i)
4266 C Get the force constant corresponding to this distance.
4267             waga=forcon(i)
4268 C Calculate the contribution to energy.
4269             ehpb=ehpb+waga*rdis*rdis
4270 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4271 C
4272 C Evaluate gradient.
4273 C
4274             fac=waga*rdis/dd
4275           endif
4276           do j=1,3
4277             ggg(j)=fac*(c(j,jj)-c(j,ii))
4278           enddo
4279           do j=1,3
4280             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4281             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4282           enddo
4283           do k=1,3
4284             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4285             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4286           enddo
4287         else
4288 C Calculate the distance between the two points and its difference from the
4289 C target distance.
4290         dd=dist(ii,jj)
4291           if (dhpb1(i).gt.0.0d0) then
4292             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4293             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4294 c            write (iout,*) "alph nmr",
4295 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4296           else
4297         rdis=dd-dhpb(i)
4298 C Get the force constant corresponding to this distance.
4299         waga=forcon(i)
4300 C Calculate the contribution to energy.
4301         ehpb=ehpb+waga*rdis*rdis
4302 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4303 C
4304 C Evaluate gradient.
4305 C
4306         fac=waga*rdis/dd
4307           endif
4308 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4309 cd   &   ' waga=',waga,' fac=',fac
4310         do j=1,3
4311           ggg(j)=fac*(c(j,jj)-c(j,ii))
4312         enddo
4313 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4314 C If this is a SC-SC distance, we need to calculate the contributions to the
4315 C Cartesian gradient in the SC vectors (ghpbx).
4316         if (iii.lt.ii) then
4317           do j=1,3
4318             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4319             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4320           enddo
4321         endif
4322 cgrad        do j=iii,jjj-1
4323 cgrad          do k=1,3
4324 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4325 cgrad          enddo
4326 cgrad        enddo
4327         do k=1,3
4328           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4329           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4330         enddo
4331         endif
4332       enddo
4333       ehpb=0.5D0*ehpb
4334       return
4335       end
4336 C--------------------------------------------------------------------------
4337       subroutine ssbond_ene(i,j,eij)
4338 C
4339 C Calculate the distance and angle dependent SS-bond potential energy
4340 C using a free-energy function derived based on RHF/6-31G** ab initio
4341 C calculations of diethyl disulfide.
4342 C
4343 C A. Liwo and U. Kozlowska, 11/24/03
4344 C
4345       implicit real*8 (a-h,o-z)
4346       include 'DIMENSIONS'
4347       include 'COMMON.SBRIDGE'
4348       include 'COMMON.CHAIN'
4349       include 'COMMON.DERIV'
4350       include 'COMMON.LOCAL'
4351       include 'COMMON.INTERACT'
4352       include 'COMMON.VAR'
4353       include 'COMMON.IOUNITS'
4354       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4355       itypi=itype(i)
4356       xi=c(1,nres+i)
4357       yi=c(2,nres+i)
4358       zi=c(3,nres+i)
4359       dxi=dc_norm(1,nres+i)
4360       dyi=dc_norm(2,nres+i)
4361       dzi=dc_norm(3,nres+i)
4362 c      dsci_inv=dsc_inv(itypi)
4363       dsci_inv=vbld_inv(nres+i)
4364       itypj=itype(j)
4365 c      dscj_inv=dsc_inv(itypj)
4366       dscj_inv=vbld_inv(nres+j)
4367       xj=c(1,nres+j)-xi
4368       yj=c(2,nres+j)-yi
4369       zj=c(3,nres+j)-zi
4370       dxj=dc_norm(1,nres+j)
4371       dyj=dc_norm(2,nres+j)
4372       dzj=dc_norm(3,nres+j)
4373       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4374       rij=dsqrt(rrij)
4375       erij(1)=xj*rij
4376       erij(2)=yj*rij
4377       erij(3)=zj*rij
4378       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4379       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4380       om12=dxi*dxj+dyi*dyj+dzi*dzj
4381       do k=1,3
4382         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4383         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4384       enddo
4385       rij=1.0d0/rij
4386       deltad=rij-d0cm
4387       deltat1=1.0d0-om1
4388       deltat2=1.0d0+om2
4389       deltat12=om2-om1+2.0d0
4390       cosphi=om12-om1*om2
4391       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4392      &  +akct*deltad*deltat12
4393      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4394 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4395 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4396 c     &  " deltat12",deltat12," eij",eij
4397       ed=2*akcm*deltad+akct*deltat12
4398       pom1=akct*deltad
4399       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4400       eom1=-2*akth*deltat1-pom1-om2*pom2
4401       eom2= 2*akth*deltat2+pom1-om1*pom2
4402       eom12=pom2
4403       do k=1,3
4404         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4405         ghpbx(k,i)=ghpbx(k,i)-ggk
4406      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4407      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4408         ghpbx(k,j)=ghpbx(k,j)+ggk
4409      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4410      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4411         ghpbc(k,i)=ghpbc(k,i)-ggk
4412         ghpbc(k,j)=ghpbc(k,j)+ggk
4413       enddo
4414 C
4415 C Calculate the components of the gradient in DC and X
4416 C
4417 cgrad      do k=i,j-1
4418 cgrad        do l=1,3
4419 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4420 cgrad        enddo
4421 cgrad      enddo
4422       return
4423       end
4424 C--------------------------------------------------------------------------
4425       subroutine ebond(estr)
4426 c
4427 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4428 c
4429       implicit real*8 (a-h,o-z)
4430       include 'DIMENSIONS'
4431       include 'COMMON.LOCAL'
4432       include 'COMMON.GEO'
4433       include 'COMMON.INTERACT'
4434       include 'COMMON.DERIV'
4435       include 'COMMON.VAR'
4436       include 'COMMON.CHAIN'
4437       include 'COMMON.IOUNITS'
4438       include 'COMMON.NAMES'
4439       include 'COMMON.FFIELD'
4440       include 'COMMON.CONTROL'
4441       include 'COMMON.SETUP'
4442       double precision u(3),ud(3)
4443       estr=0.0d0
4444       do i=ibondp_start,ibondp_end
4445         diff = vbld(i)-vbldp0
4446 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4447         estr=estr+diff*diff
4448         do j=1,3
4449           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4450         enddo
4451 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4452       enddo
4453       estr=0.5d0*AKP*estr
4454 c
4455 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4456 c
4457       do i=ibond_start,ibond_end
4458         iti=itype(i)
4459         if (iti.ne.10) then
4460           nbi=nbondterm(iti)
4461           if (nbi.eq.1) then
4462             diff=vbld(i+nres)-vbldsc0(1,iti)
4463 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4464 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4465             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4466             do j=1,3
4467               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4468             enddo
4469           else
4470             do j=1,nbi
4471               diff=vbld(i+nres)-vbldsc0(j,iti)
4472               ud(j)=aksc(j,iti)*diff
4473               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4474             enddo
4475             uprod=u(1)
4476             do j=2,nbi
4477               uprod=uprod*u(j)
4478             enddo
4479             usum=0.0d0
4480             usumsqder=0.0d0
4481             do j=1,nbi
4482               uprod1=1.0d0
4483               uprod2=1.0d0
4484               do k=1,nbi
4485                 if (k.ne.j) then
4486                   uprod1=uprod1*u(k)
4487                   uprod2=uprod2*u(k)*u(k)
4488                 endif
4489               enddo
4490               usum=usum+uprod1
4491               usumsqder=usumsqder+ud(j)*uprod2
4492             enddo
4493             estr=estr+uprod/usum
4494             do j=1,3
4495              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4496             enddo
4497           endif
4498         endif
4499       enddo
4500       return
4501       end
4502 #ifdef CRYST_THETA
4503 C--------------------------------------------------------------------------
4504       subroutine ebend(etheta)
4505 C
4506 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4507 C angles gamma and its derivatives in consecutive thetas and gammas.
4508 C
4509       implicit real*8 (a-h,o-z)
4510       include 'DIMENSIONS'
4511       include 'COMMON.LOCAL'
4512       include 'COMMON.GEO'
4513       include 'COMMON.INTERACT'
4514       include 'COMMON.DERIV'
4515       include 'COMMON.VAR'
4516       include 'COMMON.CHAIN'
4517       include 'COMMON.IOUNITS'
4518       include 'COMMON.NAMES'
4519       include 'COMMON.FFIELD'
4520       include 'COMMON.CONTROL'
4521       common /calcthet/ term1,term2,termm,diffak,ratak,
4522      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4523      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4524       double precision y(2),z(2)
4525       delta=0.02d0*pi
4526 c      time11=dexp(-2*time)
4527 c      time12=1.0d0
4528       etheta=0.0D0
4529 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4530       do i=ithet_start,ithet_end
4531 C Zero the energy function and its derivative at 0 or pi.
4532         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4533         it=itype(i-1)
4534         if (i.gt.3) then
4535 #ifdef OSF
4536           phii=phi(i)
4537           if (phii.ne.phii) phii=150.0
4538 #else
4539           phii=phi(i)
4540 #endif
4541           y(1)=dcos(phii)
4542           y(2)=dsin(phii)
4543         else
4544           y(1)=0.0D0
4545           y(2)=0.0D0
4546         endif
4547         if (i.lt.nres) then
4548 #ifdef OSF
4549           phii1=phi(i+1)
4550           if (phii1.ne.phii1) phii1=150.0
4551           phii1=pinorm(phii1)
4552           z(1)=cos(phii1)
4553 #else
4554           phii1=phi(i+1)
4555           z(1)=dcos(phii1)
4556 #endif
4557           z(2)=dsin(phii1)
4558         else
4559           z(1)=0.0D0
4560           z(2)=0.0D0
4561         endif
4562 C Calculate the "mean" value of theta from the part of the distribution
4563 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4564 C In following comments this theta will be referred to as t_c.
4565         thet_pred_mean=0.0d0
4566         do k=1,2
4567           athetk=athet(k,it)
4568           bthetk=bthet(k,it)
4569           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4570         enddo
4571         dthett=thet_pred_mean*ssd
4572         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4573 C Derivatives of the "mean" values in gamma1 and gamma2.
4574         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4575         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4576         if (theta(i).gt.pi-delta) then
4577           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4578      &         E_tc0)
4579           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4580           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4581           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4582      &        E_theta)
4583           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4584      &        E_tc)
4585         else if (theta(i).lt.delta) then
4586           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4587           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4588           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4589      &        E_theta)
4590           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4591           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4592      &        E_tc)
4593         else
4594           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4595      &        E_theta,E_tc)
4596         endif
4597         etheta=etheta+ethetai
4598         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4599      &      'ebend',i,ethetai
4600         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4601         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4602         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4603       enddo
4604 C Ufff.... We've done all this!!!
4605       return
4606       end
4607 C---------------------------------------------------------------------------
4608       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4609      &     E_tc)
4610       implicit real*8 (a-h,o-z)
4611       include 'DIMENSIONS'
4612       include 'COMMON.LOCAL'
4613       include 'COMMON.IOUNITS'
4614       common /calcthet/ term1,term2,termm,diffak,ratak,
4615      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4616      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4617 C Calculate the contributions to both Gaussian lobes.
4618 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4619 C The "polynomial part" of the "standard deviation" of this part of
4620 C the distribution.
4621         sig=polthet(3,it)
4622         do j=2,0,-1
4623           sig=sig*thet_pred_mean+polthet(j,it)
4624         enddo
4625 C Derivative of the "interior part" of the "standard deviation of the"
4626 C gamma-dependent Gaussian lobe in t_c.
4627         sigtc=3*polthet(3,it)
4628         do j=2,1,-1
4629           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4630         enddo
4631         sigtc=sig*sigtc
4632 C Set the parameters of both Gaussian lobes of the distribution.
4633 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4634         fac=sig*sig+sigc0(it)
4635         sigcsq=fac+fac
4636         sigc=1.0D0/sigcsq
4637 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4638         sigsqtc=-4.0D0*sigcsq*sigtc
4639 c       print *,i,sig,sigtc,sigsqtc
4640 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4641         sigtc=-sigtc/(fac*fac)
4642 C Following variable is sigma(t_c)**(-2)
4643         sigcsq=sigcsq*sigcsq
4644         sig0i=sig0(it)
4645         sig0inv=1.0D0/sig0i**2
4646         delthec=thetai-thet_pred_mean
4647         delthe0=thetai-theta0i
4648         term1=-0.5D0*sigcsq*delthec*delthec
4649         term2=-0.5D0*sig0inv*delthe0*delthe0
4650 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4651 C NaNs in taking the logarithm. We extract the largest exponent which is added
4652 C to the energy (this being the log of the distribution) at the end of energy
4653 C term evaluation for this virtual-bond angle.
4654         if (term1.gt.term2) then
4655           termm=term1
4656           term2=dexp(term2-termm)
4657           term1=1.0d0
4658         else
4659           termm=term2
4660           term1=dexp(term1-termm)
4661           term2=1.0d0
4662         endif
4663 C The ratio between the gamma-independent and gamma-dependent lobes of
4664 C the distribution is a Gaussian function of thet_pred_mean too.
4665         diffak=gthet(2,it)-thet_pred_mean
4666         ratak=diffak/gthet(3,it)**2
4667         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4668 C Let's differentiate it in thet_pred_mean NOW.
4669         aktc=ak*ratak
4670 C Now put together the distribution terms to make complete distribution.
4671         termexp=term1+ak*term2
4672         termpre=sigc+ak*sig0i
4673 C Contribution of the bending energy from this theta is just the -log of
4674 C the sum of the contributions from the two lobes and the pre-exponential
4675 C factor. Simple enough, isn't it?
4676         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4677 C NOW the derivatives!!!
4678 C 6/6/97 Take into account the deformation.
4679         E_theta=(delthec*sigcsq*term1
4680      &       +ak*delthe0*sig0inv*term2)/termexp
4681         E_tc=((sigtc+aktc*sig0i)/termpre
4682      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4683      &       aktc*term2)/termexp)
4684       return
4685       end
4686 c-----------------------------------------------------------------------------
4687       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4688       implicit real*8 (a-h,o-z)
4689       include 'DIMENSIONS'
4690       include 'COMMON.LOCAL'
4691       include 'COMMON.IOUNITS'
4692       common /calcthet/ term1,term2,termm,diffak,ratak,
4693      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4694      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4695       delthec=thetai-thet_pred_mean
4696       delthe0=thetai-theta0i
4697 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4698       t3 = thetai-thet_pred_mean
4699       t6 = t3**2
4700       t9 = term1
4701       t12 = t3*sigcsq
4702       t14 = t12+t6*sigsqtc
4703       t16 = 1.0d0
4704       t21 = thetai-theta0i
4705       t23 = t21**2
4706       t26 = term2
4707       t27 = t21*t26
4708       t32 = termexp
4709       t40 = t32**2
4710       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4711      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4712      & *(-t12*t9-ak*sig0inv*t27)
4713       return
4714       end
4715 #else
4716 C--------------------------------------------------------------------------
4717       subroutine ebend(etheta)
4718 C
4719 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4720 C angles gamma and its derivatives in consecutive thetas and gammas.
4721 C ab initio-derived potentials from
4722 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4723 C
4724       implicit real*8 (a-h,o-z)
4725       include 'DIMENSIONS'
4726       include 'COMMON.LOCAL'
4727       include 'COMMON.GEO'
4728       include 'COMMON.INTERACT'
4729       include 'COMMON.DERIV'
4730       include 'COMMON.VAR'
4731       include 'COMMON.CHAIN'
4732       include 'COMMON.IOUNITS'
4733       include 'COMMON.NAMES'
4734       include 'COMMON.FFIELD'
4735       include 'COMMON.CONTROL'
4736       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4737      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4738      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4739      & sinph1ph2(maxdouble,maxdouble)
4740       logical lprn /.false./, lprn1 /.false./
4741       etheta=0.0D0
4742       do i=ithet_start,ithet_end
4743         dethetai=0.0d0
4744         dephii=0.0d0
4745         dephii1=0.0d0
4746         theti2=0.5d0*theta(i)
4747         ityp2=ithetyp(itype(i-1))
4748         do k=1,nntheterm
4749           coskt(k)=dcos(k*theti2)
4750           sinkt(k)=dsin(k*theti2)
4751         enddo
4752         if (i.gt.3) then
4753 #ifdef OSF
4754           phii=phi(i)
4755           if (phii.ne.phii) phii=150.0
4756 #else
4757           phii=phi(i)
4758 #endif
4759           ityp1=ithetyp(itype(i-2))
4760           do k=1,nsingle
4761             cosph1(k)=dcos(k*phii)
4762             sinph1(k)=dsin(k*phii)
4763           enddo
4764         else
4765           phii=0.0d0
4766           ityp1=nthetyp+1
4767           do k=1,nsingle
4768             cosph1(k)=0.0d0
4769             sinph1(k)=0.0d0
4770           enddo
4771         endif
4772         if (i.lt.nres) then
4773 #ifdef OSF
4774           phii1=phi(i+1)
4775           if (phii1.ne.phii1) phii1=150.0
4776           phii1=pinorm(phii1)
4777 #else
4778           phii1=phi(i+1)
4779 #endif
4780           ityp3=ithetyp(itype(i))
4781           do k=1,nsingle
4782             cosph2(k)=dcos(k*phii1)
4783             sinph2(k)=dsin(k*phii1)
4784           enddo
4785         else
4786           phii1=0.0d0
4787           ityp3=nthetyp+1
4788           do k=1,nsingle
4789             cosph2(k)=0.0d0
4790             sinph2(k)=0.0d0
4791           enddo
4792         endif
4793         ethetai=aa0thet(ityp1,ityp2,ityp3)
4794         do k=1,ndouble
4795           do l=1,k-1
4796             ccl=cosph1(l)*cosph2(k-l)
4797             ssl=sinph1(l)*sinph2(k-l)
4798             scl=sinph1(l)*cosph2(k-l)
4799             csl=cosph1(l)*sinph2(k-l)
4800             cosph1ph2(l,k)=ccl-ssl
4801             cosph1ph2(k,l)=ccl+ssl
4802             sinph1ph2(l,k)=scl+csl
4803             sinph1ph2(k,l)=scl-csl
4804           enddo
4805         enddo
4806         if (lprn) then
4807         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4808      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4809         write (iout,*) "coskt and sinkt"
4810         do k=1,nntheterm
4811           write (iout,*) k,coskt(k),sinkt(k)
4812         enddo
4813         endif
4814         do k=1,ntheterm
4815           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4816           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4817      &      *coskt(k)
4818           if (lprn)
4819      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4820      &     " ethetai",ethetai
4821         enddo
4822         if (lprn) then
4823         write (iout,*) "cosph and sinph"
4824         do k=1,nsingle
4825           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4826         enddo
4827         write (iout,*) "cosph1ph2 and sinph2ph2"
4828         do k=2,ndouble
4829           do l=1,k-1
4830             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4831      &         sinph1ph2(l,k),sinph1ph2(k,l)
4832           enddo
4833         enddo
4834         write(iout,*) "ethetai",ethetai
4835         endif
4836         do m=1,ntheterm2
4837           do k=1,nsingle
4838             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4839      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4840      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4841      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4842             ethetai=ethetai+sinkt(m)*aux
4843             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4844             dephii=dephii+k*sinkt(m)*(
4845      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4846      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4847             dephii1=dephii1+k*sinkt(m)*(
4848      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4849      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4850             if (lprn)
4851      &      write (iout,*) "m",m," k",k," bbthet",
4852      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4853      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4854      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4855      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4856           enddo
4857         enddo
4858         if (lprn)
4859      &  write(iout,*) "ethetai",ethetai
4860         do m=1,ntheterm3
4861           do k=2,ndouble
4862             do l=1,k-1
4863               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4864      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4865      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4866      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4867               ethetai=ethetai+sinkt(m)*aux
4868               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4869               dephii=dephii+l*sinkt(m)*(
4870      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4871      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4872      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4873      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4874               dephii1=dephii1+(k-l)*sinkt(m)*(
4875      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4876      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4877      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4878      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4879               if (lprn) then
4880               write (iout,*) "m",m," k",k," l",l," ffthet",
4881      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4882      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4883      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4884      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4885               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4886      &            cosph1ph2(k,l)*sinkt(m),
4887      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4888               endif
4889             enddo
4890           enddo
4891         enddo
4892 10      continue
4893         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4894      &   i,theta(i)*rad2deg,phii*rad2deg,
4895      &   phii1*rad2deg,ethetai
4896         etheta=etheta+ethetai
4897         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4898         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4899         gloc(nphi+i-2,icg)=wang*dethetai
4900       enddo
4901       return
4902       end
4903 #endif
4904 #ifdef CRYST_SC
4905 c-----------------------------------------------------------------------------
4906       subroutine esc(escloc)
4907 C Calculate the local energy of a side chain and its derivatives in the
4908 C corresponding virtual-bond valence angles THETA and the spherical angles
4909 C ALPHA and OMEGA.
4910       implicit real*8 (a-h,o-z)
4911       include 'DIMENSIONS'
4912       include 'COMMON.GEO'
4913       include 'COMMON.LOCAL'
4914       include 'COMMON.VAR'
4915       include 'COMMON.INTERACT'
4916       include 'COMMON.DERIV'
4917       include 'COMMON.CHAIN'
4918       include 'COMMON.IOUNITS'
4919       include 'COMMON.NAMES'
4920       include 'COMMON.FFIELD'
4921       include 'COMMON.CONTROL'
4922       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4923      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4924       common /sccalc/ time11,time12,time112,theti,it,nlobit
4925       delta=0.02d0*pi
4926       escloc=0.0D0
4927 c     write (iout,'(a)') 'ESC'
4928       do i=loc_start,loc_end
4929         it=itype(i)
4930         if (it.eq.10) goto 1
4931         nlobit=nlob(it)
4932 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4933 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4934         theti=theta(i+1)-pipol
4935         x(1)=dtan(theti)
4936         x(2)=alph(i)
4937         x(3)=omeg(i)
4938
4939         if (x(2).gt.pi-delta) then
4940           xtemp(1)=x(1)
4941           xtemp(2)=pi-delta
4942           xtemp(3)=x(3)
4943           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4944           xtemp(2)=pi
4945           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4946           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4947      &        escloci,dersc(2))
4948           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4949      &        ddersc0(1),dersc(1))
4950           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4951      &        ddersc0(3),dersc(3))
4952           xtemp(2)=pi-delta
4953           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4954           xtemp(2)=pi
4955           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4956           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4957      &            dersc0(2),esclocbi,dersc02)
4958           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4959      &            dersc12,dersc01)
4960           call splinthet(x(2),0.5d0*delta,ss,ssd)
4961           dersc0(1)=dersc01
4962           dersc0(2)=dersc02
4963           dersc0(3)=0.0d0
4964           do k=1,3
4965             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4966           enddo
4967           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4968 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4969 c    &             esclocbi,ss,ssd
4970           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4971 c         escloci=esclocbi
4972 c         write (iout,*) escloci
4973         else if (x(2).lt.delta) then
4974           xtemp(1)=x(1)
4975           xtemp(2)=delta
4976           xtemp(3)=x(3)
4977           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4978           xtemp(2)=0.0d0
4979           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4980           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4981      &        escloci,dersc(2))
4982           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4983      &        ddersc0(1),dersc(1))
4984           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4985      &        ddersc0(3),dersc(3))
4986           xtemp(2)=delta
4987           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4988           xtemp(2)=0.0d0
4989           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4990           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4991      &            dersc0(2),esclocbi,dersc02)
4992           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4993      &            dersc12,dersc01)
4994           dersc0(1)=dersc01
4995           dersc0(2)=dersc02
4996           dersc0(3)=0.0d0
4997           call splinthet(x(2),0.5d0*delta,ss,ssd)
4998           do k=1,3
4999             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5000           enddo
5001           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5002 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5003 c    &             esclocbi,ss,ssd
5004           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5005 c         write (iout,*) escloci
5006         else
5007           call enesc(x,escloci,dersc,ddummy,.false.)
5008         endif
5009
5010         escloc=escloc+escloci
5011         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5012      &     'escloc',i,escloci
5013 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5014
5015         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5016      &   wscloc*dersc(1)
5017         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5018         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5019     1   continue
5020       enddo
5021       return
5022       end
5023 C---------------------------------------------------------------------------
5024       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5025       implicit real*8 (a-h,o-z)
5026       include 'DIMENSIONS'
5027       include 'COMMON.GEO'
5028       include 'COMMON.LOCAL'
5029       include 'COMMON.IOUNITS'
5030       common /sccalc/ time11,time12,time112,theti,it,nlobit
5031       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5032       double precision contr(maxlob,-1:1)
5033       logical mixed
5034 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5035         escloc_i=0.0D0
5036         do j=1,3
5037           dersc(j)=0.0D0
5038           if (mixed) ddersc(j)=0.0d0
5039         enddo
5040         x3=x(3)
5041
5042 C Because of periodicity of the dependence of the SC energy in omega we have
5043 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5044 C To avoid underflows, first compute & store the exponents.
5045
5046         do iii=-1,1
5047
5048           x(3)=x3+iii*dwapi
5049
5050           do j=1,nlobit
5051             do k=1,3
5052               z(k)=x(k)-censc(k,j,it)
5053             enddo
5054             do k=1,3
5055               Axk=0.0D0
5056               do l=1,3
5057                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5058               enddo
5059               Ax(k,j,iii)=Axk
5060             enddo
5061             expfac=0.0D0
5062             do k=1,3
5063               expfac=expfac+Ax(k,j,iii)*z(k)
5064             enddo
5065             contr(j,iii)=expfac
5066           enddo ! j
5067
5068         enddo ! iii
5069
5070         x(3)=x3
5071 C As in the case of ebend, we want to avoid underflows in exponentiation and
5072 C subsequent NaNs and INFs in energy calculation.
5073 C Find the largest exponent
5074         emin=contr(1,-1)
5075         do iii=-1,1
5076           do j=1,nlobit
5077             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5078           enddo
5079         enddo
5080         emin=0.5D0*emin
5081 cd      print *,'it=',it,' emin=',emin
5082
5083 C Compute the contribution to SC energy and derivatives
5084         do iii=-1,1
5085
5086           do j=1,nlobit
5087 #ifdef OSF
5088             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5089             if(adexp.ne.adexp) adexp=1.0
5090             expfac=dexp(adexp)
5091 #else
5092             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5093 #endif
5094 cd          print *,'j=',j,' expfac=',expfac
5095             escloc_i=escloc_i+expfac
5096             do k=1,3
5097               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5098             enddo
5099             if (mixed) then
5100               do k=1,3,2
5101                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5102      &            +gaussc(k,2,j,it))*expfac
5103               enddo
5104             endif
5105           enddo
5106
5107         enddo ! iii
5108
5109         dersc(1)=dersc(1)/cos(theti)**2
5110         ddersc(1)=ddersc(1)/cos(theti)**2
5111         ddersc(3)=ddersc(3)
5112
5113         escloci=-(dlog(escloc_i)-emin)
5114         do j=1,3
5115           dersc(j)=dersc(j)/escloc_i
5116         enddo
5117         if (mixed) then
5118           do j=1,3,2
5119             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5120           enddo
5121         endif
5122       return
5123       end
5124 C------------------------------------------------------------------------------
5125       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5126       implicit real*8 (a-h,o-z)
5127       include 'DIMENSIONS'
5128       include 'COMMON.GEO'
5129       include 'COMMON.LOCAL'
5130       include 'COMMON.IOUNITS'
5131       common /sccalc/ time11,time12,time112,theti,it,nlobit
5132       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5133       double precision contr(maxlob)
5134       logical mixed
5135
5136       escloc_i=0.0D0
5137
5138       do j=1,3
5139         dersc(j)=0.0D0
5140       enddo
5141
5142       do j=1,nlobit
5143         do k=1,2
5144           z(k)=x(k)-censc(k,j,it)
5145         enddo
5146         z(3)=dwapi
5147         do k=1,3
5148           Axk=0.0D0
5149           do l=1,3
5150             Axk=Axk+gaussc(l,k,j,it)*z(l)
5151           enddo
5152           Ax(k,j)=Axk
5153         enddo
5154         expfac=0.0D0
5155         do k=1,3
5156           expfac=expfac+Ax(k,j)*z(k)
5157         enddo
5158         contr(j)=expfac
5159       enddo ! j
5160
5161 C As in the case of ebend, we want to avoid underflows in exponentiation and
5162 C subsequent NaNs and INFs in energy calculation.
5163 C Find the largest exponent
5164       emin=contr(1)
5165       do j=1,nlobit
5166         if (emin.gt.contr(j)) emin=contr(j)
5167       enddo
5168       emin=0.5D0*emin
5169
5170 C Compute the contribution to SC energy and derivatives
5171
5172       dersc12=0.0d0
5173       do j=1,nlobit
5174         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5175         escloc_i=escloc_i+expfac
5176         do k=1,2
5177           dersc(k)=dersc(k)+Ax(k,j)*expfac
5178         enddo
5179         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5180      &            +gaussc(1,2,j,it))*expfac
5181         dersc(3)=0.0d0
5182       enddo
5183
5184       dersc(1)=dersc(1)/cos(theti)**2
5185       dersc12=dersc12/cos(theti)**2
5186       escloci=-(dlog(escloc_i)-emin)
5187       do j=1,2
5188         dersc(j)=dersc(j)/escloc_i
5189       enddo
5190       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5191       return
5192       end
5193 #else
5194 c----------------------------------------------------------------------------------
5195       subroutine esc(escloc)
5196 C Calculate the local energy of a side chain and its derivatives in the
5197 C corresponding virtual-bond valence angles THETA and the spherical angles
5198 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5199 C added by Urszula Kozlowska. 07/11/2007
5200 C
5201       implicit real*8 (a-h,o-z)
5202       include 'DIMENSIONS'
5203       include 'COMMON.GEO'
5204       include 'COMMON.LOCAL'
5205       include 'COMMON.VAR'
5206       include 'COMMON.SCROT'
5207       include 'COMMON.INTERACT'
5208       include 'COMMON.DERIV'
5209       include 'COMMON.CHAIN'
5210       include 'COMMON.IOUNITS'
5211       include 'COMMON.NAMES'
5212       include 'COMMON.FFIELD'
5213       include 'COMMON.CONTROL'
5214       include 'COMMON.VECTORS'
5215       double precision x_prime(3),y_prime(3),z_prime(3)
5216      &    , sumene,dsc_i,dp2_i,x(65),
5217      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5218      &    de_dxx,de_dyy,de_dzz,de_dt
5219       double precision s1_t,s1_6_t,s2_t,s2_6_t
5220       double precision
5221      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5222      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5223      & dt_dCi(3),dt_dCi1(3)
5224       common /sccalc/ time11,time12,time112,theti,it,nlobit
5225       delta=0.02d0*pi
5226       escloc=0.0D0
5227       do i=loc_start,loc_end
5228         costtab(i+1) =dcos(theta(i+1))
5229         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5230         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5231         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5232         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5233         cosfac=dsqrt(cosfac2)
5234         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5235         sinfac=dsqrt(sinfac2)
5236         it=itype(i)
5237         if (it.eq.10) goto 1
5238 c
5239 C  Compute the axes of tghe local cartesian coordinates system; store in
5240 c   x_prime, y_prime and z_prime
5241 c
5242         do j=1,3
5243           x_prime(j) = 0.00
5244           y_prime(j) = 0.00
5245           z_prime(j) = 0.00
5246         enddo
5247 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5248 C     &   dc_norm(3,i+nres)
5249         do j = 1,3
5250           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5251           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5252         enddo
5253         do j = 1,3
5254           z_prime(j) = -uz(j,i-1)
5255         enddo
5256 c       write (2,*) "i",i
5257 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5258 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5259 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5260 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5261 c      & " xy",scalar(x_prime(1),y_prime(1)),
5262 c      & " xz",scalar(x_prime(1),z_prime(1)),
5263 c      & " yy",scalar(y_prime(1),y_prime(1)),
5264 c      & " yz",scalar(y_prime(1),z_prime(1)),
5265 c      & " zz",scalar(z_prime(1),z_prime(1))
5266 c
5267 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5268 C to local coordinate system. Store in xx, yy, zz.
5269 c
5270         xx=0.0d0
5271         yy=0.0d0
5272         zz=0.0d0
5273         do j = 1,3
5274           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5275           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5276           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5277         enddo
5278
5279         xxtab(i)=xx
5280         yytab(i)=yy
5281         zztab(i)=zz
5282 C
5283 C Compute the energy of the ith side cbain
5284 C
5285 c        write (2,*) "xx",xx," yy",yy," zz",zz
5286         it=itype(i)
5287         do j = 1,65
5288           x(j) = sc_parmin(j,it)
5289         enddo
5290 #ifdef CHECK_COORD
5291 Cc diagnostics - remove later
5292         xx1 = dcos(alph(2))
5293         yy1 = dsin(alph(2))*dcos(omeg(2))
5294         zz1 = -dsin(alph(2))*dsin(omeg(2))
5295         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5296      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5297      &    xx1,yy1,zz1
5298 C,"  --- ", xx_w,yy_w,zz_w
5299 c end diagnostics
5300 #endif
5301         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5302      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5303      &   + x(10)*yy*zz
5304         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5305      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5306      & + x(20)*yy*zz
5307         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5308      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5309      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5310      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5311      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5312      &  +x(40)*xx*yy*zz
5313         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5314      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5315      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5316      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5317      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5318      &  +x(60)*xx*yy*zz
5319         dsc_i   = 0.743d0+x(61)
5320         dp2_i   = 1.9d0+x(62)
5321         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5322      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5323         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5324      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5325         s1=(1+x(63))/(0.1d0 + dscp1)
5326         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5327         s2=(1+x(65))/(0.1d0 + dscp2)
5328         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5329         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5330      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5331 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5332 c     &   sumene4,
5333 c     &   dscp1,dscp2,sumene
5334 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5335         escloc = escloc + sumene
5336 c        write (2,*) "i",i," escloc",sumene,escloc
5337 #ifdef DEBUG
5338 C
5339 C This section to check the numerical derivatives of the energy of ith side
5340 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5341 C #define DEBUG in the code to turn it on.
5342 C
5343         write (2,*) "sumene               =",sumene
5344         aincr=1.0d-7
5345         xxsave=xx
5346         xx=xx+aincr
5347         write (2,*) xx,yy,zz
5348         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5349         de_dxx_num=(sumenep-sumene)/aincr
5350         xx=xxsave
5351         write (2,*) "xx+ sumene from enesc=",sumenep
5352         yysave=yy
5353         yy=yy+aincr
5354         write (2,*) xx,yy,zz
5355         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5356         de_dyy_num=(sumenep-sumene)/aincr
5357         yy=yysave
5358         write (2,*) "yy+ sumene from enesc=",sumenep
5359         zzsave=zz
5360         zz=zz+aincr
5361         write (2,*) xx,yy,zz
5362         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5363         de_dzz_num=(sumenep-sumene)/aincr
5364         zz=zzsave
5365         write (2,*) "zz+ sumene from enesc=",sumenep
5366         costsave=cost2tab(i+1)
5367         sintsave=sint2tab(i+1)
5368         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5369         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5370         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5371         de_dt_num=(sumenep-sumene)/aincr
5372         write (2,*) " t+ sumene from enesc=",sumenep
5373         cost2tab(i+1)=costsave
5374         sint2tab(i+1)=sintsave
5375 C End of diagnostics section.
5376 #endif
5377 C
5378 C Compute the gradient of esc
5379 C
5380         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5381         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5382         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5383         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5384         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5385         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5386         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5387         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5388         pom1=(sumene3*sint2tab(i+1)+sumene1)
5389      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5390         pom2=(sumene4*cost2tab(i+1)+sumene2)
5391      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5392         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5393         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5394      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5395      &  +x(40)*yy*zz
5396         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5397         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5398      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5399      &  +x(60)*yy*zz
5400         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5401      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5402      &        +(pom1+pom2)*pom_dx
5403 #ifdef DEBUG
5404         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5405 #endif
5406 C
5407         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5408         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5409      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5410      &  +x(40)*xx*zz
5411         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5412         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5413      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5414      &  +x(59)*zz**2 +x(60)*xx*zz
5415         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5416      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5417      &        +(pom1-pom2)*pom_dy
5418 #ifdef DEBUG
5419         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5420 #endif
5421 C
5422         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5423      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5424      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5425      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5426      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5427      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5428      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5429      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5430 #ifdef DEBUG
5431         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5432 #endif
5433 C
5434         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5435      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5436      &  +pom1*pom_dt1+pom2*pom_dt2
5437 #ifdef DEBUG
5438         write(2,*), "de_dt = ", de_dt,de_dt_num
5439 #endif
5440 c
5441 C
5442        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5443        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5444        cosfac2xx=cosfac2*xx
5445        sinfac2yy=sinfac2*yy
5446        do k = 1,3
5447          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5448      &      vbld_inv(i+1)
5449          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5450      &      vbld_inv(i)
5451          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5452          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5453 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5454 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5455 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5456 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5457          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5458          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5459          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5460          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5461          dZZ_Ci1(k)=0.0d0
5462          dZZ_Ci(k)=0.0d0
5463          do j=1,3
5464            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5465            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5466          enddo
5467
5468          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5469          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5470          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5471 c
5472          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5473          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5474        enddo
5475
5476        do k=1,3
5477          dXX_Ctab(k,i)=dXX_Ci(k)
5478          dXX_C1tab(k,i)=dXX_Ci1(k)
5479          dYY_Ctab(k,i)=dYY_Ci(k)
5480          dYY_C1tab(k,i)=dYY_Ci1(k)
5481          dZZ_Ctab(k,i)=dZZ_Ci(k)
5482          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5483          dXX_XYZtab(k,i)=dXX_XYZ(k)
5484          dYY_XYZtab(k,i)=dYY_XYZ(k)
5485          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5486        enddo
5487
5488        do k = 1,3
5489 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5490 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5491 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5492 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5493 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5494 c     &    dt_dci(k)
5495 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5496 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5497          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5498      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5499          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5500      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5501          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5502      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5503        enddo
5504 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5505 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5506
5507 C to check gradient call subroutine check_grad
5508
5509     1 continue
5510       enddo
5511       return
5512       end
5513 c------------------------------------------------------------------------------
5514       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5515       implicit none
5516       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5517      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5518       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5519      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5520      &   + x(10)*yy*zz
5521       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5522      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5523      & + x(20)*yy*zz
5524       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5525      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5526      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5527      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5528      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5529      &  +x(40)*xx*yy*zz
5530       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5531      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5532      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5533      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5534      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5535      &  +x(60)*xx*yy*zz
5536       dsc_i   = 0.743d0+x(61)
5537       dp2_i   = 1.9d0+x(62)
5538       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5539      &          *(xx*cost2+yy*sint2))
5540       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5541      &          *(xx*cost2-yy*sint2))
5542       s1=(1+x(63))/(0.1d0 + dscp1)
5543       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5544       s2=(1+x(65))/(0.1d0 + dscp2)
5545       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5546       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5547      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5548       enesc=sumene
5549       return
5550       end
5551 #endif
5552 c------------------------------------------------------------------------------
5553       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5554 C
5555 C This procedure calculates two-body contact function g(rij) and its derivative:
5556 C
5557 C           eps0ij                                     !       x < -1
5558 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5559 C            0                                         !       x > 1
5560 C
5561 C where x=(rij-r0ij)/delta
5562 C
5563 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5564 C
5565       implicit none
5566       double precision rij,r0ij,eps0ij,fcont,fprimcont
5567       double precision x,x2,x4,delta
5568 c     delta=0.02D0*r0ij
5569 c      delta=0.2D0*r0ij
5570       x=(rij-r0ij)/delta
5571       if (x.lt.-1.0D0) then
5572         fcont=eps0ij
5573         fprimcont=0.0D0
5574       else if (x.le.1.0D0) then
5575         x2=x*x
5576         x4=x2*x2
5577         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5578         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5579       else
5580         fcont=0.0D0
5581         fprimcont=0.0D0
5582       endif
5583       return
5584       end
5585 c------------------------------------------------------------------------------
5586       subroutine splinthet(theti,delta,ss,ssder)
5587       implicit real*8 (a-h,o-z)
5588       include 'DIMENSIONS'
5589       include 'COMMON.VAR'
5590       include 'COMMON.GEO'
5591       thetup=pi-delta
5592       thetlow=delta
5593       if (theti.gt.pipol) then
5594         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5595       else
5596         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5597         ssder=-ssder
5598       endif
5599       return
5600       end
5601 c------------------------------------------------------------------------------
5602       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5603       implicit none
5604       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5605       double precision ksi,ksi2,ksi3,a1,a2,a3
5606       a1=fprim0*delta/(f1-f0)
5607       a2=3.0d0-2.0d0*a1
5608       a3=a1-2.0d0
5609       ksi=(x-x0)/delta
5610       ksi2=ksi*ksi
5611       ksi3=ksi2*ksi
5612       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5613       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5614       return
5615       end
5616 c------------------------------------------------------------------------------
5617       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5618       implicit none
5619       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5620       double precision ksi,ksi2,ksi3,a1,a2,a3
5621       ksi=(x-x0)/delta
5622       ksi2=ksi*ksi
5623       ksi3=ksi2*ksi
5624       a1=fprim0x*delta
5625       a2=3*(f1x-f0x)-2*fprim0x*delta
5626       a3=fprim0x*delta-2*(f1x-f0x)
5627       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5628       return
5629       end
5630 C-----------------------------------------------------------------------------
5631 #ifdef CRYST_TOR
5632 C-----------------------------------------------------------------------------
5633       subroutine etor(etors,edihcnstr)
5634       implicit real*8 (a-h,o-z)
5635       include 'DIMENSIONS'
5636       include 'COMMON.VAR'
5637       include 'COMMON.GEO'
5638       include 'COMMON.LOCAL'
5639       include 'COMMON.TORSION'
5640       include 'COMMON.INTERACT'
5641       include 'COMMON.DERIV'
5642       include 'COMMON.CHAIN'
5643       include 'COMMON.NAMES'
5644       include 'COMMON.IOUNITS'
5645       include 'COMMON.FFIELD'
5646       include 'COMMON.TORCNSTR'
5647       include 'COMMON.CONTROL'
5648       logical lprn
5649 C Set lprn=.true. for debugging
5650       lprn=.false.
5651 c      lprn=.true.
5652       etors=0.0D0
5653       do i=iphi_start,iphi_end
5654       etors_ii=0.0D0
5655         itori=itortyp(itype(i-2))
5656         itori1=itortyp(itype(i-1))
5657         phii=phi(i)
5658         gloci=0.0D0
5659 C Proline-Proline pair is a special case...
5660         if (itori.eq.3 .and. itori1.eq.3) then
5661           if (phii.gt.-dwapi3) then
5662             cosphi=dcos(3*phii)
5663             fac=1.0D0/(1.0D0-cosphi)
5664             etorsi=v1(1,3,3)*fac
5665             etorsi=etorsi+etorsi
5666             etors=etors+etorsi-v1(1,3,3)
5667             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5668             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5669           endif
5670           do j=1,3
5671             v1ij=v1(j+1,itori,itori1)
5672             v2ij=v2(j+1,itori,itori1)
5673             cosphi=dcos(j*phii)
5674             sinphi=dsin(j*phii)
5675             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5676             if (energy_dec) etors_ii=etors_ii+
5677      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5678             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5679           enddo
5680         else
5681           do j=1,nterm_old
5682             v1ij=v1(j,itori,itori1)
5683             v2ij=v2(j,itori,itori1)
5684             cosphi=dcos(j*phii)
5685             sinphi=dsin(j*phii)
5686             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5687             if (energy_dec) etors_ii=etors_ii+
5688      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5689             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5690           enddo
5691         endif
5692         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5693      &        'etor',i,etors_ii
5694         if (lprn)
5695      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5696      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5697      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5698         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5699 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5700       enddo
5701 ! 6/20/98 - dihedral angle constraints
5702       edihcnstr=0.0d0
5703       do i=1,ndih_constr
5704         itori=idih_constr(i)
5705         phii=phi(itori)
5706         difi=phii-phi0(i)
5707         if (difi.gt.drange(i)) then
5708           difi=difi-drange(i)
5709           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5710           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5711         else if (difi.lt.-drange(i)) then
5712           difi=difi+drange(i)
5713           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5714           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5715         endif
5716 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5717 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5718       enddo
5719 !      write (iout,*) 'edihcnstr',edihcnstr
5720       return
5721       end
5722 c------------------------------------------------------------------------------
5723       subroutine etor_d(etors_d)
5724       etors_d=0.0d0
5725       return
5726       end
5727 c----------------------------------------------------------------------------
5728 #else
5729       subroutine etor(etors,edihcnstr)
5730       implicit real*8 (a-h,o-z)
5731       include 'DIMENSIONS'
5732       include 'COMMON.VAR'
5733       include 'COMMON.GEO'
5734       include 'COMMON.LOCAL'
5735       include 'COMMON.TORSION'
5736       include 'COMMON.INTERACT'
5737       include 'COMMON.DERIV'
5738       include 'COMMON.CHAIN'
5739       include 'COMMON.NAMES'
5740       include 'COMMON.IOUNITS'
5741       include 'COMMON.FFIELD'
5742       include 'COMMON.TORCNSTR'
5743       include 'COMMON.CONTROL'
5744       logical lprn
5745 C Set lprn=.true. for debugging
5746       lprn=.false.
5747 c     lprn=.true.
5748       etors=0.0D0
5749       do i=iphi_start,iphi_end
5750       etors_ii=0.0D0
5751         itori=itortyp(itype(i-2))
5752         itori1=itortyp(itype(i-1))
5753         phii=phi(i)
5754         gloci=0.0D0
5755 C Regular cosine and sine terms
5756         do j=1,nterm(itori,itori1)
5757           v1ij=v1(j,itori,itori1)
5758           v2ij=v2(j,itori,itori1)
5759           cosphi=dcos(j*phii)
5760           sinphi=dsin(j*phii)
5761           etors=etors+v1ij*cosphi+v2ij*sinphi
5762           if (energy_dec) etors_ii=etors_ii+
5763      &                v1ij*cosphi+v2ij*sinphi
5764           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5765         enddo
5766 C Lorentz terms
5767 C                         v1
5768 C  E = SUM ----------------------------------- - v1
5769 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5770 C
5771         cosphi=dcos(0.5d0*phii)
5772         sinphi=dsin(0.5d0*phii)
5773         do j=1,nlor(itori,itori1)
5774           vl1ij=vlor1(j,itori,itori1)
5775           vl2ij=vlor2(j,itori,itori1)
5776           vl3ij=vlor3(j,itori,itori1)
5777           pom=vl2ij*cosphi+vl3ij*sinphi
5778           pom1=1.0d0/(pom*pom+1.0d0)
5779           etors=etors+vl1ij*pom1
5780           if (energy_dec) etors_ii=etors_ii+
5781      &                vl1ij*pom1
5782           pom=-pom*pom1*pom1
5783           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5784         enddo
5785 C Subtract the constant term
5786         etors=etors-v0(itori,itori1)
5787           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5788      &         'etor',i,etors_ii-v0(itori,itori1)
5789         if (lprn)
5790      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5791      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5792      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5793         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5794 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5795       enddo
5796 ! 6/20/98 - dihedral angle constraints
5797       edihcnstr=0.0d0
5798 c      do i=1,ndih_constr
5799       do i=idihconstr_start,idihconstr_end
5800         itori=idih_constr(i)
5801         phii=phi(itori)
5802         difi=pinorm(phii-phi0(i))
5803         if (difi.gt.drange(i)) then
5804           difi=difi-drange(i)
5805           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5806           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5807         else if (difi.lt.-drange(i)) then
5808           difi=difi+drange(i)
5809           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5810           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5811         else
5812           difi=0.0
5813         endif
5814 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5815 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5816 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5817       enddo
5818 cd       write (iout,*) 'edihcnstr',edihcnstr
5819       return
5820       end
5821 c----------------------------------------------------------------------------
5822       subroutine etor_d(etors_d)
5823 C 6/23/01 Compute double torsional energy
5824       implicit real*8 (a-h,o-z)
5825       include 'DIMENSIONS'
5826       include 'COMMON.VAR'
5827       include 'COMMON.GEO'
5828       include 'COMMON.LOCAL'
5829       include 'COMMON.TORSION'
5830       include 'COMMON.INTERACT'
5831       include 'COMMON.DERIV'
5832       include 'COMMON.CHAIN'
5833       include 'COMMON.NAMES'
5834       include 'COMMON.IOUNITS'
5835       include 'COMMON.FFIELD'
5836       include 'COMMON.TORCNSTR'
5837       logical lprn
5838 C Set lprn=.true. for debugging
5839       lprn=.false.
5840 c     lprn=.true.
5841       etors_d=0.0D0
5842       do i=iphid_start,iphid_end
5843         itori=itortyp(itype(i-2))
5844         itori1=itortyp(itype(i-1))
5845         itori2=itortyp(itype(i))
5846         phii=phi(i)
5847         phii1=phi(i+1)
5848         gloci1=0.0D0
5849         gloci2=0.0D0
5850 C Regular cosine and sine terms
5851         do j=1,ntermd_1(itori,itori1,itori2)
5852           v1cij=v1c(1,j,itori,itori1,itori2)
5853           v1sij=v1s(1,j,itori,itori1,itori2)
5854           v2cij=v1c(2,j,itori,itori1,itori2)
5855           v2sij=v1s(2,j,itori,itori1,itori2)
5856           cosphi1=dcos(j*phii)
5857           sinphi1=dsin(j*phii)
5858           cosphi2=dcos(j*phii1)
5859           sinphi2=dsin(j*phii1)
5860           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5861      &     v2cij*cosphi2+v2sij*sinphi2
5862           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5863           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5864         enddo
5865         do k=2,ntermd_2(itori,itori1,itori2)
5866           do l=1,k-1
5867             v1cdij = v2c(k,l,itori,itori1,itori2)
5868             v2cdij = v2c(l,k,itori,itori1,itori2)
5869             v1sdij = v2s(k,l,itori,itori1,itori2)
5870             v2sdij = v2s(l,k,itori,itori1,itori2)
5871             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5872             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5873             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5874             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5875             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5876      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5877             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5878      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5879             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5880      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5881           enddo
5882         enddo
5883         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5884         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5885       enddo
5886       return
5887       end
5888 #endif
5889 c------------------------------------------------------------------------------
5890       subroutine eback_sc_corr(esccor)
5891 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5892 c        conformational states; temporarily implemented as differences
5893 c        between UNRES torsional potentials (dependent on three types of
5894 c        residues) and the torsional potentials dependent on all 20 types
5895 c        of residues computed from AM1  energy surfaces of terminally-blocked
5896 c        amino-acid residues.
5897       implicit real*8 (a-h,o-z)
5898       include 'DIMENSIONS'
5899       include 'COMMON.VAR'
5900       include 'COMMON.GEO'
5901       include 'COMMON.LOCAL'
5902       include 'COMMON.TORSION'
5903       include 'COMMON.SCCOR'
5904       include 'COMMON.INTERACT'
5905       include 'COMMON.DERIV'
5906       include 'COMMON.CHAIN'
5907       include 'COMMON.NAMES'
5908       include 'COMMON.IOUNITS'
5909       include 'COMMON.FFIELD'
5910       include 'COMMON.CONTROL'
5911       logical lprn
5912 C Set lprn=.true. for debugging
5913       lprn=.false.
5914 c      lprn=.true.
5915 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5916       esccor=0.0D0
5917       do i=itau_start,itau_end
5918         esccor_ii=0.0D0
5919         isccori=isccortyp(itype(i-2))
5920         isccori1=isccortyp(itype(i-1))
5921 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5922         phii=phi(i)
5923         do intertyp=1,3 !intertyp
5924 cc Added 09 May 2012 (Adasko)
5925 cc  Intertyp means interaction type of backbone mainchain correlation:
5926 c   1 = SC...Ca...Ca...Ca
5927 c   2 = Ca...Ca...Ca...SC
5928 c   3 = SC...Ca...Ca...SCi
5929         gloci=0.0D0
5930         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5931      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5932      &      (itype(i-1).eq.ntyp1)))
5933      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5934      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5935      &     .or.(itype(i).eq.ntyp1)))
5936      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5937      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5938      &      (itype(i-3).eq.ntyp1)))) cycle
5939         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5940         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5941      & cycle
5942        do j=1,nterm_sccor(isccori,isccori1)
5943           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5944           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5945           cosphi=dcos(j*tauangle(intertyp,i))
5946           sinphi=dsin(j*tauangle(intertyp,i))
5947           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5948           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5949         enddo
5950 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5951         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5952         if (lprn)
5953      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5954      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5955      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5956      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5957 C        gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5958        enddo !intertyp
5959       enddo
5960
5961       return
5962       end
5963 c----------------------------------------------------------------------------
5964       subroutine multibody(ecorr)
5965 C This subroutine calculates multi-body contributions to energy following
5966 C the idea of Skolnick et al. If side chains I and J make a contact and
5967 C at the same time side chains I+1 and J+1 make a contact, an extra
5968 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5969       implicit real*8 (a-h,o-z)
5970       include 'DIMENSIONS'
5971       include 'COMMON.IOUNITS'
5972       include 'COMMON.DERIV'
5973       include 'COMMON.INTERACT'
5974       include 'COMMON.CONTACTS'
5975 #ifdef MOMENT
5976       include 'COMMON.CONTACTS.MOMENT'
5977 #endif
5978       double precision gx(3),gx1(3)
5979       logical lprn
5980
5981 C Set lprn=.true. for debugging
5982       lprn=.false.
5983
5984       if (lprn) then
5985         write (iout,'(a)') 'Contact function values:'
5986         do i=nnt,nct-2
5987           write (iout,'(i2,20(1x,i2,f10.5))')
5988      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5989         enddo
5990       endif
5991       ecorr=0.0D0
5992       do i=nnt,nct
5993         do j=1,3
5994           gradcorr(j,i)=0.0D0
5995           gradxorr(j,i)=0.0D0
5996         enddo
5997       enddo
5998       do i=nnt,nct-2
5999
6000         DO ISHIFT = 3,4
6001
6002         i1=i+ishift
6003         num_conti=num_cont(i)
6004         num_conti1=num_cont(i1)
6005         do jj=1,num_conti
6006           j=jcont(jj,i)
6007           do kk=1,num_conti1
6008             j1=jcont(kk,i1)
6009             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6010 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6011 cd   &                   ' ishift=',ishift
6012 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6013 C The system gains extra energy.
6014               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6015             endif   ! j1==j+-ishift
6016           enddo     ! kk
6017         enddo       ! jj
6018
6019         ENDDO ! ISHIFT
6020
6021       enddo         ! i
6022       return
6023       end
6024 c------------------------------------------------------------------------------
6025       double precision function esccorr(i,j,k,l,jj,kk)
6026       implicit real*8 (a-h,o-z)
6027       include 'DIMENSIONS'
6028       include 'COMMON.IOUNITS'
6029       include 'COMMON.DERIV'
6030       include 'COMMON.INTERACT'
6031       include 'COMMON.CONTACTS'
6032 #ifdef MOMENT
6033       include 'COMMON.CONTACTS.MOMENT'
6034 #endif
6035       double precision gx(3),gx1(3)
6036       logical lprn
6037       lprn=.false.
6038       eij=facont(jj,i)
6039       ekl=facont(kk,k)
6040 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6041 C Calculate the multi-body contribution to energy.
6042 C Calculate multi-body contributions to the gradient.
6043 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6044 cd   & k,l,(gacont(m,kk,k),m=1,3)
6045       do m=1,3
6046         gx(m) =ekl*gacont(m,jj,i)
6047         gx1(m)=eij*gacont(m,kk,k)
6048         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6049         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6050         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6051         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6052       enddo
6053       do m=i,j-1
6054         do ll=1,3
6055           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6056         enddo
6057       enddo
6058       do m=k,l-1
6059         do ll=1,3
6060           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6061         enddo
6062       enddo
6063       esccorr=-eij*ekl
6064       return
6065       end
6066 c------------------------------------------------------------------------------
6067       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6068 C This subroutine calculates multi-body contributions to hydrogen-bonding
6069       implicit real*8 (a-h,o-z)
6070       include 'DIMENSIONS'
6071       include 'COMMON.IOUNITS'
6072 #ifdef MPI
6073       include "mpif.h"
6074       parameter (max_cont=maxconts)
6075       parameter (max_dim=26)
6076       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6077       double precision zapas(max_dim,maxconts,max_fg_procs),
6078      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6079       common /przechowalnia/ zapas
6080       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6081      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6082 #endif
6083       include 'COMMON.SETUP'
6084       include 'COMMON.FFIELD'
6085       include 'COMMON.DERIV'
6086       include 'COMMON.INTERACT'
6087       include 'COMMON.CONTACTS'
6088 #ifdef MOMENT
6089       include 'COMMON.CONTACTS.MOMENT'
6090 #endif
6091       include 'COMMON.CONTROL'
6092       include 'COMMON.LOCAL'
6093       double precision gx(3),gx1(3),time00
6094       logical lprn,ldone
6095
6096 C Set lprn=.true. for debugging
6097       lprn=.false.
6098 #ifdef MPI
6099       n_corr=0
6100       n_corr1=0
6101       if (nfgtasks.le.1) goto 30
6102       if (lprn) then
6103         write (iout,'(a)') 'Contact function values before RECEIVE:'
6104         do i=nnt,nct-2
6105           write (iout,'(2i3,50(1x,i2,f5.2))')
6106      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6107      &    j=1,num_cont_hb(i))
6108         enddo
6109       endif
6110       call flush(iout)
6111       do i=1,ntask_cont_from
6112         ncont_recv(i)=0
6113       enddo
6114       do i=1,ntask_cont_to
6115         ncont_sent(i)=0
6116       enddo
6117 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6118 c     & ntask_cont_to
6119 C Make the list of contacts to send to send to other procesors
6120 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6121 c      call flush(iout)
6122       do i=iturn3_start,iturn3_end
6123 c        write (iout,*) "make contact list turn3",i," num_cont",
6124 c     &    num_cont_hb(i)
6125         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6126       enddo
6127       do i=iturn4_start,iturn4_end
6128 c        write (iout,*) "make contact list turn4",i," num_cont",
6129 c     &   num_cont_hb(i)
6130         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6131       enddo
6132       do ii=1,nat_sent
6133         i=iat_sent(ii)
6134 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6135 c     &    num_cont_hb(i)
6136         do j=1,num_cont_hb(i)
6137         do k=1,4
6138           jjc=jcont_hb(j,i)
6139           iproc=iint_sent_local(k,jjc,ii)
6140 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6141           if (iproc.gt.0) then
6142             ncont_sent(iproc)=ncont_sent(iproc)+1
6143             nn=ncont_sent(iproc)
6144             zapas(1,nn,iproc)=i
6145             zapas(2,nn,iproc)=jjc
6146             zapas(3,nn,iproc)=facont_hb(j,i)
6147             zapas(4,nn,iproc)=ees0p(j,i)
6148             zapas(5,nn,iproc)=ees0m(j,i)
6149             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6150             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6151             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6152             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6153             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6154             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6155             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6156             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6157             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6158             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6159             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6160             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6161             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6162             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6163             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6164             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6165             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6166             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6167             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6168             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6169             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6170           endif
6171         enddo
6172         enddo
6173       enddo
6174       if (lprn) then
6175       write (iout,*)
6176      &  "Numbers of contacts to be sent to other processors",
6177      &  (ncont_sent(i),i=1,ntask_cont_to)
6178       write (iout,*) "Contacts sent"
6179       do ii=1,ntask_cont_to
6180         nn=ncont_sent(ii)
6181         iproc=itask_cont_to(ii)
6182         write (iout,*) nn," contacts to processor",iproc,
6183      &   " of CONT_TO_COMM group"
6184         do i=1,nn
6185           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6186         enddo
6187       enddo
6188       call flush(iout)
6189       endif
6190       CorrelType=477
6191       CorrelID=fg_rank+1
6192       CorrelType1=478
6193       CorrelID1=nfgtasks+fg_rank+1
6194       ireq=0
6195 C Receive the numbers of needed contacts from other processors
6196       do ii=1,ntask_cont_from
6197         iproc=itask_cont_from(ii)
6198         ireq=ireq+1
6199         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6200      &    FG_COMM,req(ireq),IERR)
6201       enddo
6202 c      write (iout,*) "IRECV ended"
6203 c      call flush(iout)
6204 C Send the number of contacts needed by other processors
6205       do ii=1,ntask_cont_to
6206         iproc=itask_cont_to(ii)
6207         ireq=ireq+1
6208         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6209      &    FG_COMM,req(ireq),IERR)
6210       enddo
6211 c      write (iout,*) "ISEND ended"
6212 c      write (iout,*) "number of requests (nn)",ireq
6213       call flush(iout)
6214       if (ireq.gt.0)
6215      &  call MPI_Waitall(ireq,req,status_array,ierr)
6216 c      write (iout,*)
6217 c     &  "Numbers of contacts to be received from other processors",
6218 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6219 c      call flush(iout)
6220 C Receive contacts
6221       ireq=0
6222       do ii=1,ntask_cont_from
6223         iproc=itask_cont_from(ii)
6224         nn=ncont_recv(ii)
6225 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6226 c     &   " of CONT_TO_COMM group"
6227         call flush(iout)
6228         if (nn.gt.0) then
6229           ireq=ireq+1
6230           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6231      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6232 c          write (iout,*) "ireq,req",ireq,req(ireq)
6233         endif
6234       enddo
6235 C Send the contacts to processors that need them
6236       do ii=1,ntask_cont_to
6237         iproc=itask_cont_to(ii)
6238         nn=ncont_sent(ii)
6239 c        write (iout,*) nn," contacts to processor",iproc,
6240 c     &   " of CONT_TO_COMM group"
6241         if (nn.gt.0) then
6242           ireq=ireq+1
6243           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6244      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6245 c          write (iout,*) "ireq,req",ireq,req(ireq)
6246 c          do i=1,nn
6247 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6248 c          enddo
6249         endif
6250       enddo
6251 c      write (iout,*) "number of requests (contacts)",ireq
6252 c      write (iout,*) "req",(req(i),i=1,4)
6253 c      call flush(iout)
6254       if (ireq.gt.0)
6255      & call MPI_Waitall(ireq,req,status_array,ierr)
6256       do iii=1,ntask_cont_from
6257         iproc=itask_cont_from(iii)
6258         nn=ncont_recv(iii)
6259         if (lprn) then
6260         write (iout,*) "Received",nn," contacts from processor",iproc,
6261      &   " of CONT_FROM_COMM group"
6262         call flush(iout)
6263         do i=1,nn
6264           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6265         enddo
6266         call flush(iout)
6267         endif
6268         do i=1,nn
6269           ii=zapas_recv(1,i,iii)
6270 c Flag the received contacts to prevent double-counting
6271           jj=-zapas_recv(2,i,iii)
6272 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6273 c          call flush(iout)
6274           nnn=num_cont_hb(ii)+1
6275           num_cont_hb(ii)=nnn
6276           jcont_hb(nnn,ii)=jj
6277           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6278           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6279           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6280           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6281           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6282           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6283           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6284           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6285           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6286           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6287           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6288           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6289           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6290           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6291           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6292           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6293           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6294           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6295           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6296           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6297           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6298           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6299           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6300           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6301         enddo
6302       enddo
6303       call flush(iout)
6304       if (lprn) then
6305         write (iout,'(a)') 'Contact function values after receive:'
6306         do i=nnt,nct-2
6307           write (iout,'(2i3,50(1x,i3,f5.2))')
6308      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6309      &    j=1,num_cont_hb(i))
6310         enddo
6311         call flush(iout)
6312       endif
6313    30 continue
6314 #endif
6315       if (lprn) then
6316         write (iout,'(a)') 'Contact function values:'
6317         do i=nnt,nct-2
6318           write (iout,'(2i3,50(1x,i3,f5.2))')
6319      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6320      &    j=1,num_cont_hb(i))
6321         enddo
6322       endif
6323       ecorr=0.0D0
6324 C Remove the loop below after debugging !!!
6325       do i=nnt,nct
6326         do j=1,3
6327           gradcorr(j,i)=0.0D0
6328           gradxorr(j,i)=0.0D0
6329         enddo
6330       enddo
6331 C Calculate the local-electrostatic correlation terms
6332       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6333         i1=i+1
6334         num_conti=num_cont_hb(i)
6335         num_conti1=num_cont_hb(i+1)
6336         do jj=1,num_conti
6337           j=jcont_hb(jj,i)
6338           jp=iabs(j)
6339           do kk=1,num_conti1
6340             j1=jcont_hb(kk,i1)
6341             jp1=iabs(j1)
6342 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6343 c     &         ' jj=',jj,' kk=',kk
6344             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6345      &          .or. j.lt.0 .and. j1.gt.0) .and.
6346      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6347 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6348 C The system gains extra energy.
6349               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6350               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6351      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6352               n_corr=n_corr+1
6353             else if (j1.eq.j) then
6354 C Contacts I-J and I-(J+1) occur simultaneously.
6355 C The system loses extra energy.
6356 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6357             endif
6358           enddo ! kk
6359           do kk=1,num_conti
6360             j1=jcont_hb(kk,i)
6361 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6362 c    &         ' jj=',jj,' kk=',kk
6363             if (j1.eq.j+1) then
6364 C Contacts I-J and (I+1)-J occur simultaneously.
6365 C The system loses extra energy.
6366 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6367             endif ! j1==j+1
6368           enddo ! kk
6369         enddo ! jj
6370       enddo ! i
6371       return
6372       end
6373 c------------------------------------------------------------------------------
6374       subroutine add_hb_contact(ii,jj,itask)
6375       implicit real*8 (a-h,o-z)
6376       include "DIMENSIONS"
6377       include "COMMON.IOUNITS"
6378       integer max_cont
6379       integer max_dim
6380       parameter (max_cont=maxconts)
6381       parameter (max_dim=26)
6382       include "COMMON.CONTACTS"
6383 #ifdef MOMENT
6384       include 'COMMON.CONTACTS.MOMENT'
6385 #endif
6386       double precision zapas(max_dim,maxconts,max_fg_procs),
6387      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6388       common /przechowalnia/ zapas
6389       integer i,j,ii,jj,iproc,itask(4),nn
6390 c      write (iout,*) "itask",itask
6391       do i=1,2
6392         iproc=itask(i)
6393         if (iproc.gt.0) then
6394           do j=1,num_cont_hb(ii)
6395             jjc=jcont_hb(j,ii)
6396 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6397             if (jjc.eq.jj) then
6398               ncont_sent(iproc)=ncont_sent(iproc)+1
6399               nn=ncont_sent(iproc)
6400               zapas(1,nn,iproc)=ii
6401               zapas(2,nn,iproc)=jjc
6402               zapas(3,nn,iproc)=facont_hb(j,ii)
6403               zapas(4,nn,iproc)=ees0p(j,ii)
6404               zapas(5,nn,iproc)=ees0m(j,ii)
6405               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6406               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6407               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6408               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6409               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6410               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6411               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6412               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6413               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6414               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6415               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6416               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6417               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6418               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6419               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6420               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6421               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6422               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6423               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6424               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6425               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6426               exit
6427             endif
6428           enddo
6429         endif
6430       enddo
6431       return
6432       end
6433 c------------------------------------------------------------------------------
6434       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6435      &  n_corr1)
6436 C This subroutine calculates multi-body contributions to hydrogen-bonding
6437       implicit real*8 (a-h,o-z)
6438       include 'DIMENSIONS'
6439       include 'COMMON.IOUNITS'
6440 #ifdef MPI
6441       include "mpif.h"
6442       parameter (max_cont=maxconts)
6443       parameter (max_dim=70)
6444       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6445       double precision zapas(max_dim,maxconts,max_fg_procs),
6446      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6447       common /przechowalnia/ zapas
6448       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6449      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6450 #endif
6451       include 'COMMON.SETUP'
6452       include 'COMMON.FFIELD'
6453       include 'COMMON.DERIV'
6454       include 'COMMON.LOCAL'
6455       include 'COMMON.INTERACT'
6456       include 'COMMON.CONTACTS'
6457 #ifdef MOMENT
6458       include 'COMMON.CONTACTS.MOMENT'
6459 #endif
6460       include 'COMMON.CHAIN'
6461       include 'COMMON.CONTROL'
6462       double precision gx(3),gx1(3)
6463       integer num_cont_hb_old(maxres)
6464       logical lprn,ldone
6465       double precision eello4,eello5,eelo6,eello_turn6
6466       external eello4,eello5,eello6,eello_turn6
6467 C Set lprn=.true. for debugging
6468       lprn=.false.
6469       eturn6=0.0d0
6470 #ifdef MPI
6471       do i=1,nres
6472         num_cont_hb_old(i)=num_cont_hb(i)
6473       enddo
6474       n_corr=0
6475       n_corr1=0
6476       if (nfgtasks.le.1) goto 30
6477       if (lprn) then
6478         write (iout,'(a)') 'Contact function values before RECEIVE:'
6479         do i=nnt,nct-2
6480           write (iout,'(2i3,50(1x,i2,f5.2))')
6481      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6482      &    j=1,num_cont_hb(i))
6483         enddo
6484       endif
6485       call flush(iout)
6486       do i=1,ntask_cont_from
6487         ncont_recv(i)=0
6488       enddo
6489       do i=1,ntask_cont_to
6490         ncont_sent(i)=0
6491       enddo
6492 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6493 c     & ntask_cont_to
6494 C Make the list of contacts to send to send to other procesors
6495       do i=iturn3_start,iturn3_end
6496 c        write (iout,*) "make contact list turn3",i," num_cont",
6497 c     &    num_cont_hb(i)
6498         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6499       enddo
6500       do i=iturn4_start,iturn4_end
6501 c        write (iout,*) "make contact list turn4",i," num_cont",
6502 c     &   num_cont_hb(i)
6503         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6504       enddo
6505       do ii=1,nat_sent
6506         i=iat_sent(ii)
6507 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6508 c     &    num_cont_hb(i)
6509         do j=1,num_cont_hb(i)
6510         do k=1,4
6511           jjc=jcont_hb(j,i)
6512           iproc=iint_sent_local(k,jjc,ii)
6513 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6514           if (iproc.ne.0) then
6515             ncont_sent(iproc)=ncont_sent(iproc)+1
6516             nn=ncont_sent(iproc)
6517             zapas(1,nn,iproc)=i
6518             zapas(2,nn,iproc)=jjc
6519             zapas(3,nn,iproc)=d_cont(j,i)
6520             ind=3
6521             do kk=1,3
6522               ind=ind+1
6523               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6524             enddo
6525             do kk=1,2
6526               do ll=1,2
6527                 ind=ind+1
6528                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6529               enddo
6530             enddo
6531             do jj=1,5
6532               do kk=1,3
6533                 do ll=1,2
6534                   do mm=1,2
6535                     ind=ind+1
6536                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6537                   enddo
6538                 enddo
6539               enddo
6540             enddo
6541           endif
6542         enddo
6543         enddo
6544       enddo
6545       if (lprn) then
6546       write (iout,*)
6547      &  "Numbers of contacts to be sent to other processors",
6548      &  (ncont_sent(i),i=1,ntask_cont_to)
6549       write (iout,*) "Contacts sent"
6550       do ii=1,ntask_cont_to
6551         nn=ncont_sent(ii)
6552         iproc=itask_cont_to(ii)
6553         write (iout,*) nn," contacts to processor",iproc,
6554      &   " of CONT_TO_COMM group"
6555         do i=1,nn
6556           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6557         enddo
6558       enddo
6559       call flush(iout)
6560       endif
6561       CorrelType=477
6562       CorrelID=fg_rank+1
6563       CorrelType1=478
6564       CorrelID1=nfgtasks+fg_rank+1
6565       ireq=0
6566 C Receive the numbers of needed contacts from other processors
6567       do ii=1,ntask_cont_from
6568         iproc=itask_cont_from(ii)
6569         ireq=ireq+1
6570         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6571      &    FG_COMM,req(ireq),IERR)
6572       enddo
6573 c      write (iout,*) "IRECV ended"
6574 c      call flush(iout)
6575 C Send the number of contacts needed by other processors
6576       do ii=1,ntask_cont_to
6577         iproc=itask_cont_to(ii)
6578         ireq=ireq+1
6579         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6580      &    FG_COMM,req(ireq),IERR)
6581       enddo
6582 c      write (iout,*) "ISEND ended"
6583 c      write (iout,*) "number of requests (nn)",ireq
6584       call flush(iout)
6585       if (ireq.gt.0)
6586      &  call MPI_Waitall(ireq,req,status_array,ierr)
6587 c      write (iout,*)
6588 c     &  "Numbers of contacts to be received from other processors",
6589 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6590 c      call flush(iout)
6591 C Receive contacts
6592       ireq=0
6593       do ii=1,ntask_cont_from
6594         iproc=itask_cont_from(ii)
6595         nn=ncont_recv(ii)
6596 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6597 c     &   " of CONT_TO_COMM group"
6598         call flush(iout)
6599         if (nn.gt.0) then
6600           ireq=ireq+1
6601           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6602      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6603 c          write (iout,*) "ireq,req",ireq,req(ireq)
6604         endif
6605       enddo
6606 C Send the contacts to processors that need them
6607       do ii=1,ntask_cont_to
6608         iproc=itask_cont_to(ii)
6609         nn=ncont_sent(ii)
6610 c        write (iout,*) nn," contacts to processor",iproc,
6611 c     &   " of CONT_TO_COMM group"
6612         if (nn.gt.0) then
6613           ireq=ireq+1
6614           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6615      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6616 c          write (iout,*) "ireq,req",ireq,req(ireq)
6617 c          do i=1,nn
6618 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6619 c          enddo
6620         endif
6621       enddo
6622 c      write (iout,*) "number of requests (contacts)",ireq
6623 c      write (iout,*) "req",(req(i),i=1,4)
6624 c      call flush(iout)
6625       if (ireq.gt.0)
6626      & call MPI_Waitall(ireq,req,status_array,ierr)
6627       do iii=1,ntask_cont_from
6628         iproc=itask_cont_from(iii)
6629         nn=ncont_recv(iii)
6630         if (lprn) then
6631         write (iout,*) "Received",nn," contacts from processor",iproc,
6632      &   " of CONT_FROM_COMM group"
6633         call flush(iout)
6634         do i=1,nn
6635           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6636         enddo
6637         call flush(iout)
6638         endif
6639         do i=1,nn
6640           ii=zapas_recv(1,i,iii)
6641 c Flag the received contacts to prevent double-counting
6642           jj=-zapas_recv(2,i,iii)
6643 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6644 c          call flush(iout)
6645           nnn=num_cont_hb(ii)+1
6646           num_cont_hb(ii)=nnn
6647           jcont_hb(nnn,ii)=jj
6648           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6649           ind=3
6650           do kk=1,3
6651             ind=ind+1
6652             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6653           enddo
6654           do kk=1,2
6655             do ll=1,2
6656               ind=ind+1
6657               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6658             enddo
6659           enddo
6660           do jj=1,5
6661             do kk=1,3
6662               do ll=1,2
6663                 do mm=1,2
6664                   ind=ind+1
6665                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6666                 enddo
6667               enddo
6668             enddo
6669           enddo
6670         enddo
6671       enddo
6672       call flush(iout)
6673       if (lprn) then
6674         write (iout,'(a)') 'Contact function values after receive:'
6675         do i=nnt,nct-2
6676           write (iout,'(2i3,50(1x,i3,5f6.3))')
6677      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6678      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6679         enddo
6680         call flush(iout)
6681       endif
6682    30 continue
6683 #endif
6684       if (lprn) then
6685         write (iout,'(a)') 'Contact function values:'
6686         do i=nnt,nct-2
6687           write (iout,'(2i3,50(1x,i2,5f6.3))')
6688      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6689      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6690         enddo
6691       endif
6692       ecorr=0.0D0
6693       ecorr5=0.0d0
6694       ecorr6=0.0d0
6695 C Remove the loop below after debugging !!!
6696       do i=nnt,nct
6697         do j=1,3
6698           gradcorr(j,i)=0.0D0
6699           gradxorr(j,i)=0.0D0
6700         enddo
6701       enddo
6702 C Calculate the dipole-dipole interaction energies
6703       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6704       do i=iatel_s,iatel_e+1
6705         num_conti=num_cont_hb(i)
6706         do jj=1,num_conti
6707           j=jcont_hb(jj,i)
6708 #ifdef MOMENT
6709           call dipole(i,j,jj)
6710 #endif
6711         enddo
6712       enddo
6713       endif
6714 C Calculate the local-electrostatic correlation terms
6715 c                write (iout,*) "gradcorr5 in eello5 before loop"
6716 c                do iii=1,nres
6717 c                  write (iout,'(i5,3f10.5)')
6718 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6719 c                enddo
6720       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6721 c        write (iout,*) "corr loop i",i
6722         i1=i+1
6723         num_conti=num_cont_hb(i)
6724         num_conti1=num_cont_hb(i+1)
6725         do jj=1,num_conti
6726           j=jcont_hb(jj,i)
6727           jp=iabs(j)
6728           do kk=1,num_conti1
6729             j1=jcont_hb(kk,i1)
6730             jp1=iabs(j1)
6731 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6732 c     &         ' jj=',jj,' kk=',kk
6733 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6734             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6735      &          .or. j.lt.0 .and. j1.gt.0) .and.
6736      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6737 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6738 C The system gains extra energy.
6739               n_corr=n_corr+1
6740               sqd1=dsqrt(d_cont(jj,i))
6741               sqd2=dsqrt(d_cont(kk,i1))
6742               sred_geom = sqd1*sqd2
6743               IF (sred_geom.lt.cutoff_corr) THEN
6744                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6745      &            ekont,fprimcont)
6746 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6747 cd     &         ' jj=',jj,' kk=',kk
6748                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6749                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6750                 do l=1,3
6751                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6752                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6753                 enddo
6754                 n_corr1=n_corr1+1
6755 cd               write (iout,*) 'sred_geom=',sred_geom,
6756 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6757 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6758 cd               write (iout,*) "g_contij",g_contij
6759 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6760 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6761                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6762                 if (wcorr4.gt.0.0d0)
6763      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6764                   if (energy_dec.and.wcorr4.gt.0.0d0)
6765      1                 write (iout,'(a6,4i5,0pf7.3)')
6766      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6767 c                write (iout,*) "gradcorr5 before eello5"
6768 c                do iii=1,nres
6769 c                  write (iout,'(i5,3f10.5)')
6770 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6771 c                enddo
6772                 if (wcorr5.gt.0.0d0)
6773      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6774 c                write (iout,*) "gradcorr5 after eello5"
6775 c                do iii=1,nres
6776 c                  write (iout,'(i5,3f10.5)')
6777 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6778 c                enddo
6779                   if (energy_dec.and.wcorr5.gt.0.0d0)
6780      1                 write (iout,'(a6,4i5,0pf7.3)')
6781      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6782 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6783 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6784                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6785      &               .or. wturn6.eq.0.0d0))then
6786 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6787                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6788                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6789      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6790 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6791 cd     &            'ecorr6=',ecorr6
6792 cd                write (iout,'(4e15.5)') sred_geom,
6793 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6794 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6795 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6796                 else if (wturn6.gt.0.0d0
6797      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6798 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6799                   eturn6=eturn6+eello_turn6(i,jj,kk)
6800                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6801      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6802 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6803                 endif
6804               ENDIF
6805 1111          continue
6806             endif
6807           enddo ! kk
6808         enddo ! jj
6809       enddo ! i
6810       do i=1,nres
6811         num_cont_hb(i)=num_cont_hb_old(i)
6812       enddo
6813 c                write (iout,*) "gradcorr5 in eello5"
6814 c                do iii=1,nres
6815 c                  write (iout,'(i5,3f10.5)')
6816 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6817 c                enddo
6818       return
6819       end
6820 c------------------------------------------------------------------------------
6821       subroutine add_hb_contact_eello(ii,jj,itask)
6822       implicit real*8 (a-h,o-z)
6823       include "DIMENSIONS"
6824       include "COMMON.IOUNITS"
6825       integer max_cont
6826       integer max_dim
6827       parameter (max_cont=maxconts)
6828       parameter (max_dim=70)
6829       include "COMMON.CONTACTS"
6830 #ifdef MOMENT
6831       include 'COMMON.CONTACTS.MOMENT'
6832 #endif
6833       double precision zapas(max_dim,maxconts,max_fg_procs),
6834      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6835       common /przechowalnia/ zapas
6836       integer i,j,ii,jj,iproc,itask(4),nn
6837 c      write (iout,*) "itask",itask
6838       do i=1,2
6839         iproc=itask(i)
6840         if (iproc.gt.0) then
6841           do j=1,num_cont_hb(ii)
6842             jjc=jcont_hb(j,ii)
6843 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6844             if (jjc.eq.jj) then
6845               ncont_sent(iproc)=ncont_sent(iproc)+1
6846               nn=ncont_sent(iproc)
6847               zapas(1,nn,iproc)=ii
6848               zapas(2,nn,iproc)=jjc
6849               zapas(3,nn,iproc)=d_cont(j,ii)
6850               ind=3
6851               do kk=1,3
6852                 ind=ind+1
6853                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6854               enddo
6855               do kk=1,2
6856                 do ll=1,2
6857                   ind=ind+1
6858                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6859                 enddo
6860               enddo
6861               do jj=1,5
6862                 do kk=1,3
6863                   do ll=1,2
6864                     do mm=1,2
6865                       ind=ind+1
6866                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6867                     enddo
6868                   enddo
6869                 enddo
6870               enddo
6871               exit
6872             endif
6873           enddo
6874         endif
6875       enddo
6876       return
6877       end
6878 c------------------------------------------------------------------------------
6879       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6880       implicit real*8 (a-h,o-z)
6881       include 'DIMENSIONS'
6882       include 'COMMON.IOUNITS'
6883       include 'COMMON.DERIV'
6884       include 'COMMON.INTERACT'
6885       include 'COMMON.CONTACTS'
6886 #ifdef MOMENT
6887       include 'COMMON.CONTACTS.MOMENT'
6888 #endif
6889       double precision gx(3),gx1(3)
6890       logical lprn
6891       lprn=.false.
6892       eij=facont_hb(jj,i)
6893       ekl=facont_hb(kk,k)
6894       ees0pij=ees0p(jj,i)
6895       ees0pkl=ees0p(kk,k)
6896       ees0mij=ees0m(jj,i)
6897       ees0mkl=ees0m(kk,k)
6898       ekont=eij*ekl
6899       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6900 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6901 C Following 4 lines for diagnostics.
6902 cd    ees0pkl=0.0D0
6903 cd    ees0pij=1.0D0
6904 cd    ees0mkl=0.0D0
6905 cd    ees0mij=1.0D0
6906 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6907 c     & 'Contacts ',i,j,
6908 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6909 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6910 c     & 'gradcorr_long'
6911 C Calculate the multi-body contribution to energy.
6912 c      ecorr=ecorr+ekont*ees
6913 C Calculate multi-body contributions to the gradient.
6914       coeffpees0pij=coeffp*ees0pij
6915       coeffmees0mij=coeffm*ees0mij
6916       coeffpees0pkl=coeffp*ees0pkl
6917       coeffmees0mkl=coeffm*ees0mkl
6918       do ll=1,3
6919 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6920         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6921      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6922      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6923         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6924      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6925      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6926 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6927         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6928      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6929      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6930         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6931      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6932      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6933         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6934      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6935      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6936         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6937         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6938         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6939      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6940      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6941         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6942         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6943 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6944       enddo
6945 c      write (iout,*)
6946 cgrad      do m=i+1,j-1
6947 cgrad        do ll=1,3
6948 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6949 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6950 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6951 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6952 cgrad        enddo
6953 cgrad      enddo
6954 cgrad      do m=k+1,l-1
6955 cgrad        do ll=1,3
6956 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6957 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6958 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6959 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6960 cgrad        enddo
6961 cgrad      enddo
6962 c      write (iout,*) "ehbcorr",ekont*ees
6963       ehbcorr=ekont*ees
6964       return
6965       end
6966 #ifdef MOMENT
6967 C---------------------------------------------------------------------------
6968       subroutine dipole(i,j,jj)
6969       implicit real*8 (a-h,o-z)
6970       include 'DIMENSIONS'
6971       include 'COMMON.IOUNITS'
6972       include 'COMMON.CHAIN'
6973       include 'COMMON.FFIELD'
6974       include 'COMMON.DERIV'
6975       include 'COMMON.INTERACT'
6976       include 'COMMON.CONTACTS'
6977 #ifdef MOMENT
6978       include 'COMMON.CONTACTS.MOMENT'
6979 #endif
6980       include 'COMMON.TORSION'
6981       include 'COMMON.VAR'
6982       include 'COMMON.GEO'
6983       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6984      &  auxmat(2,2)
6985       iti1 = itortyp(itype(i+1))
6986       if (j.lt.nres-1) then
6987         itj1 = itortyp(itype(j+1))
6988       else
6989         itj1=ntortyp+1
6990       endif
6991       do iii=1,2
6992         dipi(iii,1)=Ub2(iii,i)
6993         dipderi(iii)=Ub2der(iii,i)
6994         dipi(iii,2)=b1(iii,iti1)
6995         dipj(iii,1)=Ub2(iii,j)
6996         dipderj(iii)=Ub2der(iii,j)
6997         dipj(iii,2)=b1(iii,itj1)
6998       enddo
6999       kkk=0
7000       do iii=1,2
7001         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7002         do jjj=1,2
7003           kkk=kkk+1
7004           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7005         enddo
7006       enddo
7007       do kkk=1,5
7008         do lll=1,3
7009           mmm=0
7010           do iii=1,2
7011             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7012      &        auxvec(1))
7013             do jjj=1,2
7014               mmm=mmm+1
7015               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7016             enddo
7017           enddo
7018         enddo
7019       enddo
7020       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7021       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7022       do iii=1,2
7023         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7024       enddo
7025       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7026       do iii=1,2
7027         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7028       enddo
7029       return
7030       end
7031 #endif
7032 C---------------------------------------------------------------------------
7033       subroutine calc_eello(i,j,k,l,jj,kk)
7034 C
7035 C This subroutine computes matrices and vectors needed to calculate
7036 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7037 C
7038       implicit real*8 (a-h,o-z)
7039       include 'DIMENSIONS'
7040       include 'COMMON.IOUNITS'
7041       include 'COMMON.CHAIN'
7042       include 'COMMON.DERIV'
7043       include 'COMMON.INTERACT'
7044       include 'COMMON.CONTACTS'
7045 #ifdef MOMENT
7046       include 'COMMON.CONTACTS.MOMENT'
7047 #endif
7048       include 'COMMON.TORSION'
7049       include 'COMMON.VAR'
7050       include 'COMMON.GEO'
7051       include 'COMMON.FFIELD'
7052       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7053      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7054       logical lprn
7055       common /kutas/ lprn
7056 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7057 cd     & ' jj=',jj,' kk=',kk
7058 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7059 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7060 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7061       do iii=1,2
7062         do jjj=1,2
7063           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7064           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7065         enddo
7066       enddo
7067       call transpose2(aa1(1,1),aa1t(1,1))
7068       call transpose2(aa2(1,1),aa2t(1,1))
7069       do kkk=1,5
7070         do lll=1,3
7071           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7072      &      aa1tder(1,1,lll,kkk))
7073           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7074      &      aa2tder(1,1,lll,kkk))
7075         enddo
7076       enddo
7077       if (l.eq.j+1) then
7078 C parallel orientation of the two CA-CA-CA frames.
7079         if (i.gt.1) then
7080           iti=itortyp(itype(i))
7081         else
7082           iti=ntortyp+1
7083         endif
7084         itk1=itortyp(itype(k+1))
7085         itj=itortyp(itype(j))
7086         if (l.lt.nres-1) then
7087           itl1=itortyp(itype(l+1))
7088         else
7089           itl1=ntortyp+1
7090         endif
7091 C A1 kernel(j+1) A2T
7092 cd        do iii=1,2
7093 cd          write (iout,'(3f10.5,5x,3f10.5)')
7094 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7095 cd        enddo
7096         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7097      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7098      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7099 C Following matrices are needed only for 6-th order cumulants
7100         IF (wcorr6.gt.0.0d0) THEN
7101         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7102      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7103      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7104         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7105      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7106      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7107      &   ADtEAderx(1,1,1,1,1,1))
7108         lprn=.false.
7109         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7110      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7111      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7112      &   ADtEA1derx(1,1,1,1,1,1))
7113         ENDIF
7114 C End 6-th order cumulants
7115 cd        lprn=.false.
7116 cd        if (lprn) then
7117 cd        write (2,*) 'In calc_eello6'
7118 cd        do iii=1,2
7119 cd          write (2,*) 'iii=',iii
7120 cd          do kkk=1,5
7121 cd            write (2,*) 'kkk=',kkk
7122 cd            do jjj=1,2
7123 cd              write (2,'(3(2f10.5),5x)')
7124 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7125 cd            enddo
7126 cd          enddo
7127 cd        enddo
7128 cd        endif
7129         call transpose2(EUgder(1,1,k),auxmat(1,1))
7130         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7131         call transpose2(EUg(1,1,k),auxmat(1,1))
7132         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7133         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7134         do iii=1,2
7135           do kkk=1,5
7136             do lll=1,3
7137               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7138      &          EAEAderx(1,1,lll,kkk,iii,1))
7139             enddo
7140           enddo
7141         enddo
7142 C A1T kernel(i+1) A2
7143         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7144      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7145      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7146 C Following matrices are needed only for 6-th order cumulants
7147         IF (wcorr6.gt.0.0d0) THEN
7148         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7149      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7150      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7151         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7152      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7153      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7154      &   ADtEAderx(1,1,1,1,1,2))
7155         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7156      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7157      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7158      &   ADtEA1derx(1,1,1,1,1,2))
7159         ENDIF
7160 C End 6-th order cumulants
7161         call transpose2(EUgder(1,1,l),auxmat(1,1))
7162         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7163         call transpose2(EUg(1,1,l),auxmat(1,1))
7164         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7165         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7166         do iii=1,2
7167           do kkk=1,5
7168             do lll=1,3
7169               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7170      &          EAEAderx(1,1,lll,kkk,iii,2))
7171             enddo
7172           enddo
7173         enddo
7174 C AEAb1 and AEAb2
7175 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7176 C They are needed only when the fifth- or the sixth-order cumulants are
7177 C indluded.
7178         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7179         call transpose2(AEA(1,1,1),auxmat(1,1))
7180         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7181         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7182         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7183         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7184         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7185         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7186         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7187         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7188         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7189         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7190         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7191         call transpose2(AEA(1,1,2),auxmat(1,1))
7192         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7193         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7194         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7195         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7196         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7197         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7198         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7199         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7200         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7201         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7202         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7203 C Calculate the Cartesian derivatives of the vectors.
7204         do iii=1,2
7205           do kkk=1,5
7206             do lll=1,3
7207               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7208               call matvec2(auxmat(1,1),b1(1,iti),
7209      &          AEAb1derx(1,lll,kkk,iii,1,1))
7210               call matvec2(auxmat(1,1),Ub2(1,i),
7211      &          AEAb2derx(1,lll,kkk,iii,1,1))
7212               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7213      &          AEAb1derx(1,lll,kkk,iii,2,1))
7214               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7215      &          AEAb2derx(1,lll,kkk,iii,2,1))
7216               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7217               call matvec2(auxmat(1,1),b1(1,itj),
7218      &          AEAb1derx(1,lll,kkk,iii,1,2))
7219               call matvec2(auxmat(1,1),Ub2(1,j),
7220      &          AEAb2derx(1,lll,kkk,iii,1,2))
7221               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7222      &          AEAb1derx(1,lll,kkk,iii,2,2))
7223               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7224      &          AEAb2derx(1,lll,kkk,iii,2,2))
7225             enddo
7226           enddo
7227         enddo
7228         ENDIF
7229 C End vectors
7230       else
7231 C Antiparallel orientation of the two CA-CA-CA frames.
7232         if (i.gt.1) then
7233           iti=itortyp(itype(i))
7234         else
7235           iti=ntortyp+1
7236         endif
7237         itk1=itortyp(itype(k+1))
7238         itl=itortyp(itype(l))
7239         itj=itortyp(itype(j))
7240         if (j.lt.nres-1) then
7241           itj1=itortyp(itype(j+1))
7242         else
7243           itj1=ntortyp+1
7244         endif
7245 C A2 kernel(j-1)T A1T
7246         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7247      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7248      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7249 C Following matrices are needed only for 6-th order cumulants
7250         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7251      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7252         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7253      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7254      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7255         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7256      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7257      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7258      &   ADtEAderx(1,1,1,1,1,1))
7259         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7260      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7261      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7262      &   ADtEA1derx(1,1,1,1,1,1))
7263         ENDIF
7264 C End 6-th order cumulants
7265         call transpose2(EUgder(1,1,k),auxmat(1,1))
7266         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7267         call transpose2(EUg(1,1,k),auxmat(1,1))
7268         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7269         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7270         do iii=1,2
7271           do kkk=1,5
7272             do lll=1,3
7273               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7274      &          EAEAderx(1,1,lll,kkk,iii,1))
7275             enddo
7276           enddo
7277         enddo
7278 C A2T kernel(i+1)T A1
7279         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7280      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7281      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7282 C Following matrices are needed only for 6-th order cumulants
7283         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7284      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7285         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7286      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7287      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7288         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7289      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7290      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7291      &   ADtEAderx(1,1,1,1,1,2))
7292         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7293      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7294      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7295      &   ADtEA1derx(1,1,1,1,1,2))
7296         ENDIF
7297 C End 6-th order cumulants
7298         call transpose2(EUgder(1,1,j),auxmat(1,1))
7299         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7300         call transpose2(EUg(1,1,j),auxmat(1,1))
7301         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7302         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7303         do iii=1,2
7304           do kkk=1,5
7305             do lll=1,3
7306               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7307      &          EAEAderx(1,1,lll,kkk,iii,2))
7308             enddo
7309           enddo
7310         enddo
7311 C AEAb1 and AEAb2
7312 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7313 C They are needed only when the fifth- or the sixth-order cumulants are
7314 C indluded.
7315         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7316      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7317         call transpose2(AEA(1,1,1),auxmat(1,1))
7318         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7319         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7320         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7321         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7322         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7323         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7324         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7325         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7326         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7327         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7328         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7329         call transpose2(AEA(1,1,2),auxmat(1,1))
7330         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7331         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7332         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7333         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7334         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7335         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7336         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7337         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7338         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7339         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7340         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7341 C Calculate the Cartesian derivatives of the vectors.
7342         do iii=1,2
7343           do kkk=1,5
7344             do lll=1,3
7345               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7346               call matvec2(auxmat(1,1),b1(1,iti),
7347      &          AEAb1derx(1,lll,kkk,iii,1,1))
7348               call matvec2(auxmat(1,1),Ub2(1,i),
7349      &          AEAb2derx(1,lll,kkk,iii,1,1))
7350               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7351      &          AEAb1derx(1,lll,kkk,iii,2,1))
7352               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7353      &          AEAb2derx(1,lll,kkk,iii,2,1))
7354               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7355               call matvec2(auxmat(1,1),b1(1,itl),
7356      &          AEAb1derx(1,lll,kkk,iii,1,2))
7357               call matvec2(auxmat(1,1),Ub2(1,l),
7358      &          AEAb2derx(1,lll,kkk,iii,1,2))
7359               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7360      &          AEAb1derx(1,lll,kkk,iii,2,2))
7361               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7362      &          AEAb2derx(1,lll,kkk,iii,2,2))
7363             enddo
7364           enddo
7365         enddo
7366         ENDIF
7367 C End vectors
7368       endif
7369       return
7370       end
7371 C---------------------------------------------------------------------------
7372       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7373      &  KK,KKderg,AKA,AKAderg,AKAderx)
7374       implicit none
7375       integer nderg
7376       logical transp
7377       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7378      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7379      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7380       integer iii,kkk,lll
7381       integer jjj,mmm
7382       logical lprn
7383       common /kutas/ lprn
7384       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7385       do iii=1,nderg
7386         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7387      &    AKAderg(1,1,iii))
7388       enddo
7389 cd      if (lprn) write (2,*) 'In kernel'
7390       do kkk=1,5
7391 cd        if (lprn) write (2,*) 'kkk=',kkk
7392         do lll=1,3
7393           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7394      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7395 cd          if (lprn) then
7396 cd            write (2,*) 'lll=',lll
7397 cd            write (2,*) 'iii=1'
7398 cd            do jjj=1,2
7399 cd              write (2,'(3(2f10.5),5x)')
7400 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7401 cd            enddo
7402 cd          endif
7403           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7404      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7405 cd          if (lprn) then
7406 cd            write (2,*) 'lll=',lll
7407 cd            write (2,*) 'iii=2'
7408 cd            do jjj=1,2
7409 cd              write (2,'(3(2f10.5),5x)')
7410 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7411 cd            enddo
7412 cd          endif
7413         enddo
7414       enddo
7415       return
7416       end
7417 C---------------------------------------------------------------------------
7418       double precision function eello4(i,j,k,l,jj,kk)
7419       implicit real*8 (a-h,o-z)
7420       include 'DIMENSIONS'
7421       include 'COMMON.IOUNITS'
7422       include 'COMMON.CHAIN'
7423       include 'COMMON.DERIV'
7424       include 'COMMON.INTERACT'
7425       include 'COMMON.CONTACTS'
7426 #ifdef MOMENT
7427       include 'COMMON.CONTACTS.MOMENT'
7428 #endif
7429       include 'COMMON.TORSION'
7430       include 'COMMON.VAR'
7431       include 'COMMON.GEO'
7432       double precision pizda(2,2),ggg1(3),ggg2(3)
7433 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7434 cd        eello4=0.0d0
7435 cd        return
7436 cd      endif
7437 cd      print *,'eello4:',i,j,k,l,jj,kk
7438 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7439 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7440 cold      eij=facont_hb(jj,i)
7441 cold      ekl=facont_hb(kk,k)
7442 cold      ekont=eij*ekl
7443       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7444 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7445       gcorr_loc(k-1)=gcorr_loc(k-1)
7446      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7447       if (l.eq.j+1) then
7448         gcorr_loc(l-1)=gcorr_loc(l-1)
7449      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7450       else
7451         gcorr_loc(j-1)=gcorr_loc(j-1)
7452      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7453       endif
7454       do iii=1,2
7455         do kkk=1,5
7456           do lll=1,3
7457             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7458      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7459 cd            derx(lll,kkk,iii)=0.0d0
7460           enddo
7461         enddo
7462       enddo
7463 cd      gcorr_loc(l-1)=0.0d0
7464 cd      gcorr_loc(j-1)=0.0d0
7465 cd      gcorr_loc(k-1)=0.0d0
7466 cd      eel4=1.0d0
7467 cd      write (iout,*)'Contacts have occurred for peptide groups',
7468 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7469 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7470       if (j.lt.nres-1) then
7471         j1=j+1
7472         j2=j-1
7473       else
7474         j1=j-1
7475         j2=j-2
7476       endif
7477       if (l.lt.nres-1) then
7478         l1=l+1
7479         l2=l-1
7480       else
7481         l1=l-1
7482         l2=l-2
7483       endif
7484       do ll=1,3
7485 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7486 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7487         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7488         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7489 cgrad        ghalf=0.5d0*ggg1(ll)
7490         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7491         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7492         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7493         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7494         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7495         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7496 cgrad        ghalf=0.5d0*ggg2(ll)
7497         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7498         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7499         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7500         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7501         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7502         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7503       enddo
7504 cgrad      do m=i+1,j-1
7505 cgrad        do ll=1,3
7506 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7507 cgrad        enddo
7508 cgrad      enddo
7509 cgrad      do m=k+1,l-1
7510 cgrad        do ll=1,3
7511 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7512 cgrad        enddo
7513 cgrad      enddo
7514 cgrad      do m=i+2,j2
7515 cgrad        do ll=1,3
7516 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7517 cgrad        enddo
7518 cgrad      enddo
7519 cgrad      do m=k+2,l2
7520 cgrad        do ll=1,3
7521 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7522 cgrad        enddo
7523 cgrad      enddo
7524 cd      do iii=1,nres-3
7525 cd        write (2,*) iii,gcorr_loc(iii)
7526 cd      enddo
7527       eello4=ekont*eel4
7528 cd      write (2,*) 'ekont',ekont
7529 cd      write (iout,*) 'eello4',ekont*eel4
7530       return
7531       end
7532 C---------------------------------------------------------------------------
7533       double precision function eello5(i,j,k,l,jj,kk)
7534       implicit real*8 (a-h,o-z)
7535       include 'DIMENSIONS'
7536       include 'COMMON.IOUNITS'
7537       include 'COMMON.CHAIN'
7538       include 'COMMON.DERIV'
7539       include 'COMMON.INTERACT'
7540       include 'COMMON.CONTACTS'
7541 #ifdef MOMENT
7542       include 'COMMON.CONTACTS.MOMENT'
7543 #endif
7544       include 'COMMON.TORSION'
7545       include 'COMMON.VAR'
7546       include 'COMMON.GEO'
7547       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7548       double precision ggg1(3),ggg2(3)
7549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7550 C                                                                              C
7551 C                            Parallel chains                                   C
7552 C                                                                              C
7553 C          o             o                   o             o                   C
7554 C         /l\           / \             \   / \           / \   /              C
7555 C        /   \         /   \             \ /   \         /   \ /               C
7556 C       j| o |l1       | o |              o| o |         | o |o                C
7557 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7558 C      \i/   \         /   \ /             /   \         /   \                 C
7559 C       o    k1             o                                                  C
7560 C         (I)          (II)                (III)          (IV)                 C
7561 C                                                                              C
7562 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7563 C                                                                              C
7564 C                            Antiparallel chains                               C
7565 C                                                                              C
7566 C          o             o                   o             o                   C
7567 C         /j\           / \             \   / \           / \   /              C
7568 C        /   \         /   \             \ /   \         /   \ /               C
7569 C      j1| o |l        | o |              o| o |         | o |o                C
7570 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7571 C      \i/   \         /   \ /             /   \         /   \                 C
7572 C       o     k1            o                                                  C
7573 C         (I)          (II)                (III)          (IV)                 C
7574 C                                                                              C
7575 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7576 C                                                                              C
7577 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7578 C                                                                              C
7579 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7580 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7581 cd        eello5=0.0d0
7582 cd        return
7583 cd      endif
7584 cd      write (iout,*)
7585 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7586 cd     &   ' and',k,l
7587       itk=itortyp(itype(k))
7588       itl=itortyp(itype(l))
7589       itj=itortyp(itype(j))
7590       eello5_1=0.0d0
7591       eello5_2=0.0d0
7592       eello5_3=0.0d0
7593       eello5_4=0.0d0
7594 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7595 cd     &   eel5_3_num,eel5_4_num)
7596       do iii=1,2
7597         do kkk=1,5
7598           do lll=1,3
7599             derx(lll,kkk,iii)=0.0d0
7600           enddo
7601         enddo
7602       enddo
7603 cd      eij=facont_hb(jj,i)
7604 cd      ekl=facont_hb(kk,k)
7605 cd      ekont=eij*ekl
7606 cd      write (iout,*)'Contacts have occurred for peptide groups',
7607 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7608 cd      goto 1111
7609 C Contribution from the graph I.
7610 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7611 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7612       call transpose2(EUg(1,1,k),auxmat(1,1))
7613       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7614       vv(1)=pizda(1,1)-pizda(2,2)
7615       vv(2)=pizda(1,2)+pizda(2,1)
7616       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7617      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7618 C Explicit gradient in virtual-dihedral angles.
7619       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7620      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7621      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7622       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7623       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7624       vv(1)=pizda(1,1)-pizda(2,2)
7625       vv(2)=pizda(1,2)+pizda(2,1)
7626       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7627      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7628      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7629       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7630       vv(1)=pizda(1,1)-pizda(2,2)
7631       vv(2)=pizda(1,2)+pizda(2,1)
7632       if (l.eq.j+1) then
7633         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7634      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7635      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7636       else
7637         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7638      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7639      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7640       endif
7641 C Cartesian gradient
7642       do iii=1,2
7643         do kkk=1,5
7644           do lll=1,3
7645             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7646      &        pizda(1,1))
7647             vv(1)=pizda(1,1)-pizda(2,2)
7648             vv(2)=pizda(1,2)+pizda(2,1)
7649             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7650      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7651      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7652           enddo
7653         enddo
7654       enddo
7655 c      goto 1112
7656 c1111  continue
7657 C Contribution from graph II
7658       call transpose2(EE(1,1,itk),auxmat(1,1))
7659       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7660       vv(1)=pizda(1,1)+pizda(2,2)
7661       vv(2)=pizda(2,1)-pizda(1,2)
7662       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7663      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7664 C Explicit gradient in virtual-dihedral angles.
7665       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7666      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7667       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7668       vv(1)=pizda(1,1)+pizda(2,2)
7669       vv(2)=pizda(2,1)-pizda(1,2)
7670       if (l.eq.j+1) then
7671         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7672      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7673      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7674       else
7675         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7676      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7677      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7678       endif
7679 C Cartesian gradient
7680       do iii=1,2
7681         do kkk=1,5
7682           do lll=1,3
7683             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7684      &        pizda(1,1))
7685             vv(1)=pizda(1,1)+pizda(2,2)
7686             vv(2)=pizda(2,1)-pizda(1,2)
7687             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7688      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7689      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7690           enddo
7691         enddo
7692       enddo
7693 cd      goto 1112
7694 cd1111  continue
7695       if (l.eq.j+1) then
7696 cd        goto 1110
7697 C Parallel orientation
7698 C Contribution from graph III
7699         call transpose2(EUg(1,1,l),auxmat(1,1))
7700         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7701         vv(1)=pizda(1,1)-pizda(2,2)
7702         vv(2)=pizda(1,2)+pizda(2,1)
7703         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7704      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7705 C Explicit gradient in virtual-dihedral angles.
7706         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7707      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7708      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7709         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7710         vv(1)=pizda(1,1)-pizda(2,2)
7711         vv(2)=pizda(1,2)+pizda(2,1)
7712         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7713      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7714      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7715         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7716         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7717         vv(1)=pizda(1,1)-pizda(2,2)
7718         vv(2)=pizda(1,2)+pizda(2,1)
7719         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7720      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7721      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7722 C Cartesian gradient
7723         do iii=1,2
7724           do kkk=1,5
7725             do lll=1,3
7726               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7727      &          pizda(1,1))
7728               vv(1)=pizda(1,1)-pizda(2,2)
7729               vv(2)=pizda(1,2)+pizda(2,1)
7730               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7731      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7732      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7733             enddo
7734           enddo
7735         enddo
7736 cd        goto 1112
7737 C Contribution from graph IV
7738 cd1110    continue
7739         call transpose2(EE(1,1,itl),auxmat(1,1))
7740         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7741         vv(1)=pizda(1,1)+pizda(2,2)
7742         vv(2)=pizda(2,1)-pizda(1,2)
7743         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7744      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7745 C Explicit gradient in virtual-dihedral angles.
7746         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7747      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7748         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7749         vv(1)=pizda(1,1)+pizda(2,2)
7750         vv(2)=pizda(2,1)-pizda(1,2)
7751         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7752      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7753      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7754 C Cartesian gradient
7755         do iii=1,2
7756           do kkk=1,5
7757             do lll=1,3
7758               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7759      &          pizda(1,1))
7760               vv(1)=pizda(1,1)+pizda(2,2)
7761               vv(2)=pizda(2,1)-pizda(1,2)
7762               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7763      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7764      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7765             enddo
7766           enddo
7767         enddo
7768       else
7769 C Antiparallel orientation
7770 C Contribution from graph III
7771 c        goto 1110
7772         call transpose2(EUg(1,1,j),auxmat(1,1))
7773         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7774         vv(1)=pizda(1,1)-pizda(2,2)
7775         vv(2)=pizda(1,2)+pizda(2,1)
7776         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7777      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7778 C Explicit gradient in virtual-dihedral angles.
7779         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7780      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7781      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7782         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7783         vv(1)=pizda(1,1)-pizda(2,2)
7784         vv(2)=pizda(1,2)+pizda(2,1)
7785         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7786      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7787      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7788         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7789         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7790         vv(1)=pizda(1,1)-pizda(2,2)
7791         vv(2)=pizda(1,2)+pizda(2,1)
7792         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7793      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7794      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7795 C Cartesian gradient
7796         do iii=1,2
7797           do kkk=1,5
7798             do lll=1,3
7799               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7800      &          pizda(1,1))
7801               vv(1)=pizda(1,1)-pizda(2,2)
7802               vv(2)=pizda(1,2)+pizda(2,1)
7803               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7804      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7805      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7806             enddo
7807           enddo
7808         enddo
7809 cd        goto 1112
7810 C Contribution from graph IV
7811 1110    continue
7812         call transpose2(EE(1,1,itj),auxmat(1,1))
7813         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7814         vv(1)=pizda(1,1)+pizda(2,2)
7815         vv(2)=pizda(2,1)-pizda(1,2)
7816         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7817      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7818 C Explicit gradient in virtual-dihedral angles.
7819         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7820      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7821         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7822         vv(1)=pizda(1,1)+pizda(2,2)
7823         vv(2)=pizda(2,1)-pizda(1,2)
7824         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7825      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7826      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7827 C Cartesian gradient
7828         do iii=1,2
7829           do kkk=1,5
7830             do lll=1,3
7831               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7832      &          pizda(1,1))
7833               vv(1)=pizda(1,1)+pizda(2,2)
7834               vv(2)=pizda(2,1)-pizda(1,2)
7835               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7836      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7837      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7838             enddo
7839           enddo
7840         enddo
7841       endif
7842 1112  continue
7843       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7844 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7845 cd        write (2,*) 'ijkl',i,j,k,l
7846 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7847 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7848 cd      endif
7849 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7850 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7851 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7852 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7853       if (j.lt.nres-1) then
7854         j1=j+1
7855         j2=j-1
7856       else
7857         j1=j-1
7858         j2=j-2
7859       endif
7860       if (l.lt.nres-1) then
7861         l1=l+1
7862         l2=l-1
7863       else
7864         l1=l-1
7865         l2=l-2
7866       endif
7867 cd      eij=1.0d0
7868 cd      ekl=1.0d0
7869 cd      ekont=1.0d0
7870 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7871 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7872 C        summed up outside the subrouine as for the other subroutines
7873 C        handling long-range interactions. The old code is commented out
7874 C        with "cgrad" to keep track of changes.
7875       do ll=1,3
7876 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7877 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7878         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7879         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7880 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7881 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7882 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7883 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7884 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7885 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7886 c     &   gradcorr5ij,
7887 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7888 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7889 cgrad        ghalf=0.5d0*ggg1(ll)
7890 cd        ghalf=0.0d0
7891         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7892         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7893         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7894         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7895         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7896         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7897 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7898 cgrad        ghalf=0.5d0*ggg2(ll)
7899 cd        ghalf=0.0d0
7900         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7901         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7902         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7903         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7904         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7905         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7906       enddo
7907 cd      goto 1112
7908 cgrad      do m=i+1,j-1
7909 cgrad        do ll=1,3
7910 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7911 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7912 cgrad        enddo
7913 cgrad      enddo
7914 cgrad      do m=k+1,l-1
7915 cgrad        do ll=1,3
7916 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7917 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7918 cgrad        enddo
7919 cgrad      enddo
7920 c1112  continue
7921 cgrad      do m=i+2,j2
7922 cgrad        do ll=1,3
7923 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7924 cgrad        enddo
7925 cgrad      enddo
7926 cgrad      do m=k+2,l2
7927 cgrad        do ll=1,3
7928 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7929 cgrad        enddo
7930 cgrad      enddo
7931 cd      do iii=1,nres-3
7932 cd        write (2,*) iii,g_corr5_loc(iii)
7933 cd      enddo
7934       eello5=ekont*eel5
7935 cd      write (2,*) 'ekont',ekont
7936 cd      write (iout,*) 'eello5',ekont*eel5
7937       return
7938       end
7939 c--------------------------------------------------------------------------
7940       double precision function eello6(i,j,k,l,jj,kk)
7941       implicit real*8 (a-h,o-z)
7942       include 'DIMENSIONS'
7943       include 'COMMON.IOUNITS'
7944       include 'COMMON.CHAIN'
7945       include 'COMMON.DERIV'
7946       include 'COMMON.INTERACT'
7947       include 'COMMON.CONTACTS'
7948 #ifdef MOMENT
7949       include 'COMMON.CONTACTS.MOMENT'
7950 #endif
7951       include 'COMMON.TORSION'
7952       include 'COMMON.VAR'
7953       include 'COMMON.GEO'
7954       include 'COMMON.FFIELD'
7955       double precision ggg1(3),ggg2(3)
7956 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7957 cd        eello6=0.0d0
7958 cd        return
7959 cd      endif
7960 cd      write (iout,*)
7961 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7962 cd     &   ' and',k,l
7963       eello6_1=0.0d0
7964       eello6_2=0.0d0
7965       eello6_3=0.0d0
7966       eello6_4=0.0d0
7967       eello6_5=0.0d0
7968       eello6_6=0.0d0
7969 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7970 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7971       do iii=1,2
7972         do kkk=1,5
7973           do lll=1,3
7974             derx(lll,kkk,iii)=0.0d0
7975           enddo
7976         enddo
7977       enddo
7978 cd      eij=facont_hb(jj,i)
7979 cd      ekl=facont_hb(kk,k)
7980 cd      ekont=eij*ekl
7981 cd      eij=1.0d0
7982 cd      ekl=1.0d0
7983 cd      ekont=1.0d0
7984       if (l.eq.j+1) then
7985         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7986         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7987         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7988         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7989         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7990         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7991       else
7992         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7993         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7994         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7995         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7996         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7997           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7998         else
7999           eello6_5=0.0d0
8000         endif
8001         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8002       endif
8003 C If turn contributions are considered, they will be handled separately.
8004       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8005 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8006 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8007 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8008 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8009 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8010 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8011 cd      goto 1112
8012       if (j.lt.nres-1) then
8013         j1=j+1
8014         j2=j-1
8015       else
8016         j1=j-1
8017         j2=j-2
8018       endif
8019       if (l.lt.nres-1) then
8020         l1=l+1
8021         l2=l-1
8022       else
8023         l1=l-1
8024         l2=l-2
8025       endif
8026       do ll=1,3
8027 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8028 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8029 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8030 cgrad        ghalf=0.5d0*ggg1(ll)
8031 cd        ghalf=0.0d0
8032         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8033         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8034         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8035         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8036         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8037         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8038         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8039         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8040 cgrad        ghalf=0.5d0*ggg2(ll)
8041 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8042 cd        ghalf=0.0d0
8043         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8044         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8045         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8046         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8047         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8048         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8049       enddo
8050 cd      goto 1112
8051 cgrad      do m=i+1,j-1
8052 cgrad        do ll=1,3
8053 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8054 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8055 cgrad        enddo
8056 cgrad      enddo
8057 cgrad      do m=k+1,l-1
8058 cgrad        do ll=1,3
8059 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8060 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8061 cgrad        enddo
8062 cgrad      enddo
8063 cgrad1112  continue
8064 cgrad      do m=i+2,j2
8065 cgrad        do ll=1,3
8066 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8067 cgrad        enddo
8068 cgrad      enddo
8069 cgrad      do m=k+2,l2
8070 cgrad        do ll=1,3
8071 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8072 cgrad        enddo
8073 cgrad      enddo
8074 cd      do iii=1,nres-3
8075 cd        write (2,*) iii,g_corr6_loc(iii)
8076 cd      enddo
8077       eello6=ekont*eel6
8078 cd      write (2,*) 'ekont',ekont
8079 cd      write (iout,*) 'eello6',ekont*eel6
8080       return
8081       end
8082 c--------------------------------------------------------------------------
8083       double precision function eello6_graph1(i,j,k,l,imat,swap)
8084       implicit real*8 (a-h,o-z)
8085       include 'DIMENSIONS'
8086       include 'COMMON.IOUNITS'
8087       include 'COMMON.CHAIN'
8088       include 'COMMON.DERIV'
8089       include 'COMMON.INTERACT'
8090       include 'COMMON.CONTACTS'
8091 #ifdef MOMENT
8092       include 'COMMON.CONTACTS.MOMENT'
8093 #endif
8094       include 'COMMON.TORSION'
8095       include 'COMMON.VAR'
8096       include 'COMMON.GEO'
8097       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8098       logical swap
8099       logical lprn
8100       common /kutas/ lprn
8101 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8102 C                                                                              C
8103 C      Parallel       Antiparallel                                             C
8104 C                                                                              C
8105 C          o             o                                                     C
8106 C         /l\           /j\                                                    C
8107 C        /   \         /   \                                                   C
8108 C       /| o |         | o |\                                                  C
8109 C     \ j|/k\|  /   \  |/k\|l /                                                C
8110 C      \ /   \ /     \ /   \ /                                                 C
8111 C       o     o       o     o                                                  C
8112 C       i             i                                                        C
8113 C                                                                              C
8114 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8115       itk=itortyp(itype(k))
8116       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8117       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8118       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8119       call transpose2(EUgC(1,1,k),auxmat(1,1))
8120       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8121       vv1(1)=pizda1(1,1)-pizda1(2,2)
8122       vv1(2)=pizda1(1,2)+pizda1(2,1)
8123       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8124       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8125       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8126       s5=scalar2(vv(1),Dtobr2(1,i))
8127 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8128       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8129       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8130      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8131      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8132      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8133      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8134      & +scalar2(vv(1),Dtobr2der(1,i)))
8135       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8136       vv1(1)=pizda1(1,1)-pizda1(2,2)
8137       vv1(2)=pizda1(1,2)+pizda1(2,1)
8138       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8139       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8140       if (l.eq.j+1) then
8141         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8142      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8143      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8144      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8145      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8146       else
8147         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8148      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8149      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8150      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8151      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8152       endif
8153       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8154       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8155       vv1(1)=pizda1(1,1)-pizda1(2,2)
8156       vv1(2)=pizda1(1,2)+pizda1(2,1)
8157       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8158      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8159      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8160      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8161       do iii=1,2
8162         if (swap) then
8163           ind=3-iii
8164         else
8165           ind=iii
8166         endif
8167         do kkk=1,5
8168           do lll=1,3
8169             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8170             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8171             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8172             call transpose2(EUgC(1,1,k),auxmat(1,1))
8173             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8174      &        pizda1(1,1))
8175             vv1(1)=pizda1(1,1)-pizda1(2,2)
8176             vv1(2)=pizda1(1,2)+pizda1(2,1)
8177             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8178             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8179      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8180             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8181      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8182             s5=scalar2(vv(1),Dtobr2(1,i))
8183             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8184           enddo
8185         enddo
8186       enddo
8187       return
8188       end
8189 c----------------------------------------------------------------------------
8190       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8191       implicit real*8 (a-h,o-z)
8192       include 'DIMENSIONS'
8193       include 'COMMON.IOUNITS'
8194       include 'COMMON.CHAIN'
8195       include 'COMMON.DERIV'
8196       include 'COMMON.INTERACT'
8197       include 'COMMON.CONTACTS'
8198 #ifdef MOMENT
8199       include 'COMMON.CONTACTS.MOMENT'
8200 #endif
8201       include 'COMMON.TORSION'
8202       include 'COMMON.VAR'
8203       include 'COMMON.GEO'
8204       logical swap
8205       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8206      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8207       logical lprn
8208       common /kutas/ lprn
8209 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8210 C                                                                              C
8211 C      Parallel       Antiparallel                                             C
8212 C                                                                              C
8213 C          o             o                                                     C
8214 C     \   /l\           /j\   /                                                C
8215 C      \ /   \         /   \ /                                                 C
8216 C       o| o |         | o |o                                                  C
8217 C     \ j|/k\|      \  |/k\|l                                                  C
8218 C      \ /   \       \ /   \                                                   C
8219 C       o             o                                                        C
8220 C       i             i                                                        C
8221 C                                                                              C
8222 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8223 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8224 C AL 7/4/01 s1 would occur in the sixth-order moment,
8225 C           but not in a cluster cumulant
8226 #ifdef MOMENT
8227       s1=dip(1,jj,i)*dip(1,kk,k)
8228 #endif
8229       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8230       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8231       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8232       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8233       call transpose2(EUg(1,1,k),auxmat(1,1))
8234       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8235       vv(1)=pizda(1,1)-pizda(2,2)
8236       vv(2)=pizda(1,2)+pizda(2,1)
8237       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8238 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8239 #ifdef MOMENT
8240       eello6_graph2=-(s1+s2+s3+s4)
8241 #else
8242       eello6_graph2=-(s2+s3+s4)
8243 #endif
8244 c      eello6_graph2=-s3
8245 C Derivatives in gamma(i-1)
8246       if (i.gt.1) then
8247 #ifdef MOMENT
8248         s1=dipderg(1,jj,i)*dip(1,kk,k)
8249 #endif
8250         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8251         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8252         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8253         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8254 #ifdef MOMENT
8255         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8256 #else
8257         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8258 #endif
8259 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8260       endif
8261 C Derivatives in gamma(k-1)
8262 #ifdef MOMENT
8263       s1=dip(1,jj,i)*dipderg(1,kk,k)
8264 #endif
8265       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8266       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8267       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8268       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8269       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8270       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8271       vv(1)=pizda(1,1)-pizda(2,2)
8272       vv(2)=pizda(1,2)+pizda(2,1)
8273       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8274 #ifdef MOMENT
8275       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8276 #else
8277       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8278 #endif
8279 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8280 C Derivatives in gamma(j-1) or gamma(l-1)
8281       if (j.gt.1) then
8282 #ifdef MOMENT
8283         s1=dipderg(3,jj,i)*dip(1,kk,k)
8284 #endif
8285         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8286         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8287         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8288         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8289         vv(1)=pizda(1,1)-pizda(2,2)
8290         vv(2)=pizda(1,2)+pizda(2,1)
8291         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8292 #ifdef MOMENT
8293         if (swap) then
8294           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8295         else
8296           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8297         endif
8298 #endif
8299         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8300 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8301       endif
8302 C Derivatives in gamma(l-1) or gamma(j-1)
8303       if (l.gt.1) then
8304 #ifdef MOMENT
8305         s1=dip(1,jj,i)*dipderg(3,kk,k)
8306 #endif
8307         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8308         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8309         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8310         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8311         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8312         vv(1)=pizda(1,1)-pizda(2,2)
8313         vv(2)=pizda(1,2)+pizda(2,1)
8314         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8315 #ifdef MOMENT
8316         if (swap) then
8317           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8318         else
8319           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8320         endif
8321 #endif
8322         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8323 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8324       endif
8325 C Cartesian derivatives.
8326       if (lprn) then
8327         write (2,*) 'In eello6_graph2'
8328         do iii=1,2
8329           write (2,*) 'iii=',iii
8330           do kkk=1,5
8331             write (2,*) 'kkk=',kkk
8332             do jjj=1,2
8333               write (2,'(3(2f10.5),5x)')
8334      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8335             enddo
8336           enddo
8337         enddo
8338       endif
8339       do iii=1,2
8340         do kkk=1,5
8341           do lll=1,3
8342 #ifdef MOMENT
8343             if (iii.eq.1) then
8344               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8345             else
8346               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8347             endif
8348 #endif
8349             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8350      &        auxvec(1))
8351             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8352             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8353      &        auxvec(1))
8354             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8355             call transpose2(EUg(1,1,k),auxmat(1,1))
8356             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8357      &        pizda(1,1))
8358             vv(1)=pizda(1,1)-pizda(2,2)
8359             vv(2)=pizda(1,2)+pizda(2,1)
8360             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8361 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8362 #ifdef MOMENT
8363             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8364 #else
8365             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8366 #endif
8367             if (swap) then
8368               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8369             else
8370               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8371             endif
8372           enddo
8373         enddo
8374       enddo
8375       return
8376       end
8377 c----------------------------------------------------------------------------
8378       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8379       implicit real*8 (a-h,o-z)
8380       include 'DIMENSIONS'
8381       include 'COMMON.IOUNITS'
8382       include 'COMMON.CHAIN'
8383       include 'COMMON.DERIV'
8384       include 'COMMON.INTERACT'
8385       include 'COMMON.CONTACTS'
8386 #ifdef MOMENT
8387       include 'COMMON.CONTACTS.MOMENT'
8388 #endif
8389       include 'COMMON.TORSION'
8390       include 'COMMON.VAR'
8391       include 'COMMON.GEO'
8392       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8393       logical swap
8394 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8395 C                                                                              C
8396 C      Parallel       Antiparallel                                             C
8397 C                                                                              C
8398 C          o             o                                                     C
8399 C         /l\   /   \   /j\                                                    C
8400 C        /   \ /     \ /   \                                                   C
8401 C       /| o |o       o| o |\                                                  C
8402 C       j|/k\|  /      |/k\|l /                                                C
8403 C        /   \ /       /   \ /                                                 C
8404 C       /     o       /     o                                                  C
8405 C       i             i                                                        C
8406 C                                                                              C
8407 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8408 C
8409 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8410 C           energy moment and not to the cluster cumulant.
8411       iti=itortyp(itype(i))
8412       if (j.lt.nres-1) then
8413         itj1=itortyp(itype(j+1))
8414       else
8415         itj1=ntortyp+1
8416       endif
8417       itk=itortyp(itype(k))
8418       itk1=itortyp(itype(k+1))
8419       if (l.lt.nres-1) then
8420         itl1=itortyp(itype(l+1))
8421       else
8422         itl1=ntortyp+1
8423       endif
8424 #ifdef MOMENT
8425       s1=dip(4,jj,i)*dip(4,kk,k)
8426 #endif
8427       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8428       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8429       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8430       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8431       call transpose2(EE(1,1,itk),auxmat(1,1))
8432       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8433       vv(1)=pizda(1,1)+pizda(2,2)
8434       vv(2)=pizda(2,1)-pizda(1,2)
8435       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8436 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8437 cd     & "sum",-(s2+s3+s4)
8438 #ifdef MOMENT
8439       eello6_graph3=-(s1+s2+s3+s4)
8440 #else
8441       eello6_graph3=-(s2+s3+s4)
8442 #endif
8443 c      eello6_graph3=-s4
8444 C Derivatives in gamma(k-1)
8445       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8446       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8447       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8448       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8449 C Derivatives in gamma(l-1)
8450       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8451       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8452       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8453       vv(1)=pizda(1,1)+pizda(2,2)
8454       vv(2)=pizda(2,1)-pizda(1,2)
8455       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8456       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8457 C Cartesian derivatives.
8458       do iii=1,2
8459         do kkk=1,5
8460           do lll=1,3
8461 #ifdef MOMENT
8462             if (iii.eq.1) then
8463               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8464             else
8465               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8466             endif
8467 #endif
8468             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8469      &        auxvec(1))
8470             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8471             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8472      &        auxvec(1))
8473             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8474             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8475      &        pizda(1,1))
8476             vv(1)=pizda(1,1)+pizda(2,2)
8477             vv(2)=pizda(2,1)-pizda(1,2)
8478             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8479 #ifdef MOMENT
8480             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8481 #else
8482             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8483 #endif
8484             if (swap) then
8485               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8486             else
8487               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8488             endif
8489 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8490           enddo
8491         enddo
8492       enddo
8493       return
8494       end
8495 c----------------------------------------------------------------------------
8496       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8497       implicit real*8 (a-h,o-z)
8498       include 'DIMENSIONS'
8499       include 'COMMON.IOUNITS'
8500       include 'COMMON.CHAIN'
8501       include 'COMMON.DERIV'
8502       include 'COMMON.INTERACT'
8503       include 'COMMON.CONTACTS'
8504 #ifdef MOMENT
8505       include 'COMMON.CONTACTS.MOMENT'
8506 #endif
8507       include 'COMMON.TORSION'
8508       include 'COMMON.VAR'
8509       include 'COMMON.GEO'
8510       include 'COMMON.FFIELD'
8511       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8512      & auxvec1(2),auxmat1(2,2)
8513       logical swap
8514 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8515 C                                                                              C
8516 C      Parallel       Antiparallel                                             C
8517 C                                                                              C
8518 C          o             o                                                     C
8519 C         /l\   /   \   /j\                                                    C
8520 C        /   \ /     \ /   \                                                   C
8521 C       /| o |o       o| o |\                                                  C
8522 C     \ j|/k\|      \  |/k\|l                                                  C
8523 C      \ /   \       \ /   \                                                   C
8524 C       o     \       o     \                                                  C
8525 C       i             i                                                        C
8526 C                                                                              C
8527 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8528 C
8529 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8530 C           energy moment and not to the cluster cumulant.
8531 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8532       iti=itortyp(itype(i))
8533       itj=itortyp(itype(j))
8534       if (j.lt.nres-1) then
8535         itj1=itortyp(itype(j+1))
8536       else
8537         itj1=ntortyp+1
8538       endif
8539       itk=itortyp(itype(k))
8540       if (k.lt.nres-1) then
8541         itk1=itortyp(itype(k+1))
8542       else
8543         itk1=ntortyp+1
8544       endif
8545       itl=itortyp(itype(l))
8546       if (l.lt.nres-1) then
8547         itl1=itortyp(itype(l+1))
8548       else
8549         itl1=ntortyp+1
8550       endif
8551 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8552 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8553 cd     & ' itl',itl,' itl1',itl1
8554 #ifdef MOMENT
8555       if (imat.eq.1) then
8556         s1=dip(3,jj,i)*dip(3,kk,k)
8557       else
8558         s1=dip(2,jj,j)*dip(2,kk,l)
8559       endif
8560 #endif
8561       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8562       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8563       if (j.eq.l+1) then
8564         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8565         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8566       else
8567         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8568         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8569       endif
8570       call transpose2(EUg(1,1,k),auxmat(1,1))
8571       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8572       vv(1)=pizda(1,1)-pizda(2,2)
8573       vv(2)=pizda(2,1)+pizda(1,2)
8574       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8575 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8576 #ifdef MOMENT
8577       eello6_graph4=-(s1+s2+s3+s4)
8578 #else
8579       eello6_graph4=-(s2+s3+s4)
8580 #endif
8581 C Derivatives in gamma(i-1)
8582       if (i.gt.1) then
8583 #ifdef MOMENT
8584         if (imat.eq.1) then
8585           s1=dipderg(2,jj,i)*dip(3,kk,k)
8586         else
8587           s1=dipderg(4,jj,j)*dip(2,kk,l)
8588         endif
8589 #endif
8590         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8591         if (j.eq.l+1) then
8592           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8593           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8594         else
8595           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8596           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8597         endif
8598         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8599         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8600 cd          write (2,*) 'turn6 derivatives'
8601 #ifdef MOMENT
8602           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8603 #else
8604           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8605 #endif
8606         else
8607 #ifdef MOMENT
8608           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8609 #else
8610           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8611 #endif
8612         endif
8613       endif
8614 C Derivatives in gamma(k-1)
8615 #ifdef MOMENT
8616       if (imat.eq.1) then
8617         s1=dip(3,jj,i)*dipderg(2,kk,k)
8618       else
8619         s1=dip(2,jj,j)*dipderg(4,kk,l)
8620       endif
8621 #endif
8622       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8623       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8624       if (j.eq.l+1) then
8625         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8626         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8627       else
8628         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8629         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8630       endif
8631       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8632       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8633       vv(1)=pizda(1,1)-pizda(2,2)
8634       vv(2)=pizda(2,1)+pizda(1,2)
8635       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8636       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8637 #ifdef MOMENT
8638         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8639 #else
8640         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8641 #endif
8642       else
8643 #ifdef MOMENT
8644         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8645 #else
8646         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8647 #endif
8648       endif
8649 C Derivatives in gamma(j-1) or gamma(l-1)
8650       if (l.eq.j+1 .and. l.gt.1) then
8651         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8652         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8653         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8654         vv(1)=pizda(1,1)-pizda(2,2)
8655         vv(2)=pizda(2,1)+pizda(1,2)
8656         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8657         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8658       else if (j.gt.1) then
8659         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8660         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8661         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8662         vv(1)=pizda(1,1)-pizda(2,2)
8663         vv(2)=pizda(2,1)+pizda(1,2)
8664         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8665         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8666           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8667         else
8668           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8669         endif
8670       endif
8671 C Cartesian derivatives.
8672       do iii=1,2
8673         do kkk=1,5
8674           do lll=1,3
8675 #ifdef MOMENT
8676             if (iii.eq.1) then
8677               if (imat.eq.1) then
8678                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8679               else
8680                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8681               endif
8682             else
8683               if (imat.eq.1) then
8684                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8685               else
8686                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8687               endif
8688             endif
8689 #endif
8690             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8691      &        auxvec(1))
8692             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8693             if (j.eq.l+1) then
8694               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8695      &          b1(1,itj1),auxvec(1))
8696               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8697             else
8698               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8699      &          b1(1,itl1),auxvec(1))
8700               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8701             endif
8702             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8703      &        pizda(1,1))
8704             vv(1)=pizda(1,1)-pizda(2,2)
8705             vv(2)=pizda(2,1)+pizda(1,2)
8706             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8707             if (swap) then
8708               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8709 #ifdef MOMENT
8710                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8711      &             -(s1+s2+s4)
8712 #else
8713                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8714      &             -(s2+s4)
8715 #endif
8716                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8717               else
8718 #ifdef MOMENT
8719                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8720 #else
8721                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8722 #endif
8723                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8724               endif
8725             else
8726 #ifdef MOMENT
8727               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8728 #else
8729               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8730 #endif
8731               if (l.eq.j+1) then
8732                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8733               else
8734                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8735               endif
8736             endif
8737           enddo
8738         enddo
8739       enddo
8740       return
8741       end
8742 c----------------------------------------------------------------------------
8743       double precision function eello_turn6(i,jj,kk)
8744       implicit real*8 (a-h,o-z)
8745       include 'DIMENSIONS'
8746       include 'COMMON.IOUNITS'
8747       include 'COMMON.CHAIN'
8748       include 'COMMON.DERIV'
8749       include 'COMMON.INTERACT'
8750       include 'COMMON.CONTACTS'
8751 #ifdef MOMENT
8752       include 'COMMON.CONTACTS.MOMENT'
8753 #endif
8754       include 'COMMON.TORSION'
8755       include 'COMMON.VAR'
8756       include 'COMMON.GEO'
8757       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8758      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8759      &  ggg1(3),ggg2(3)
8760       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8761      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8762 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8763 C           the respective energy moment and not to the cluster cumulant.
8764       s1=0.0d0
8765       s8=0.0d0
8766       s13=0.0d0
8767 c
8768       eello_turn6=0.0d0
8769       j=i+4
8770       k=i+1
8771       l=i+3
8772       iti=itortyp(itype(i))
8773       itk=itortyp(itype(k))
8774       itk1=itortyp(itype(k+1))
8775       itl=itortyp(itype(l))
8776       itj=itortyp(itype(j))
8777 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8778 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8779 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8780 cd        eello6=0.0d0
8781 cd        return
8782 cd      endif
8783 cd      write (iout,*)
8784 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8785 cd     &   ' and',k,l
8786 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8787       do iii=1,2
8788         do kkk=1,5
8789           do lll=1,3
8790             derx_turn(lll,kkk,iii)=0.0d0
8791           enddo
8792         enddo
8793       enddo
8794 cd      eij=1.0d0
8795 cd      ekl=1.0d0
8796 cd      ekont=1.0d0
8797       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8798 cd      eello6_5=0.0d0
8799 cd      write (2,*) 'eello6_5',eello6_5
8800 #ifdef MOMENT
8801       call transpose2(AEA(1,1,1),auxmat(1,1))
8802       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8803       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8804       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8805 #endif
8806       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8807       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8808       s2 = scalar2(b1(1,itk),vtemp1(1))
8809 #ifdef MOMENT
8810       call transpose2(AEA(1,1,2),atemp(1,1))
8811       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8812       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8813       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8814 #endif
8815       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8816       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8817       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8818 #ifdef MOMENT
8819       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8820       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8821       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8822       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8823       ss13 = scalar2(b1(1,itk),vtemp4(1))
8824       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8825 #endif
8826 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8827 c      s1=0.0d0
8828 c      s2=0.0d0
8829 c      s8=0.0d0
8830 c      s12=0.0d0
8831 c      s13=0.0d0
8832       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8833 C Derivatives in gamma(i+2)
8834       s1d =0.0d0
8835       s8d =0.0d0
8836 #ifdef MOMENT
8837       call transpose2(AEA(1,1,1),auxmatd(1,1))
8838       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8839       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8840       call transpose2(AEAderg(1,1,2),atempd(1,1))
8841       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8842       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8843 #endif
8844       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8845       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8846       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8847 c      s1d=0.0d0
8848 c      s2d=0.0d0
8849 c      s8d=0.0d0
8850 c      s12d=0.0d0
8851 c      s13d=0.0d0
8852       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8853 C Derivatives in gamma(i+3)
8854 #ifdef MOMENT
8855       call transpose2(AEA(1,1,1),auxmatd(1,1))
8856       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8857       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8858       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8859 #endif
8860       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8861       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8862       s2d = scalar2(b1(1,itk),vtemp1d(1))
8863 #ifdef MOMENT
8864       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8865       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8866 #endif
8867       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8868 #ifdef MOMENT
8869       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8870       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8871       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8872 #endif
8873 c      s1d=0.0d0
8874 c      s2d=0.0d0
8875 c      s8d=0.0d0
8876 c      s12d=0.0d0
8877 c      s13d=0.0d0
8878 #ifdef MOMENT
8879       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8880      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8881 #else
8882       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8883      &               -0.5d0*ekont*(s2d+s12d)
8884 #endif
8885 C Derivatives in gamma(i+4)
8886       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8887       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8888       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8889 #ifdef MOMENT
8890       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8891       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8892       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8893 #endif
8894 c      s1d=0.0d0
8895 c      s2d=0.0d0
8896 c      s8d=0.0d0
8897 C      s12d=0.0d0
8898 c      s13d=0.0d0
8899 #ifdef MOMENT
8900       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8901 #else
8902       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8903 #endif
8904 C Derivatives in gamma(i+5)
8905 #ifdef MOMENT
8906       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8907       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8908       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8909 #endif
8910       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8911       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8912       s2d = scalar2(b1(1,itk),vtemp1d(1))
8913 #ifdef MOMENT
8914       call transpose2(AEA(1,1,2),atempd(1,1))
8915       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8916       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8917 #endif
8918       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8919       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8920 #ifdef MOMENT
8921       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8922       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8923       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8924 #endif
8925 c      s1d=0.0d0
8926 c      s2d=0.0d0
8927 c      s8d=0.0d0
8928 c      s12d=0.0d0
8929 c      s13d=0.0d0
8930 #ifdef MOMENT
8931       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8932      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8933 #else
8934       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8935      &               -0.5d0*ekont*(s2d+s12d)
8936 #endif
8937 C Cartesian derivatives
8938       do iii=1,2
8939         do kkk=1,5
8940           do lll=1,3
8941 #ifdef MOMENT
8942             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8943             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8944             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8945 #endif
8946             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8947             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8948      &          vtemp1d(1))
8949             s2d = scalar2(b1(1,itk),vtemp1d(1))
8950 #ifdef MOMENT
8951             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8952             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8953             s8d = -(atempd(1,1)+atempd(2,2))*
8954      &           scalar2(cc(1,1,itl),vtemp2(1))
8955 #endif
8956             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8957      &           auxmatd(1,1))
8958             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8959             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8960 c      s1d=0.0d0
8961 c      s2d=0.0d0
8962 c      s8d=0.0d0
8963 c      s12d=0.0d0
8964 c      s13d=0.0d0
8965 #ifdef MOMENT
8966             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8967      &        - 0.5d0*(s1d+s2d)
8968 #else
8969             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8970      &        - 0.5d0*s2d
8971 #endif
8972 #ifdef MOMENT
8973             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8974      &        - 0.5d0*(s8d+s12d)
8975 #else
8976             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8977      &        - 0.5d0*s12d
8978 #endif
8979           enddo
8980         enddo
8981       enddo
8982 #ifdef MOMENT
8983       do kkk=1,5
8984         do lll=1,3
8985           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8986      &      achuj_tempd(1,1))
8987           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8988           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8989           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8990           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8991           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8992      &      vtemp4d(1))
8993           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8994           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8995           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8996         enddo
8997       enddo
8998 #endif
8999 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9000 cd     &  16*eel_turn6_num
9001 cd      goto 1112
9002       if (j.lt.nres-1) then
9003         j1=j+1
9004         j2=j-1
9005       else
9006         j1=j-1
9007         j2=j-2
9008       endif
9009       if (l.lt.nres-1) then
9010         l1=l+1
9011         l2=l-1
9012       else
9013         l1=l-1
9014         l2=l-2
9015       endif
9016       do ll=1,3
9017 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9018 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9019 cgrad        ghalf=0.5d0*ggg1(ll)
9020 cd        ghalf=0.0d0
9021         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9022         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9023         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9024      &    +ekont*derx_turn(ll,2,1)
9025         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9026         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9027      &    +ekont*derx_turn(ll,4,1)
9028         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9029         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9030         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9031 cgrad        ghalf=0.5d0*ggg2(ll)
9032 cd        ghalf=0.0d0
9033         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9034      &    +ekont*derx_turn(ll,2,2)
9035         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9036         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9037      &    +ekont*derx_turn(ll,4,2)
9038         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9039         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9040         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9041       enddo
9042 cd      goto 1112
9043 cgrad      do m=i+1,j-1
9044 cgrad        do ll=1,3
9045 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9046 cgrad        enddo
9047 cgrad      enddo
9048 cgrad      do m=k+1,l-1
9049 cgrad        do ll=1,3
9050 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9051 cgrad        enddo
9052 cgrad      enddo
9053 cgrad1112  continue
9054 cgrad      do m=i+2,j2
9055 cgrad        do ll=1,3
9056 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9057 cgrad        enddo
9058 cgrad      enddo
9059 cgrad      do m=k+2,l2
9060 cgrad        do ll=1,3
9061 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9062 cgrad        enddo
9063 cgrad      enddo
9064 cd      do iii=1,nres-3
9065 cd        write (2,*) iii,g_corr6_loc(iii)
9066 cd      enddo
9067       eello_turn6=ekont*eel_turn6
9068 cd      write (2,*) 'ekont',ekont
9069 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9070       return
9071       end
9072
9073 C-----------------------------------------------------------------------------
9074       double precision function scalar(u,v)
9075 !DIR$ INLINEALWAYS scalar
9076 #ifndef OSF
9077 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9078 #endif
9079       implicit none
9080       double precision u(3),v(3)
9081 cd      double precision sc
9082 cd      integer i
9083 cd      sc=0.0d0
9084 cd      do i=1,3
9085 cd        sc=sc+u(i)*v(i)
9086 cd      enddo
9087 cd      scalar=sc
9088
9089       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9090       return
9091       end
9092 crc-------------------------------------------------
9093       SUBROUTINE MATVEC2(A1,V1,V2)
9094 !DIR$ INLINEALWAYS MATVEC2
9095 #ifndef OSF
9096 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9097 #endif
9098       implicit real*8 (a-h,o-z)
9099       include 'DIMENSIONS'
9100       DIMENSION A1(2,2),V1(2),V2(2)
9101 c      DO 1 I=1,2
9102 c        VI=0.0
9103 c        DO 3 K=1,2
9104 c    3     VI=VI+A1(I,K)*V1(K)
9105 c        Vaux(I)=VI
9106 c    1 CONTINUE
9107
9108       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9109       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9110
9111       v2(1)=vaux1
9112       v2(2)=vaux2
9113       END
9114 C---------------------------------------
9115       SUBROUTINE MATMAT2(A1,A2,A3)
9116 #ifndef OSF
9117 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9118 #endif
9119       implicit real*8 (a-h,o-z)
9120       include 'DIMENSIONS'
9121       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9122 c      DIMENSION AI3(2,2)
9123 c        DO  J=1,2
9124 c          A3IJ=0.0
9125 c          DO K=1,2
9126 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9127 c          enddo
9128 c          A3(I,J)=A3IJ
9129 c       enddo
9130 c      enddo
9131
9132       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9133       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9134       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9135       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9136
9137       A3(1,1)=AI3_11
9138       A3(2,1)=AI3_21
9139       A3(1,2)=AI3_12
9140       A3(2,2)=AI3_22
9141       END
9142
9143 c-------------------------------------------------------------------------
9144       double precision function scalar2(u,v)
9145 !DIR$ INLINEALWAYS scalar2
9146       implicit none
9147       double precision u(2),v(2)
9148       double precision sc
9149       integer i
9150       scalar2=u(1)*v(1)+u(2)*v(2)
9151       return
9152       end
9153
9154 C-----------------------------------------------------------------------------
9155
9156       subroutine transpose2(a,at)
9157 !DIR$ INLINEALWAYS transpose2
9158 #ifndef OSF
9159 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9160 #endif
9161       implicit none
9162       double precision a(2,2),at(2,2)
9163       at(1,1)=a(1,1)
9164       at(1,2)=a(2,1)
9165       at(2,1)=a(1,2)
9166       at(2,2)=a(2,2)
9167       return
9168       end
9169 c--------------------------------------------------------------------------
9170       subroutine transpose(n,a,at)
9171       implicit none
9172       integer n,i,j
9173       double precision a(n,n),at(n,n)
9174       do i=1,n
9175         do j=1,n
9176           at(j,i)=a(i,j)
9177         enddo
9178       enddo
9179       return
9180       end
9181 C---------------------------------------------------------------------------
9182       subroutine prodmat3(a1,a2,kk,transp,prod)
9183 !DIR$ INLINEALWAYS prodmat3
9184 #ifndef OSF
9185 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9186 #endif
9187       implicit none
9188       integer i,j
9189       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9190       logical transp
9191 crc      double precision auxmat(2,2),prod_(2,2)
9192
9193       if (transp) then
9194 crc        call transpose2(kk(1,1),auxmat(1,1))
9195 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9196 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9197
9198            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9199      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9200            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9201      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9202            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9203      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9204            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9205      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9206
9207       else
9208 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9209 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9210
9211            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9212      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9213            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9214      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9215            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9216      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9217            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9218      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9219
9220       endif
9221 c      call transpose2(a2(1,1),a2t(1,1))
9222
9223 crc      print *,transp
9224 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9225 crc      print *,((prod(i,j),i=1,2),j=1,2)
9226
9227       return
9228       end
9229