source/unres/src_MD/old_F/energy_p_new.F.safe

   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       if (modecalc.eq.12.or.modecalc.eq.14) then
  28 #ifdef MPI
  29 c        if (fg_rank.eq.0) call int_from_cart1(.false.)
  30 #else
  31         call int_from_cart1(.false.)
  32 #endif
  33       endif
  34 #ifdef MPI
  35 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  36 c     & " nfgtasks",nfgtasks
  37       if (nfgtasks.gt.1) then
  38         time00=MPI_Wtime()
  39 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  40         if (fg_rank.eq.0) then
  41           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  42 c          print *,"Processor",myrank," BROADCAST iorder"
  43 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  44 C FG slaves as WEIGHTS array.
  45           weights_(1)=wsc
  46           weights_(2)=wscp
  47           weights_(3)=welec
  48           weights_(4)=wcorr
  49           weights_(5)=wcorr5
  50           weights_(6)=wcorr6
  51           weights_(7)=wel_loc
  52           weights_(8)=wturn3
  53           weights_(9)=wturn4
  54           weights_(10)=wturn6
  55           weights_(11)=wang
  56           weights_(12)=wscloc
  57           weights_(13)=wtor
  58           weights_(14)=wtor_d
  59           weights_(15)=wstrain
  60           weights_(16)=wvdwpp
  61           weights_(17)=wbond
  62           weights_(18)=scal14
  63           weights_(21)=wsccor
  64 C FG Master broadcasts the WEIGHTS_ array
  65           call MPI_Bcast(weights_(1),n_ene,
  66      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  67         else
  68 C FG slaves receive the WEIGHTS array
  69           call MPI_Bcast(weights(1),n_ene,
  70      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  71         endif
  72 c        print *,"Processor",myrank," BROADCAST weights"
  73 c        call MPI_Bcast(c(1,1),maxres6,MPI_DOUBLE_PRECISION,
  74 c     &    king,FG_COMM,IERR)
  75 c        call MPI_Bcast(c(1,1),6*nres,MPI_DOUBLE_PRECISION,
  76 c     &    king,FG_COMM,IERR)
  77 c        print *,"Processor",myrank," BROADCAST c"
  78 c        call MPI_Bcast(dc(1,1),maxres6,MPI_DOUBLE_PRECISION,
  79 c     &    king,FG_COMM,IERR)
  80         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,
  81      &    king,FG_COMM,IERR)
  82 c        print *,"Processor",myrank," BROADCAST dc"
  83 c        call MPI_Bcast(dc_norm(1,1),maxres6,MPI_DOUBLE_PRECISION,
  84 c     &    king,FG_COMM,IERR)
  85 c        call MPI_Bcast(dc_norm(1,1),6*nres,MPI_DOUBLE_PRECISION,
  86 c     &    king,FG_COMM,IERR)
  87 c        print *,"Processor",myrank," BROADCAST dc_norm"
  88 c        call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,
  89 c     &    king,FG_COMM,IERR)
  90 c        print *,"Processor",myrank," BROADCAST theta"
  91 c        call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,
  92 c     &    king,FG_COMM,IERR)
  93 c        print *,"Processor",myrank," BROADCAST phi"
  94 c        call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,
  95 c     &    king,FG_COMM,IERR)
  96 c        print *,"Processor",myrank," BROADCAST alph"
  97 c        call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,
  98 c     &    king,FG_COMM,IERR)
  99 c        print *,"Processor",myrank," BROADCAST omeg"
 100 c        call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,
 101 c     &    king,FG_COMM,IERR)
 102 c        print *,"Processor",myrank," BROADCAST vbld"
 103 c        call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,
 104 c     &    king,FG_COMM,IERR)
 105         time_Bcast=time_Bcast+MPI_Wtime()-time00
 106         call chainbuild_cart
 107         call int_from_cart1(.false.)
 108 c        print *,"Processor",myrank," BROADCAST vbld_inv"
 109       endif
 110 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 111 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 112 #endif
 113 C
 114 C Compute the side-chain and electrostatic interaction energy
 115 C
 116       goto (101,102,103,104,105,106) ipot
 117 C Lennard-Jones potential.
 118   101 call elj(evdw)
 119 cd    print '(a)','Exit ELJ'
 120       goto 107
 121 C Lennard-Jones-Kihara potential (shifted).
 122   102 call eljk(evdw)
 123       goto 107
 124 C Berne-Pechukas potential (dilated LJ, angular dependence).
 125   103 call ebp(evdw)
 126       goto 107
 127 C Gay-Berne potential (shifted LJ, angular dependence).
 128   104 call egb(evdw)
 129       goto 107
 130 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 131   105 call egbv(evdw)
 132       goto 107
 133 C Soft-sphere potential
 134   106 call e_softsphere(evdw)
 135 C
 136 C Calculate electrostatic (H-bonding) energy of the main chain.
 137 C
 138   107 continue
 139 c      print *,"Processor",myrank," computed USCSC"
 140       call vec_and_deriv
 141 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 142       if (ipot.lt.6) then
 143 #ifdef SPLITELE
 144          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 145      &       wturn3.gt.0d0.or.wturn4.gt.0d0) then
 146 #else
 147          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 148      &       wturn3.gt.0d0.or.wturn4.gt.0d0) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0
 153             evdw1=0
 154             eel_loc=0
 155             eello_turn3=0
 156             eello_turn4=0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 c         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
 241 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0
 244          ecorr5=0
 245          ecorr6=0
 246          eturn6=0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250       else
 251          ecorr=0
 252          ecorr5=0
 253          ecorr6=0
 254          eturn6=0
 255       endif
 256 c      print *,"Processor",myrank," computed Ucorr"
 257 C
 258 C If performing constraint dynamics, call the constraint energy
 259 C  after the equilibration time
 260       if(usampl.and.totT.gt.eq_time) then
 261          call EconstrQ
 262          call Econstr_back
 263       else
 264          Uconst=0.0d0
 265          Uconst_back=0.0d0
 266       endif
 267 c      print *,"Processor",myrank," computed Uconstr"
 268 c
 269 C Sum the energies
 270 C
 271       energia(1)=evdw
 272 #ifdef SCP14
 273       energia(2)=evdw2-evdw2_14
 274       energia(18)=evdw2_14
 275 #else
 276       energia(2)=evdw2
 277       energia(18)=0.0d0
 278 #endif
 279 #ifdef SPLITELE
 280       energia(3)=ees
 281       energia(16)=evdw1
 282 #else
 283       energia(3)=ees+evdw1
 284       energia(16)=0.0d0
 285 #endif
 286       energia(4)=ecorr
 287       energia(5)=ecorr5
 288       energia(6)=ecorr6
 289       energia(7)=eel_loc
 290       energia(8)=eello_turn3
 291       energia(9)=eello_turn4
 292       energia(10)=eturn6
 293       energia(11)=ebe
 294       energia(12)=escloc
 295       energia(13)=etors
 296       energia(14)=etors_d
 297       energia(15)=ehpb
 298       energia(19)=edihcnstr
 299       energia(17)=estr
 300       energia(20)=Uconst+Uconst_back
 301       energia(21)=esccor
 302 c      print *," Processor",myrank," calls SUM_ENERGY"
 303       call sum_energy(energia,.true.)
 304 c      print *," Processor",myrank," left SUM_ENERGY"
 305       return
 306       end
 307 c-------------------------------------------------------------------------------
 308       subroutine sum_energy(energia,reduce)
 309       implicit real*8 (a-h,o-z)
 310       include 'DIMENSIONS'
 311 #ifndef ISNAN
 312       external proc_proc
 313 #ifdef WINPGI
 314 cMS$ATTRIBUTES C ::  proc_proc
 315 #endif
 316 #endif
 317 #ifdef MPI
 318       include "mpif.h"
 319 #endif
 320       include 'COMMON.SETUP'
 321       include 'COMMON.IOUNITS'
 322       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 323       include 'COMMON.FFIELD'
 324       include 'COMMON.DERIV'
 325       include 'COMMON.INTERACT'
 326       include 'COMMON.SBRIDGE'
 327       include 'COMMON.CHAIN'
 328       include 'COMMON.VAR'
 329       include 'COMMON.CONTROL'
 330       include 'COMMON.TIME1'
 331       logical reduce
 332 #ifdef MPI
 333       if (nfgtasks.gt.1 .and. reduce) then
 334 #ifdef DEBUG
 335         write (iout,*) "energies before REDUCE"
 336         call enerprint(energia)
 337         call flush(iout)
 338 #endif
 339         do i=0,n_ene
 340           enebuff(i)=energia(i)
 341         enddo
 342         time00=MPI_Wtime()
 343         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 344      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 345 #ifdef DEBUG
 346         write (iout,*) "energies after REDUCE"
 347         call enerprint(energia)
 348         call flush(iout)
 349 #endif
 350         time_Reduce=time_Reduce+MPI_Wtime()-time00
 351       endif
 352       if (fg_rank.eq.0) then
 353 #endif
 354       evdw=energia(1)
 355 #ifdef SCP14
 356       evdw2=energia(2)+energia(18)
 357       evdw2_14=energia(18)
 358 #else
 359       evdw2=energia(2)
 360 #endif
 361 #ifdef SPLITELE
 362       ees=energia(3)
 363       evdw1=energia(16)
 364 #else
 365       ees=energia(3)
 366       evdw1=0.0d0
 367 #endif
 368       ecorr=energia(4)
 369       ecorr5=energia(5)
 370       ecorr6=energia(6)
 371       eel_loc=energia(7)
 372       eello_turn3=energia(8)
 373       eello_turn4=energia(9)
 374       eturn6=energia(10)
 375       ebe=energia(11)
 376       escloc=energia(12)
 377       etors=energia(13)
 378       etors_d=energia(14)
 379       ehpb=energia(15)
 380       edihcnstr=energia(19)
 381       estr=energia(17)
 382       Uconst=energia(20)
 383       esccor=energia(21)
 384 #ifdef SPLITELE
 385       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 386      & +wang*ebe+wtor*etors+wscloc*escloc
 387      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 388      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 389      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 390      & +wbond*estr+Uconst+wsccor*esccor
 391 #else
 392       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 393      & +wang*ebe+wtor*etors+wscloc*escloc
 394      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 395      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 396      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 397      & +wbond*estr+Uconst+wsccor*esccor
 398 #endif
 399       energia(0)=etot
 400 c detecting NaNQ
 401 #ifdef ISNAN
 402 #ifdef AIX
 403       if (isnan(etot).ne.0) energia(0)=1.0d+99
 404 #else
 405       if (isnan(etot)) energia(0)=1.0d+99
 406 #endif
 407 #else
 408       i=0
 409 #ifdef WINPGI
 410       idumm=proc_proc(etot,i)
 411 #else
 412       call proc_proc(etot,i)
 413 #endif
 414       if(i.eq.1)energia(0)=1.0d+99
 415 #endif
 416 #ifdef MPI
 417       endif
 418 #endif
 419       return
 420       end
 421 c-------------------------------------------------------------------------------
 422       subroutine sum_gradient
 423       implicit real*8 (a-h,o-z)
 424       include 'DIMENSIONS'
 425 #ifndef ISNAN
 426       external proc_proc
 427 #ifdef WINPGI
 428 cMS$ATTRIBUTES C ::  proc_proc
 429 #endif
 430 #endif
 431 #ifdef MPI
 432       include 'mpif.h'
 433       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 434      &  glocbuf(4*maxres)
 435 #endif
 436       include 'COMMON.SETUP'
 437       include 'COMMON.IOUNITS'
 438       include 'COMMON.FFIELD'
 439       include 'COMMON.DERIV'
 440       include 'COMMON.INTERACT'
 441       include 'COMMON.SBRIDGE'
 442       include 'COMMON.CHAIN'
 443       include 'COMMON.VAR'
 444       include 'COMMON.CONTROL'
 445       include 'COMMON.TIME1'
 446       include 'COMMON.MAXGRAD'
 447 C
 448 C Sum up the components of the Cartesian gradient.
 449 C
 450 #ifdef SPLITELE
 451       do i=1,nct
 452         do j=1,3
 453           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 454      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 455      &                wbond*gradb(j,i)+
 456      &                wstrain*ghpbc(j,i)+
 457      &                wcorr*gradcorr(j,i)+
 458      &                wel_loc*gel_loc(j,i)+
 459      &                wturn3*gcorr3_turn(j,i)+
 460      &                wturn4*gcorr4_turn(j,i)+
 461      &                wcorr5*gradcorr5(j,i)+
 462      &                wcorr6*gradcorr6(j,i)+
 463      &                wturn6*gcorr6_turn(j,i)+
 464      &                wsccor*gsccorc(j,i)
 465      &               +wscloc*gscloc(j,i)
 466           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 467      &                  wbond*gradbx(j,i)+
 468      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 469      &                  wsccor*gsccorx(j,i)
 470      &                 +wscloc*gsclocx(j,i)
 471         enddo
 472       enddo
 473 #else
 474       do i=1,nct
 475         do j=1,3
 476           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 477      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 478      &                wbond*gradb(j,i)+
 479      &                wcorr*gradcorr(j,i)+
 480      &                wel_loc*gel_loc(j,i)+
 481      &                wturn3*gcorr3_turn(j,i)+
 482      &                wturn4*gcorr4_turn(j,i)+
 483      &                wcorr5*gradcorr5(j,i)+
 484      &                wcorr6*gradcorr6(j,i)+
 485      &                wturn6*gcorr6_turn(j,i)+
 486      &                wsccor*gsccorc(j,i)
 487      &               +wscloc*gscloc(j,i)
 488           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 489      &                  wbond*gradbx(j,i)+
 490      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 491      &                  wsccor*gsccorx(j,i)
 492      &                 +wscloc*gsclocx(j,i)
 493         enddo
 494       enddo
 495 #endif
 496       do i=1,nres-3
 497         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 498      &   +wcorr5*g_corr5_loc(i)
 499      &   +wcorr6*g_corr6_loc(i)
 500      &   +wturn4*gel_loc_turn4(i)
 501      &   +wturn3*gel_loc_turn3(i)
 502      &   +wturn6*gel_loc_turn6(i)
 503      &   +wel_loc*gel_loc_loc(i)
 504      &   +wsccor*gsccor_loc(i)
 505       enddo
 506 #ifdef MPI
 507       if (nfgtasks.gt.1) then
 508         do j=1,3
 509           do i=1,nres
 510             gradbufc(j,i)=gradc(j,i,icg)
 511             gradbufx(j,i)=gradx(j,i,icg)
 512           enddo
 513         enddo
 514         do i=1,4*nres
 515           glocbuf(i)=gloc(i,icg)
 516         enddo
 517 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 518         if (fg_rank.eq.0) call MPI_Bcast(1,1,MPI_INTEGER,
 519      &      king,FG_COMM,IERROR)
 520         time00=MPI_Wtime()
 521         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 522      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 523         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 524      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 525         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 526      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 527         time_reduce=time_reduce+MPI_Wtime()-time00
 528       endif
 529 #endif
 530       if (gnorm_check) then
 531 c
 532 c Compute the maximum elements of the gradient
 533 c
 534       gvdwc_max=0.0d0
 535       gvdwc_scp_max=0.0d0
 536       gelc_max=0.0d0
 537       gvdwpp_max=0.0d0
 538       gradb_max=0.0d0
 539       ghpbc_max=0.0d0
 540       gradcorr_max=0.0d0
 541       gel_loc_max=0.0d0
 542       gcorr3_turn_max=0.0d0
 543       gcorr4_turn_max=0.0d0
 544       gradcorr5_max=0.0d0
 545       gradcorr6_max=0.0d0
 546       gcorr6_turn_max=0.0d0
 547       gsccorc_max=0.0d0
 548       gscloc_max=0.0d0
 549       gvdwx_max=0.0d0
 550       gradx_scp_max=0.0d0
 551       ghpbx_max=0.0d0
 552       gradxorr_max=0.0d0
 553       gsccorx_max=0.0d0
 554       gsclocx_max=0.0d0
 555       do i=1,nct
 556         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 557         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 558         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 559         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 560      &   gvdwc_scp_max=gvdwc_scp_norm
 561         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 562         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 563         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 564         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 565         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 566         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 567         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 568         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 569         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 570         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 571         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 572         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 573         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 574      &    gcorr3_turn(1,i)))
 575         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 576      &    gcorr3_turn_max=gcorr3_turn_norm
 577         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 578      &    gcorr4_turn(1,i)))
 579         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 580      &    gcorr4_turn_max=gcorr4_turn_norm
 581         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 582         if (gradcorr5_norm.gt.gradcorr5_max)
 583      &    gradcorr5_max=gradcorr5_norm
 584         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 585         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 586         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 587      &    gcorr6_turn(1,i)))
 588         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 589      &    gcorr6_turn_max=gcorr6_turn_norm
 590         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 591         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 592         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 593         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 594         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 595         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 596         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 597         if (gradx_scp_norm.gt.gradx_scp_max)
 598      &    gradx_scp_max=gradx_scp_norm
 599         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 600         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 601         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 602         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 603         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 604         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 605         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 606         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 607       enddo
 608       if (gradout) then
 609 #ifdef AIX
 610         open(istat,file=statname,position="append")
 611 #else
 612         open(istat,file=statname,access="append")
 613 #endif
 614         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 615      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 616      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 617      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 618      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 619      &     gsccorx_max,gsclocx_max
 620         close(istat)
 621         if (gvdwc_max.gt.1.0d4) then
 622           write (iout,*) "gvdwc gvdwx gradb gradbx"
 623           do i=nnt,nct
 624             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 625      &        gradb(j,i),gradbx(j,i),j=1,3)
 626           enddo
 627           call pdbout(0.0d0,'cipiszcze',iout)
 628           call flush(iout)
 629         endif
 630       endif
 631       endif
 632 #ifdef DEBUG
 633       write (iout,*) "gradc gradx gloc"
 634       do i=1,nres
 635         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 636      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 637       enddo
 638 #endif
 639       return
 640       end
 641 c-------------------------------------------------------------------------------
 642       subroutine rescale_weights(t_bath)
 643       implicit real*8 (a-h,o-z)
 644       include 'DIMENSIONS'
 645       include 'COMMON.IOUNITS'
 646       include 'COMMON.FFIELD'
 647       include 'COMMON.SBRIDGE'
 648       double precision kfac /2.4d0/
 649       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 650 c      facT=temp0/t_bath
 651 c      facT=2*temp0/(t_bath+temp0)
 652       if (rescale_mode.eq.0) then
 653         facT=1.0d0
 654         facT2=1.0d0
 655         facT3=1.0d0
 656         facT4=1.0d0
 657         facT5=1.0d0
 658       else if (rescale_mode.eq.1) then
 659         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 660         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 661         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 662         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 663         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 664       else if (rescale_mode.eq.2) then
 665         x=t_bath/temp0
 666         x2=x*x
 667         x3=x2*x
 668         x4=x3*x
 669         x5=x4*x
 670         facT=licznik/dlog(dexp(x)+dexp(-x))
 671         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 672         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 673         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 674         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 675       else
 676         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 677         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 678 #ifdef MPI
 679        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 680 #endif
 681        stop 555
 682       endif
 683       welec=weights(3)*fact
 684       wcorr=weights(4)*fact3
 685       wcorr5=weights(5)*fact4
 686       wcorr6=weights(6)*fact5
 687       wel_loc=weights(7)*fact2
 688       wturn3=weights(8)*fact2
 689       wturn4=weights(9)*fact3
 690       wturn6=weights(10)*fact5
 691       wtor=weights(13)*fact
 692       wtor_d=weights(14)*fact2
 693       wsccor=weights(21)*fact
 694
 695       return
 696       end
 697 C------------------------------------------------------------------------
 698       subroutine enerprint(energia)
 699       implicit real*8 (a-h,o-z)
 700       include 'DIMENSIONS'
 701       include 'COMMON.IOUNITS'
 702       include 'COMMON.FFIELD'
 703       include 'COMMON.SBRIDGE'
 704       include 'COMMON.MD'
 705       double precision energia(0:n_ene)
 706       etot=energia(0)
 707       evdw=energia(1)
 708       evdw2=energia(2)
 709 #ifdef SCP14
 710       evdw2=energia(2)+energia(18)
 711 #else
 712       evdw2=energia(2)
 713 #endif
 714       ees=energia(3)
 715 #ifdef SPLITELE
 716       evdw1=energia(16)
 717 #endif
 718       ecorr=energia(4)
 719       ecorr5=energia(5)
 720       ecorr6=energia(6)
 721       eel_loc=energia(7)
 722       eello_turn3=energia(8)
 723       eello_turn4=energia(9)
 724       eello_turn6=energia(10)
 725       ebe=energia(11)
 726       escloc=energia(12)
 727       etors=energia(13)
 728       etors_d=energia(14)
 729       ehpb=energia(15)
 730       edihcnstr=energia(19)
 731       estr=energia(17)
 732       Uconst=energia(20)
 733       esccor=energia(21)
 734 #ifdef SPLITELE
 735       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 736      &  estr,wbond,ebe,wang,
 737      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 738      &  ecorr,wcorr,
 739      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 740      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 741      &  edihcnstr,ebr*nss,
 742      &  Uconst,etot
 743    10 format (/'Virtual-chain energies:'//
 744      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 745      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 746      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 747      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 748      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 749      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 750      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 751      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 752      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 753      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 754      & ' (SS bridges & dist. cnstr.)'/
 755      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 756      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 757      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 758      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 759      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 760      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 761      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 762      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 763      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 764      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 765      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 766      & 'ETOT=  ',1pE16.6,' (total)')
 767 #else
 768       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 769      &  estr,wbond,ebe,wang,
 770      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 771      &  ecorr,wcorr,
 772      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 773      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 774      &  ebr*nss,Uconst,etot
 775    10 format (/'Virtual-chain energies:'//
 776      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 777      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 778      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 779      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 780      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 781      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 782      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 783      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 784      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 785      & ' (SS bridges & dist. cnstr.)'/
 786      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 787      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 788      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 789      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 790      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 791      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 792      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 793      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 794      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 795      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 796      & 'UCONST=',1pE16.6,' (Constraint energy)'/
 797      & 'ETOT=  ',1pE16.6,' (total)')
 798 #endif
 799       return
 800       end
 801 C-----------------------------------------------------------------------
 802       subroutine elj(evdw)
 803 C
 804 C This subroutine calculates the interaction energy of nonbonded side chains
 805 C assuming the LJ potential of interaction.
 806 C
 807       implicit real*8 (a-h,o-z)
 808       include 'DIMENSIONS'
 809       parameter (accur=1.0d-10)
 810       include 'COMMON.GEO'
 811       include 'COMMON.VAR'
 812       include 'COMMON.LOCAL'
 813       include 'COMMON.CHAIN'
 814       include 'COMMON.DERIV'
 815       include 'COMMON.INTERACT'
 816       include 'COMMON.TORSION'
 817       include 'COMMON.SBRIDGE'
 818       include 'COMMON.NAMES'
 819       include 'COMMON.IOUNITS'
 820       include 'COMMON.CONTACTS'
 821       dimension gg(3)
 822 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 823       evdw=0.0D0
 824       do i=iatsc_s,iatsc_e
 825         itypi=itype(i)
 826         itypi1=itype(i+1)
 827         xi=c(1,nres+i)
 828         yi=c(2,nres+i)
 829         zi=c(3,nres+i)
 830 C Change 12/1/95
 831         num_conti=0
 832 C
 833 C Calculate SC interaction energy.
 834 C
 835         do iint=1,nint_gr(i)
 836 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 837 cd   &                  'iend=',iend(i,iint)
 838           do j=istart(i,iint),iend(i,iint)
 839             itypj=itype(j)
 840             xj=c(1,nres+j)-xi
 841             yj=c(2,nres+j)-yi
 842             zj=c(3,nres+j)-zi
 843 C Change 12/1/95 to calculate four-body interactions
 844             rij=xj*xj+yj*yj+zj*zj
 845             rrij=1.0D0/rij
 846 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 847             eps0ij=eps(itypi,itypj)
 848             fac=rrij**expon2
 849             e1=fac*fac*aa(itypi,itypj)
 850             e2=fac*bb(itypi,itypj)
 851             evdwij=e1+e2
 852 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 853 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 854 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 855 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 856 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 857 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 858             evdw=evdw+evdwij
 859 C
 860 C Calculate the components of the gradient in DC and X
 861 C
 862             fac=-rrij*(e1+evdwij)
 863             gg(1)=xj*fac
 864             gg(2)=yj*fac
 865             gg(3)=zj*fac
 866             do k=1,3
 867               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 868               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 869             enddo
 870             do k=i,j-1
 871               do l=1,3
 872                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 873               enddo
 874             enddo
 875 C
 876 C 12/1/95, revised on 5/20/97
 877 C
 878 C Calculate the contact function. The ith column of the array JCONT will
 879 C contain the numbers of atoms that make contacts with the atom I (of numbers
 880 C greater than I). The arrays FACONT and GACONT will contain the values of
 881 C the contact function and its derivative.
 882 C
 883 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 884 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 885 C Uncomment next line, if the correlation interactions are contact function only
 886             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 887               rij=dsqrt(rij)
 888               sigij=sigma(itypi,itypj)
 889               r0ij=rs0(itypi,itypj)
 890 C
 891 C Check whether the SC's are not too far to make a contact.
 892 C
 893               rcut=1.5d0*r0ij
 894               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 895 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 896 C
 897               if (fcont.gt.0.0D0) then
 898 C If the SC-SC distance if close to sigma, apply spline.
 899 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 900 cAdam &             fcont1,fprimcont1)
 901 cAdam           fcont1=1.0d0-fcont1
 902 cAdam           if (fcont1.gt.0.0d0) then
 903 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 904 cAdam             fcont=fcont*fcont1
 905 cAdam           endif
 906 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 907 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 908 cga             do k=1,3
 909 cga               gg(k)=gg(k)*eps0ij
 910 cga             enddo
 911 cga             eps0ij=-evdwij*eps0ij
 912 C Uncomment for AL's type of SC correlation interactions.
 913 cadam           eps0ij=-evdwij
 914                 num_conti=num_conti+1
 915                 jcont(num_conti,i)=j
 916                 facont(num_conti,i)=fcont*eps0ij
 917                 fprimcont=eps0ij*fprimcont/rij
 918                 fcont=expon*fcont
 919 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 920 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 921 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 922 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 923                 gacont(1,num_conti,i)=-fprimcont*xj
 924                 gacont(2,num_conti,i)=-fprimcont*yj
 925                 gacont(3,num_conti,i)=-fprimcont*zj
 926 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 927 cd              write (iout,'(2i3,3f10.5)')
 928 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 929               endif
 930             endif
 931           enddo      ! j
 932         enddo        ! iint
 933 C Change 12/1/95
 934         num_cont(i)=num_conti
 935       enddo          ! i
 936       do i=1,nct
 937         do j=1,3
 938           gvdwc(j,i)=expon*gvdwc(j,i)
 939           gvdwx(j,i)=expon*gvdwx(j,i)
 940         enddo
 941       enddo
 942 C******************************************************************************
 943 C
 944 C                              N O T E !!!
 945 C
 946 C To save time, the factor of EXPON has been extracted from ALL components
 947 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 948 C use!
 949 C
 950 C******************************************************************************
 951       return
 952       end
 953 C-----------------------------------------------------------------------------
 954       subroutine eljk(evdw)
 955 C
 956 C This subroutine calculates the interaction energy of nonbonded side chains
 957 C assuming the LJK potential of interaction.
 958 C
 959       implicit real*8 (a-h,o-z)
 960       include 'DIMENSIONS'
 961       include 'COMMON.GEO'
 962       include 'COMMON.VAR'
 963       include 'COMMON.LOCAL'
 964       include 'COMMON.CHAIN'
 965       include 'COMMON.DERIV'
 966       include 'COMMON.INTERACT'
 967       include 'COMMON.IOUNITS'
 968       include 'COMMON.NAMES'
 969       dimension gg(3)
 970       logical scheck
 971 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 972       evdw=0.0D0
 973       do i=iatsc_s,iatsc_e
 974         itypi=itype(i)
 975         itypi1=itype(i+1)
 976         xi=c(1,nres+i)
 977         yi=c(2,nres+i)
 978         zi=c(3,nres+i)
 979 C
 980 C Calculate SC interaction energy.
 981 C
 982         do iint=1,nint_gr(i)
 983           do j=istart(i,iint),iend(i,iint)
 984             itypj=itype(j)
 985             xj=c(1,nres+j)-xi
 986             yj=c(2,nres+j)-yi
 987             zj=c(3,nres+j)-zi
 988             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 989             fac_augm=rrij**expon
 990             e_augm=augm(itypi,itypj)*fac_augm
 991             r_inv_ij=dsqrt(rrij)
 992             rij=1.0D0/r_inv_ij
 993             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 994             fac=r_shift_inv**expon
 995             e1=fac*fac*aa(itypi,itypj)
 996             e2=fac*bb(itypi,itypj)
 997             evdwij=e_augm+e1+e2
 998 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 999 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1000 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1001 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1002 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1003 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1004 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1005             evdw=evdw+evdwij
1006 C
1007 C Calculate the components of the gradient in DC and X
1008 C
1009             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1010             gg(1)=xj*fac
1011             gg(2)=yj*fac
1012             gg(3)=zj*fac
1013             do k=1,3
1014               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1015               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1016             enddo
1017             do k=i,j-1
1018               do l=1,3
1019                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
1020               enddo
1021             enddo
1022           enddo      ! j
1023         enddo        ! iint
1024       enddo          ! i
1025       do i=1,nct
1026         do j=1,3
1027           gvdwc(j,i)=expon*gvdwc(j,i)
1028           gvdwx(j,i)=expon*gvdwx(j,i)
1029         enddo
1030       enddo
1031       return
1032       end
1033 C-----------------------------------------------------------------------------
1034       subroutine ebp(evdw)
1035 C
1036 C This subroutine calculates the interaction energy of nonbonded side chains
1037 C assuming the Berne-Pechukas potential of interaction.
1038 C
1039       implicit real*8 (a-h,o-z)
1040       include 'DIMENSIONS'
1041       include 'COMMON.GEO'
1042       include 'COMMON.VAR'
1043       include 'COMMON.LOCAL'
1044       include 'COMMON.CHAIN'
1045       include 'COMMON.DERIV'
1046       include 'COMMON.NAMES'
1047       include 'COMMON.INTERACT'
1048       include 'COMMON.IOUNITS'
1049       include 'COMMON.CALC'
1050       common /srutu/ icall
1051 c     double precision rrsave(maxdim)
1052       logical lprn
1053       evdw=0.0D0
1054 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1055       evdw=0.0D0
1056 c     if (icall.eq.0) then
1057 c       lprn=.true.
1058 c     else
1059         lprn=.false.
1060 c     endif
1061       ind=0
1062       do i=iatsc_s,iatsc_e
1063         itypi=itype(i)
1064         itypi1=itype(i+1)
1065         xi=c(1,nres+i)
1066         yi=c(2,nres+i)
1067         zi=c(3,nres+i)
1068         dxi=dc_norm(1,nres+i)
1069         dyi=dc_norm(2,nres+i)
1070         dzi=dc_norm(3,nres+i)
1071 c        dsci_inv=dsc_inv(itypi)
1072         dsci_inv=vbld_inv(i+nres)
1073 C
1074 C Calculate SC interaction energy.
1075 C
1076         do iint=1,nint_gr(i)
1077           do j=istart(i,iint),iend(i,iint)
1078             ind=ind+1
1079             itypj=itype(j)
1080 c            dscj_inv=dsc_inv(itypj)
1081             dscj_inv=vbld_inv(j+nres)
1082             chi1=chi(itypi,itypj)
1083             chi2=chi(itypj,itypi)
1084             chi12=chi1*chi2
1085             chip1=chip(itypi)
1086             chip2=chip(itypj)
1087             chip12=chip1*chip2
1088             alf1=alp(itypi)
1089             alf2=alp(itypj)
1090             alf12=0.5D0*(alf1+alf2)
1091 C For diagnostics only!!!
1092 c           chi1=0.0D0
1093 c           chi2=0.0D0
1094 c           chi12=0.0D0
1095 c           chip1=0.0D0
1096 c           chip2=0.0D0
1097 c           chip12=0.0D0
1098 c           alf1=0.0D0
1099 c           alf2=0.0D0
1100 c           alf12=0.0D0
1101             xj=c(1,nres+j)-xi
1102             yj=c(2,nres+j)-yi
1103             zj=c(3,nres+j)-zi
1104             dxj=dc_norm(1,nres+j)
1105             dyj=dc_norm(2,nres+j)
1106             dzj=dc_norm(3,nres+j)
1107             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1108 cd          if (icall.eq.0) then
1109 cd            rrsave(ind)=rrij
1110 cd          else
1111 cd            rrij=rrsave(ind)
1112 cd          endif
1113             rij=dsqrt(rrij)
1114 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1115             call sc_angular
1116 C Calculate whole angle-dependent part of epsilon and contributions
1117 C to its derivatives
1118             fac=(rrij*sigsq)**expon2
1119             e1=fac*fac*aa(itypi,itypj)
1120             e2=fac*bb(itypi,itypj)
1121             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1122             eps2der=evdwij*eps3rt
1123             eps3der=evdwij*eps2rt
1124             evdwij=evdwij*eps2rt*eps3rt
1125             evdw=evdw+evdwij
1126             if (lprn) then
1127             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1128             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1129 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1130 cd     &        restyp(itypi),i,restyp(itypj),j,
1131 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1132 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1133 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1134 cd     &        evdwij
1135             endif
1136 C Calculate gradient components.
1137             e1=e1*eps1*eps2rt**2*eps3rt**2
1138             fac=-expon*(e1+evdwij)
1139             sigder=fac/sigsq
1140             fac=rrij*fac
1141 C Calculate radial part of the gradient
1142             gg(1)=xj*fac
1143             gg(2)=yj*fac
1144             gg(3)=zj*fac
1145 C Calculate the angular part of the gradient and sum add the contributions
1146 C to the appropriate components of the Cartesian gradient.
1147             call sc_grad
1148           enddo      ! j
1149         enddo        ! iint
1150       enddo          ! i
1151 c     stop
1152       return
1153       end
1154 C-----------------------------------------------------------------------------
1155       subroutine egb(evdw)
1156 C
1157 C This subroutine calculates the interaction energy of nonbonded side chains
1158 C assuming the Gay-Berne potential of interaction.
1159 C
1160       implicit real*8 (a-h,o-z)
1161       include 'DIMENSIONS'
1162       include 'COMMON.GEO'
1163       include 'COMMON.VAR'
1164       include 'COMMON.LOCAL'
1165       include 'COMMON.CHAIN'
1166       include 'COMMON.DERIV'
1167       include 'COMMON.NAMES'
1168       include 'COMMON.INTERACT'
1169       include 'COMMON.IOUNITS'
1170       include 'COMMON.CALC'
1171       include 'COMMON.CONTROL'
1172       logical lprn
1173       evdw=0.0D0
1174 ccccc      energy_dec=.false.
1175 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1176       evdw=0.0D0
1177       lprn=.false.
1178 c     if (icall.eq.0) lprn=.false.
1179       ind=0
1180       do i=iatsc_s,iatsc_e
1181         itypi=itype(i)
1182         itypi1=itype(i+1)
1183         xi=c(1,nres+i)
1184         yi=c(2,nres+i)
1185         zi=c(3,nres+i)
1186         dxi=dc_norm(1,nres+i)
1187         dyi=dc_norm(2,nres+i)
1188         dzi=dc_norm(3,nres+i)
1189 c        dsci_inv=dsc_inv(itypi)
1190         dsci_inv=vbld_inv(i+nres)
1191 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1192 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1193 C
1194 C Calculate SC interaction energy.
1195 C
1196         do iint=1,nint_gr(i)
1197           do j=istart(i,iint),iend(i,iint)
1198             ind=ind+1
1199             itypj=itype(j)
1200 c            dscj_inv=dsc_inv(itypj)
1201             dscj_inv=vbld_inv(j+nres)
1202 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1203 c     &       1.0d0/vbld(j+nres)
1204 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1205             sig0ij=sigma(itypi,itypj)
1206             chi1=chi(itypi,itypj)
1207             chi2=chi(itypj,itypi)
1208             chi12=chi1*chi2
1209             chip1=chip(itypi)
1210             chip2=chip(itypj)
1211             chip12=chip1*chip2
1212             alf1=alp(itypi)
1213             alf2=alp(itypj)
1214             alf12=0.5D0*(alf1+alf2)
1215 C For diagnostics only!!!
1216 c           chi1=0.0D0
1217 c           chi2=0.0D0
1218 c           chi12=0.0D0
1219 c           chip1=0.0D0
1220 c           chip2=0.0D0
1221 c           chip12=0.0D0
1222 c           alf1=0.0D0
1223 c           alf2=0.0D0
1224 c           alf12=0.0D0
1225             xj=c(1,nres+j)-xi
1226             yj=c(2,nres+j)-yi
1227             zj=c(3,nres+j)-zi
1228             dxj=dc_norm(1,nres+j)
1229             dyj=dc_norm(2,nres+j)
1230             dzj=dc_norm(3,nres+j)
1231 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1232 c            write (iout,*) "j",j," dc_norm",
1233 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1234             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1235             rij=dsqrt(rrij)
1236 C Calculate angle-dependent terms of energy and contributions to their
1237 C derivatives.
1238             call sc_angular
1239             sigsq=1.0D0/sigsq
1240             sig=sig0ij*dsqrt(sigsq)
1241             rij_shift=1.0D0/rij-sig+sig0ij
1242 c for diagnostics; uncomment
1243 c            rij_shift=1.2*sig0ij
1244 C I hate to put IF's in the loops, but here don't have another choice!!!!
1245             if (rij_shift.le.0.0D0) then
1246               evdw=1.0D20
1247 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1248 cd     &        restyp(itypi),i,restyp(itypj),j,
1249 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1250               return
1251             endif
1252             sigder=-sig*sigsq
1253 c---------------------------------------------------------------
1254             rij_shift=1.0D0/rij_shift
1255             fac=rij_shift**expon
1256             e1=fac*fac*aa(itypi,itypj)
1257             e2=fac*bb(itypi,itypj)
1258             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1259             eps2der=evdwij*eps3rt
1260             eps3der=evdwij*eps2rt
1261 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1262 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1263             evdwij=evdwij*eps2rt*eps3rt
1264             evdw=evdw+evdwij
1265             if (lprn) then
1266             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1267             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1268             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1269      &        restyp(itypi),i,restyp(itypj),j,
1270      &        epsi,sigm,chi1,chi2,chip1,chip2,
1271      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1272      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1273      &        evdwij
1274             endif
1275
1276             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1277      &                        'evdw',i,j,evdwij
1278
1279 C Calculate gradient components.
1280             e1=e1*eps1*eps2rt**2*eps3rt**2
1281             fac=-expon*(e1+evdwij)*rij_shift
1282             sigder=fac*sigder
1283             fac=rij*fac
1284 c            fac=0.0d0
1285 C Calculate the radial part of the gradient
1286             gg(1)=xj*fac
1287             gg(2)=yj*fac
1288             gg(3)=zj*fac
1289 C Calculate angular part of the gradient.
1290             call sc_grad
1291           enddo      ! j
1292         enddo        ! iint
1293       enddo          ! i
1294 c      write (iout,*) "Number of loop steps in EGB:",ind
1295 cccc      energy_dec=.false.
1296       return
1297       end
1298 C-----------------------------------------------------------------------------
1299       subroutine egbv(evdw)
1300 C
1301 C This subroutine calculates the interaction energy of nonbonded side chains
1302 C assuming the Gay-Berne-Vorobjev potential of interaction.
1303 C
1304       implicit real*8 (a-h,o-z)
1305       include 'DIMENSIONS'
1306       include 'COMMON.GEO'
1307       include 'COMMON.VAR'
1308       include 'COMMON.LOCAL'
1309       include 'COMMON.CHAIN'
1310       include 'COMMON.DERIV'
1311       include 'COMMON.NAMES'
1312       include 'COMMON.INTERACT'
1313       include 'COMMON.IOUNITS'
1314       include 'COMMON.CALC'
1315       common /srutu/ icall
1316       logical lprn
1317       evdw=0.0D0
1318 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1319       evdw=0.0D0
1320       lprn=.false.
1321 c     if (icall.eq.0) lprn=.true.
1322       ind=0
1323       do i=iatsc_s,iatsc_e
1324         itypi=itype(i)
1325         itypi1=itype(i+1)
1326         xi=c(1,nres+i)
1327         yi=c(2,nres+i)
1328         zi=c(3,nres+i)
1329         dxi=dc_norm(1,nres+i)
1330         dyi=dc_norm(2,nres+i)
1331         dzi=dc_norm(3,nres+i)
1332 c        dsci_inv=dsc_inv(itypi)
1333         dsci_inv=vbld_inv(i+nres)
1334 C
1335 C Calculate SC interaction energy.
1336 C
1337         do iint=1,nint_gr(i)
1338           do j=istart(i,iint),iend(i,iint)
1339             ind=ind+1
1340             itypj=itype(j)
1341 c            dscj_inv=dsc_inv(itypj)
1342             dscj_inv=vbld_inv(j+nres)
1343             sig0ij=sigma(itypi,itypj)
1344             r0ij=r0(itypi,itypj)
1345             chi1=chi(itypi,itypj)
1346             chi2=chi(itypj,itypi)
1347             chi12=chi1*chi2
1348             chip1=chip(itypi)
1349             chip2=chip(itypj)
1350             chip12=chip1*chip2
1351             alf1=alp(itypi)
1352             alf2=alp(itypj)
1353             alf12=0.5D0*(alf1+alf2)
1354 C For diagnostics only!!!
1355 c           chi1=0.0D0
1356 c           chi2=0.0D0
1357 c           chi12=0.0D0
1358 c           chip1=0.0D0
1359 c           chip2=0.0D0
1360 c           chip12=0.0D0
1361 c           alf1=0.0D0
1362 c           alf2=0.0D0
1363 c           alf12=0.0D0
1364             xj=c(1,nres+j)-xi
1365             yj=c(2,nres+j)-yi
1366             zj=c(3,nres+j)-zi
1367             dxj=dc_norm(1,nres+j)
1368             dyj=dc_norm(2,nres+j)
1369             dzj=dc_norm(3,nres+j)
1370             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1371             rij=dsqrt(rrij)
1372 C Calculate angle-dependent terms of energy and contributions to their
1373 C derivatives.
1374             call sc_angular
1375             sigsq=1.0D0/sigsq
1376             sig=sig0ij*dsqrt(sigsq)
1377             rij_shift=1.0D0/rij-sig+r0ij
1378 C I hate to put IF's in the loops, but here don't have another choice!!!!
1379             if (rij_shift.le.0.0D0) then
1380               evdw=1.0D20
1381               return
1382             endif
1383             sigder=-sig*sigsq
1384 c---------------------------------------------------------------
1385             rij_shift=1.0D0/rij_shift
1386             fac=rij_shift**expon
1387             e1=fac*fac*aa(itypi,itypj)
1388             e2=fac*bb(itypi,itypj)
1389             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1390             eps2der=evdwij*eps3rt
1391             eps3der=evdwij*eps2rt
1392             fac_augm=rrij**expon
1393             e_augm=augm(itypi,itypj)*fac_augm
1394             evdwij=evdwij*eps2rt*eps3rt
1395             evdw=evdw+evdwij+e_augm
1396             if (lprn) then
1397             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1398             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1399             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1400      &        restyp(itypi),i,restyp(itypj),j,
1401      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1402      &        chi1,chi2,chip1,chip2,
1403      &        eps1,eps2rt**2,eps3rt**2,
1404      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1405      &        evdwij+e_augm
1406             endif
1407 C Calculate gradient components.
1408             e1=e1*eps1*eps2rt**2*eps3rt**2
1409             fac=-expon*(e1+evdwij)*rij_shift
1410             sigder=fac*sigder
1411             fac=rij*fac-2*expon*rrij*e_augm
1412 C Calculate the radial part of the gradient
1413             gg(1)=xj*fac
1414             gg(2)=yj*fac
1415             gg(3)=zj*fac
1416 C Calculate angular part of the gradient.
1417             call sc_grad
1418           enddo      ! j
1419         enddo        ! iint
1420       enddo          ! i
1421       end
1422 C-----------------------------------------------------------------------------
1423       subroutine sc_angular
1424 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1425 C om12. Called by ebp, egb, and egbv.
1426       implicit none
1427       include 'COMMON.CALC'
1428       include 'COMMON.IOUNITS'
1429       erij(1)=xj*rij
1430       erij(2)=yj*rij
1431       erij(3)=zj*rij
1432       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1433       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1434       om12=dxi*dxj+dyi*dyj+dzi*dzj
1435       chiom12=chi12*om12
1436 C Calculate eps1(om12) and its derivative in om12
1437       faceps1=1.0D0-om12*chiom12
1438       faceps1_inv=1.0D0/faceps1
1439       eps1=dsqrt(faceps1_inv)
1440 C Following variable is eps1*deps1/dom12
1441       eps1_om12=faceps1_inv*chiom12
1442 c diagnostics only
1443 c      faceps1_inv=om12
1444 c      eps1=om12
1445 c      eps1_om12=1.0d0
1446 c      write (iout,*) "om12",om12," eps1",eps1
1447 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1448 C and om12.
1449       om1om2=om1*om2
1450       chiom1=chi1*om1
1451       chiom2=chi2*om2
1452       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1453       sigsq=1.0D0-facsig*faceps1_inv
1454       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1455       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1456       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1457 c diagnostics only
1458 c      sigsq=1.0d0
1459 c      sigsq_om1=0.0d0
1460 c      sigsq_om2=0.0d0
1461 c      sigsq_om12=0.0d0
1462 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1463 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1464 c     &    " eps1",eps1
1465 C Calculate eps2 and its derivatives in om1, om2, and om12.
1466       chipom1=chip1*om1
1467       chipom2=chip2*om2
1468       chipom12=chip12*om12
1469       facp=1.0D0-om12*chipom12
1470       facp_inv=1.0D0/facp
1471       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1472 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1473 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1474 C Following variable is the square root of eps2
1475       eps2rt=1.0D0-facp1*facp_inv
1476 C Following three variables are the derivatives of the square root of eps
1477 C in om1, om2, and om12.
1478       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1479       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1480       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1481 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1482       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1483 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1484 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1485 c     &  " eps2rt_om12",eps2rt_om12
1486 C Calculate whole angle-dependent part of epsilon and contributions
1487 C to its derivatives
1488       return
1489       end
1490 C----------------------------------------------------------------------------
1491       subroutine sc_grad
1492       implicit real*8 (a-h,o-z)
1493       include 'DIMENSIONS'
1494       include 'COMMON.CHAIN'
1495       include 'COMMON.DERIV'
1496       include 'COMMON.CALC'
1497       include 'COMMON.IOUNITS'
1498       double precision dcosom1(3),dcosom2(3)
1499       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1500       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1501       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1502      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1503 c diagnostics only
1504 c      eom1=0.0d0
1505 c      eom2=0.0d0
1506 c      eom12=evdwij*eps1_om12
1507 c end diagnostics
1508 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1509 c     &  " sigder",sigder
1510 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1511 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1512       do k=1,3
1513         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1514         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1515       enddo
1516       do k=1,3
1517         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1518       enddo
1519 c      write (iout,*) "gg",(gg(k),k=1,3)
1520       do k=1,3
1521         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1522      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1523      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1524         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1525      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1526      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1527 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1528 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1529 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1530 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1531       enddo
1532 C
1533 C Calculate the components of the gradient in DC and X
1534 C
1535       do k=i,j-1
1536         do l=1,3
1537           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1538         enddo
1539       enddo
1540       return
1541       end
1542 C-----------------------------------------------------------------------
1543       subroutine e_softsphere(evdw)
1544 C
1545 C This subroutine calculates the interaction energy of nonbonded side chains
1546 C assuming the LJ potential of interaction.
1547 C
1548       implicit real*8 (a-h,o-z)
1549       include 'DIMENSIONS'
1550       parameter (accur=1.0d-10)
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.INTERACT'
1557       include 'COMMON.TORSION'
1558       include 'COMMON.SBRIDGE'
1559       include 'COMMON.NAMES'
1560       include 'COMMON.IOUNITS'
1561       include 'COMMON.CONTACTS'
1562       dimension gg(3)
1563 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1564       evdw=0.0D0
1565       do i=iatsc_s,iatsc_e
1566         itypi=itype(i)
1567         itypi1=itype(i+1)
1568         xi=c(1,nres+i)
1569         yi=c(2,nres+i)
1570         zi=c(3,nres+i)
1571 C
1572 C Calculate SC interaction energy.
1573 C
1574         do iint=1,nint_gr(i)
1575 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1576 cd   &                  'iend=',iend(i,iint)
1577           do j=istart(i,iint),iend(i,iint)
1578             itypj=itype(j)
1579             xj=c(1,nres+j)-xi
1580             yj=c(2,nres+j)-yi
1581             zj=c(3,nres+j)-zi
1582             rij=xj*xj+yj*yj+zj*zj
1583 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1584             r0ij=r0(itypi,itypj)
1585             r0ijsq=r0ij*r0ij
1586 c            print *,i,j,r0ij,dsqrt(rij)
1587             if (rij.lt.r0ijsq) then
1588               evdwij=0.25d0*(rij-r0ijsq)**2
1589               fac=rij-r0ijsq
1590             else
1591               evdwij=0.0d0
1592               fac=0.0d0
1593             endif
1594             evdw=evdw+evdwij
1595 C
1596 C Calculate the components of the gradient in DC and X
1597 C
1598             gg(1)=xj*fac
1599             gg(2)=yj*fac
1600             gg(3)=zj*fac
1601             do k=1,3
1602               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1603               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1604             enddo
1605             do k=i,j-1
1606               do l=1,3
1607                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
1608               enddo
1609             enddo
1610           enddo ! j
1611         enddo ! iint
1612       enddo ! i
1613       return
1614       end
1615 C--------------------------------------------------------------------------
1616       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1617      &              eello_turn4)
1618 C
1619 C Soft-sphere potential of p-p interaction
1620 C
1621       implicit real*8 (a-h,o-z)
1622       include 'DIMENSIONS'
1623       include 'COMMON.CONTROL'
1624       include 'COMMON.IOUNITS'
1625       include 'COMMON.GEO'
1626       include 'COMMON.VAR'
1627       include 'COMMON.LOCAL'
1628       include 'COMMON.CHAIN'
1629       include 'COMMON.DERIV'
1630       include 'COMMON.INTERACT'
1631       include 'COMMON.CONTACTS'
1632       include 'COMMON.TORSION'
1633       include 'COMMON.VECTORS'
1634       include 'COMMON.FFIELD'
1635       dimension ggg(3)
1636 cd      write(iout,*) 'In EELEC_soft_sphere'
1637       num_conti_hb=0
1638       ees=0.0D0
1639       evdw1=0.0D0
1640       eel_loc=0.0d0
1641       eello_turn3=0.0d0
1642       eello_turn4=0.0d0
1643       ind=0
1644       do i=iatel_s,iatel_e
1645         dxi=dc(1,i)
1646         dyi=dc(2,i)
1647         dzi=dc(3,i)
1648         xmedi=c(1,i)+0.5d0*dxi
1649         ymedi=c(2,i)+0.5d0*dyi
1650         zmedi=c(3,i)+0.5d0*dzi
1651         num_conti=0
1652 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1653         do j=ielstart(i),ielend(i)
1654           ind=ind+1
1655           iteli=itel(i)
1656           itelj=itel(j)
1657           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1658           r0ij=rpp(iteli,itelj)
1659           r0ijsq=r0ij*r0ij
1660           dxj=dc(1,j)
1661           dyj=dc(2,j)
1662           dzj=dc(3,j)
1663           xj=c(1,j)+0.5D0*dxj-xmedi
1664           yj=c(2,j)+0.5D0*dyj-ymedi
1665           zj=c(3,j)+0.5D0*dzj-zmedi
1666           rij=xj*xj+yj*yj+zj*zj
1667           if (rij.lt.r0ijsq) then
1668             evdw1ij=0.25d0*(rij-r0ijsq)**2
1669             fac=rij-r0ijsq
1670           else
1671             evdw1ij=0.0d0
1672             fac=0.0d0
1673           endif
1674           evdw1=evdw1+evdw1ij
1675 C
1676 C Calculate contributions to the Cartesian gradient.
1677 C
1678           ggg(1)=fac*xj
1679           ggg(2)=fac*yj
1680           ggg(3)=fac*zj
1681           do k=1,3
1682             ghalf=0.5D0*ggg(k)
1683             gelc(k,i)=gelc(k,i)+ghalf
1684             gelc(k,j)=gelc(k,j)+ghalf
1685           enddo
1686 *
1687 * Loop over residues i+1 thru j-1.
1688 *
1689           do k=i+1,j-1
1690             do l=1,3
1691               gelc(l,k)=gelc(l,k)+ggg(l)
1692             enddo
1693           enddo
1694         enddo ! j
1695       enddo   ! i
1696       return
1697       end
1698 c------------------------------------------------------------------------------
1699       subroutine vec_and_deriv
1700       implicit real*8 (a-h,o-z)
1701       include 'DIMENSIONS'
1702 #ifdef MPI
1703       include 'mpif.h'
1704 #endif
1705       include 'COMMON.IOUNITS'
1706       include 'COMMON.GEO'
1707       include 'COMMON.VAR'
1708       include 'COMMON.LOCAL'
1709       include 'COMMON.CHAIN'
1710       include 'COMMON.VECTORS'
1711       include 'COMMON.SETUP'
1712       include 'COMMON.TIME1'
1713       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1714 C Compute the local reference systems. For reference system (i), the
1715 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1716 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1717 c      do i=1,nres-1
1718       do i=ivec_start,ivec_end
1719           if (i.eq.nres-1) then
1720 C Case of the last full residue
1721 C Compute the Z-axis
1722             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1723             costh=dcos(pi-theta(nres))
1724             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1725             do k=1,3
1726               uz(k,i)=fac*uz(k,i)
1727             enddo
1728 C Compute the derivatives of uz
1729             uzder(1,1,1)= 0.0d0
1730             uzder(2,1,1)=-dc_norm(3,i-1)
1731             uzder(3,1,1)= dc_norm(2,i-1)
1732             uzder(1,2,1)= dc_norm(3,i-1)
1733             uzder(2,2,1)= 0.0d0
1734             uzder(3,2,1)=-dc_norm(1,i-1)
1735             uzder(1,3,1)=-dc_norm(2,i-1)
1736             uzder(2,3,1)= dc_norm(1,i-1)
1737             uzder(3,3,1)= 0.0d0
1738             uzder(1,1,2)= 0.0d0
1739             uzder(2,1,2)= dc_norm(3,i)
1740             uzder(3,1,2)=-dc_norm(2,i)
1741             uzder(1,2,2)=-dc_norm(3,i)
1742             uzder(2,2,2)= 0.0d0
1743             uzder(3,2,2)= dc_norm(1,i)
1744             uzder(1,3,2)= dc_norm(2,i)
1745             uzder(2,3,2)=-dc_norm(1,i)
1746             uzder(3,3,2)= 0.0d0
1747 C Compute the Y-axis
1748             facy=fac
1749             do k=1,3
1750               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1751             enddo
1752 C Compute the derivatives of uy
1753             do j=1,3
1754               do k=1,3
1755                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1756      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1757                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1758               enddo
1759               uyder(j,j,1)=uyder(j,j,1)-costh
1760               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1761             enddo
1762             do j=1,2
1763               do k=1,3
1764                 do l=1,3
1765                   uygrad(l,k,j,i)=uyder(l,k,j)
1766                   uzgrad(l,k,j,i)=uzder(l,k,j)
1767                 enddo
1768               enddo
1769             enddo
1770             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1771             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1772             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1773             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1774           else
1775 C Other residues
1776 C Compute the Z-axis
1777             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1778             costh=dcos(pi-theta(i+2))
1779             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1780             do k=1,3
1781               uz(k,i)=fac*uz(k,i)
1782             enddo
1783 C Compute the derivatives of uz
1784             uzder(1,1,1)= 0.0d0
1785             uzder(2,1,1)=-dc_norm(3,i+1)
1786             uzder(3,1,1)= dc_norm(2,i+1)
1787             uzder(1,2,1)= dc_norm(3,i+1)
1788             uzder(2,2,1)= 0.0d0
1789             uzder(3,2,1)=-dc_norm(1,i+1)
1790             uzder(1,3,1)=-dc_norm(2,i+1)
1791             uzder(2,3,1)= dc_norm(1,i+1)
1792             uzder(3,3,1)= 0.0d0
1793             uzder(1,1,2)= 0.0d0
1794             uzder(2,1,2)= dc_norm(3,i)
1795             uzder(3,1,2)=-dc_norm(2,i)
1796             uzder(1,2,2)=-dc_norm(3,i)
1797             uzder(2,2,2)= 0.0d0
1798             uzder(3,2,2)= dc_norm(1,i)
1799             uzder(1,3,2)= dc_norm(2,i)
1800             uzder(2,3,2)=-dc_norm(1,i)
1801             uzder(3,3,2)= 0.0d0
1802 C Compute the Y-axis
1803             facy=fac
1804             do k=1,3
1805               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1806             enddo
1807 C Compute the derivatives of uy
1808             do j=1,3
1809               do k=1,3
1810                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1811      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1812                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1813               enddo
1814               uyder(j,j,1)=uyder(j,j,1)-costh
1815               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1816             enddo
1817             do j=1,2
1818               do k=1,3
1819                 do l=1,3
1820                   uygrad(l,k,j,i)=uyder(l,k,j)
1821                   uzgrad(l,k,j,i)=uzder(l,k,j)
1822                 enddo
1823               enddo
1824             enddo
1825             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1826             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1827             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1828             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1829           endif
1830       enddo
1831       do i=1,nres-1
1832         vbld_inv_temp(1)=vbld_inv(i+1)
1833         if (i.lt.nres-1) then
1834           vbld_inv_temp(2)=vbld_inv(i+2)
1835           else
1836           vbld_inv_temp(2)=vbld_inv(i)
1837           endif
1838         do j=1,2
1839           do k=1,3
1840             do l=1,3
1841               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1842               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1843             enddo
1844           enddo
1845         enddo
1846       enddo
1847 #ifdef MPI
1848       if (nfgtasks.gt.1) then
1849         time00=MPI_Wtime()
1850 c        print *,"Processor",fg_rank,kolor," ivec_start",ivec_start,
1851 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
1852 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
1853         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank),
1854      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1855      &   FG_COMM,IERR)
1856         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank),
1857      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1858      &   FG_COMM,IERR)
1859         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
1860      &   ivec_count(fg_rank),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
1861      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1862         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
1863      &   ivec_count(fg_rank),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
1864      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1865         time_gather=time_gather+MPI_Wtime()-time00
1866       endif
1867 c      if (fg_rank.eq.0) then
1868 c        write (iout,*) "Arrays UY and UZ"
1869 c        do i=1,nres-1
1870 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1871 c     &     (uz(k,i),k=1,3)
1872 c        enddo
1873 c      endif
1874 #endif
1875       return
1876       end
1877 C-----------------------------------------------------------------------------
1878       subroutine check_vecgrad
1879       implicit real*8 (a-h,o-z)
1880       include 'DIMENSIONS'
1881       include 'COMMON.IOUNITS'
1882       include 'COMMON.GEO'
1883       include 'COMMON.VAR'
1884       include 'COMMON.LOCAL'
1885       include 'COMMON.CHAIN'
1886       include 'COMMON.VECTORS'
1887       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1888       dimension uyt(3,maxres),uzt(3,maxres)
1889       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1890       double precision delta /1.0d-7/
1891       call vec_and_deriv
1892 cd      do i=1,nres
1893 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1894 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1895 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1896 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1897 cd     &     (dc_norm(if90,i),if90=1,3)
1898 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1899 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1900 cd          write(iout,'(a)')
1901 cd      enddo
1902       do i=1,nres
1903         do j=1,2
1904           do k=1,3
1905             do l=1,3
1906               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1907               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1908             enddo
1909           enddo
1910         enddo
1911       enddo
1912       call vec_and_deriv
1913       do i=1,nres
1914         do j=1,3
1915           uyt(j,i)=uy(j,i)
1916           uzt(j,i)=uz(j,i)
1917         enddo
1918       enddo
1919       do i=1,nres
1920 cd        write (iout,*) 'i=',i
1921         do k=1,3
1922           erij(k)=dc_norm(k,i)
1923         enddo
1924         do j=1,3
1925           do k=1,3
1926             dc_norm(k,i)=erij(k)
1927           enddo
1928           dc_norm(j,i)=dc_norm(j,i)+delta
1929 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1930 c          do k=1,3
1931 c            dc_norm(k,i)=dc_norm(k,i)/fac
1932 c          enddo
1933 c          write (iout,*) (dc_norm(k,i),k=1,3)
1934 c          write (iout,*) (erij(k),k=1,3)
1935           call vec_and_deriv
1936           do k=1,3
1937             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1938             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1939             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1940             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1941           enddo
1942 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1943 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1944 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1945         enddo
1946         do k=1,3
1947           dc_norm(k,i)=erij(k)
1948         enddo
1949 cd        do k=1,3
1950 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1951 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1952 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1953 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1954 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1955 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1956 cd          write (iout,'(a)')
1957 cd        enddo
1958       enddo
1959       return
1960       end
1961 C--------------------------------------------------------------------------
1962       subroutine set_matrices
1963       implicit real*8 (a-h,o-z)
1964       include 'DIMENSIONS'
1965       include 'COMMON.IOUNITS'
1966       include 'COMMON.GEO'
1967       include 'COMMON.VAR'
1968       include 'COMMON.LOCAL'
1969       include 'COMMON.CHAIN'
1970       include 'COMMON.DERIV'
1971       include 'COMMON.INTERACT'
1972       include 'COMMON.CONTACTS'
1973       include 'COMMON.TORSION'
1974       include 'COMMON.VECTORS'
1975       include 'COMMON.FFIELD'
1976       double precision auxvec(2),auxmat(2,2)
1977 C
1978 C Compute the virtual-bond-torsional-angle dependent quantities needed
1979 C to calculate the el-loc multibody terms of various order.
1980 C
1981       do i=3,nres+1
1982         if (i .lt. nres+1) then
1983           sin1=dsin(phi(i))
1984           cos1=dcos(phi(i))
1985           sintab(i-2)=sin1
1986           costab(i-2)=cos1
1987           obrot(1,i-2)=cos1
1988           obrot(2,i-2)=sin1
1989           sin2=dsin(2*phi(i))
1990           cos2=dcos(2*phi(i))
1991           sintab2(i-2)=sin2
1992           costab2(i-2)=cos2
1993           obrot2(1,i-2)=cos2
1994           obrot2(2,i-2)=sin2
1995           Ug(1,1,i-2)=-cos1
1996           Ug(1,2,i-2)=-sin1
1997           Ug(2,1,i-2)=-sin1
1998           Ug(2,2,i-2)= cos1
1999           Ug2(1,1,i-2)=-cos2
2000           Ug2(1,2,i-2)=-sin2
2001           Ug2(2,1,i-2)=-sin2
2002           Ug2(2,2,i-2)= cos2
2003         else
2004           costab(i-2)=1.0d0
2005           sintab(i-2)=0.0d0
2006           obrot(1,i-2)=1.0d0
2007           obrot(2,i-2)=0.0d0
2008           obrot2(1,i-2)=0.0d0
2009           obrot2(2,i-2)=0.0d0
2010           Ug(1,1,i-2)=1.0d0
2011           Ug(1,2,i-2)=0.0d0
2012           Ug(2,1,i-2)=0.0d0
2013           Ug(2,2,i-2)=1.0d0
2014           Ug2(1,1,i-2)=0.0d0
2015           Ug2(1,2,i-2)=0.0d0
2016           Ug2(2,1,i-2)=0.0d0
2017           Ug2(2,2,i-2)=0.0d0
2018         endif
2019         if (i .gt. 3 .and. i .lt. nres+1) then
2020           obrot_der(1,i-2)=-sin1
2021           obrot_der(2,i-2)= cos1
2022           Ugder(1,1,i-2)= sin1
2023           Ugder(1,2,i-2)=-cos1
2024           Ugder(2,1,i-2)=-cos1
2025           Ugder(2,2,i-2)=-sin1
2026           dwacos2=cos2+cos2
2027           dwasin2=sin2+sin2
2028           obrot2_der(1,i-2)=-dwasin2
2029           obrot2_der(2,i-2)= dwacos2
2030           Ug2der(1,1,i-2)= dwasin2
2031           Ug2der(1,2,i-2)=-dwacos2
2032           Ug2der(2,1,i-2)=-dwacos2
2033           Ug2der(2,2,i-2)=-dwasin2
2034         else
2035           obrot_der(1,i-2)=0.0d0
2036           obrot_der(2,i-2)=0.0d0
2037           Ugder(1,1,i-2)=0.0d0
2038           Ugder(1,2,i-2)=0.0d0
2039           Ugder(2,1,i-2)=0.0d0
2040           Ugder(2,2,i-2)=0.0d0
2041           obrot2_der(1,i-2)=0.0d0
2042           obrot2_der(2,i-2)=0.0d0
2043           Ug2der(1,1,i-2)=0.0d0
2044           Ug2der(1,2,i-2)=0.0d0
2045           Ug2der(2,1,i-2)=0.0d0
2046           Ug2der(2,2,i-2)=0.0d0
2047         endif
2048 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2049         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2050           iti = itortyp(itype(i-2))
2051         else
2052           iti=ntortyp+1
2053         endif
2054 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2055         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2056           iti1 = itortyp(itype(i-1))
2057         else
2058           iti1=ntortyp+1
2059         endif
2060 cd        write (iout,*) '*******i',i,' iti1',iti
2061 cd        write (iout,*) 'b1',b1(:,iti)
2062 cd        write (iout,*) 'b2',b2(:,iti)
2063 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2064 c        if (i .gt. iatel_s+2) then
2065         if (i .gt. nnt+2) then
2066           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2067           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2068           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2069           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2070           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2071           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2072           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2073         else
2074           do k=1,2
2075             Ub2(k,i-2)=0.0d0
2076             Ctobr(k,i-2)=0.0d0
2077             Dtobr2(k,i-2)=0.0d0
2078             do l=1,2
2079               EUg(l,k,i-2)=0.0d0
2080               CUg(l,k,i-2)=0.0d0
2081               DUg(l,k,i-2)=0.0d0
2082               DtUg2(l,k,i-2)=0.0d0
2083             enddo
2084           enddo
2085         endif
2086         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2087         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2088         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2089         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2090         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2091         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2092         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2093         do k=1,2
2094           muder(k,i-2)=Ub2der(k,i-2)
2095         enddo
2096 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2097         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2098           iti1 = itortyp(itype(i-1))
2099         else
2100           iti1=ntortyp+1
2101         endif
2102         do k=1,2
2103           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2104         enddo
2105 C Vectors and matrices dependent on a single virtual-bond dihedral.
2106         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2107         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2108         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2109         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2110         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2111         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2112         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2113         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2114         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2115 cd        write (iout,*) 'mu ',mu(:,i-2)
2116 cd        write (iout,*) 'mu1',mu1(:,i-2)
2117 cd        write (iout,*) 'mu2',mu2(:,i-2)
2118       enddo
2119 C Matrices dependent on two consecutive virtual-bond dihedrals.
2120 C The order of matrices is from left to right.
2121       do i=2,nres-1
2122         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2123         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2124         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2125         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2126         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2127         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2128         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2129         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2130       enddo
2131 cd      do i=1,nres
2132 cd        iti = itortyp(itype(i))
2133 cd        write (iout,*) i
2134 cd        do j=1,2
2135 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2136 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2137 cd        enddo
2138 cd      enddo
2139       return
2140       end
2141 C--------------------------------------------------------------------------
2142       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2143 C
2144 C This subroutine calculates the average interaction energy and its gradient
2145 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2146 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2147 C The potential depends both on the distance of peptide-group centers and on
2148 C the orientation of the CA-CA virtual bonds.
2149 C
2150       implicit real*8 (a-h,o-z)
2151       include 'DIMENSIONS'
2152       include 'COMMON.CONTROL'
2153       include 'COMMON.IOUNITS'
2154       include 'COMMON.GEO'
2155       include 'COMMON.VAR'
2156       include 'COMMON.LOCAL'
2157       include 'COMMON.CHAIN'
2158       include 'COMMON.DERIV'
2159       include 'COMMON.INTERACT'
2160       include 'COMMON.CONTACTS'
2161       include 'COMMON.TORSION'
2162       include 'COMMON.VECTORS'
2163       include 'COMMON.FFIELD'
2164       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2165      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2166       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2167      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2168       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2169 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2170 #ifdef MOMENT
2171       double precision scal_el /1.0d0/
2172 #else
2173       double precision scal_el /0.5d0/
2174 #endif
2175 C 12/13/98
2176 C 13-go grudnia roku pamietnego...
2177       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2178      &                   0.0d0,1.0d0,0.0d0,
2179      &                   0.0d0,0.0d0,1.0d0/
2180 cd      write(iout,*) 'In EELEC'
2181 cd      do i=1,nloctyp
2182 cd        write(iout,*) 'Type',i
2183 cd        write(iout,*) 'B1',B1(:,i)
2184 cd        write(iout,*) 'B2',B2(:,i)
2185 cd        write(iout,*) 'CC',CC(:,:,i)
2186 cd        write(iout,*) 'DD',DD(:,:,i)
2187 cd        write(iout,*) 'EE',EE(:,:,i)
2188 cd      enddo
2189 cd      call check_vecgrad
2190 cd      stop
2191       if (icheckgrad.eq.1) then
2192         do i=1,nres-1
2193           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2194           do k=1,3
2195             dc_norm(k,i)=dc(k,i)*fac
2196           enddo
2197 c          write (iout,*) 'i',i,' fac',fac
2198         enddo
2199       endif
2200       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2201      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2202      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2203 c        call vec_and_deriv
2204         call set_matrices
2205       endif
2206 cd      do i=1,nres-1
2207 cd        write (iout,*) 'i=',i
2208 cd        do k=1,3
2209 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2210 cd        enddo
2211 cd        do k=1,3
2212 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2213 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2214 cd        enddo
2215 cd      enddo
2216       num_conti_hb=0
2217       ees=0.0D0
2218       evdw1=0.0D0
2219       eel_loc=0.0d0
2220       eello_turn3=0.0d0
2221       eello_turn4=0.0d0
2222       ind=0
2223       do i=1,nres
2224         num_cont_hb(i)=0
2225       enddo
2226 cd      print '(a)','Enter EELEC'
2227 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2228       do i=1,nres
2229         gel_loc_loc(i)=0.0d0
2230         gcorr_loc(i)=0.0d0
2231       enddo
2232       do i=iatel_s,iatel_e
2233         dxi=dc(1,i)
2234         dyi=dc(2,i)
2235         dzi=dc(3,i)
2236         dx_normi=dc_norm(1,i)
2237         dy_normi=dc_norm(2,i)
2238         dz_normi=dc_norm(3,i)
2239         xmedi=c(1,i)+0.5d0*dxi
2240         ymedi=c(2,i)+0.5d0*dyi
2241         zmedi=c(3,i)+0.5d0*dzi
2242         num_conti=0
2243 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2244         do j=ielstart(i),ielend(i)
2245           ind=ind+1
2246           iteli=itel(i)
2247           itelj=itel(j)
2248           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2249           aaa=app(iteli,itelj)
2250           bbb=bpp(iteli,itelj)
2251           ael6i=ael6(iteli,itelj)
2252           ael3i=ael3(iteli,itelj)
2253 C Diagnostics only!!!
2254 c         aaa=0.0D0
2255 c         bbb=0.0D0
2256 c         ael6i=0.0D0
2257 c         ael3i=0.0D0
2258 C End diagnostics
2259           dxj=dc(1,j)
2260           dyj=dc(2,j)
2261           dzj=dc(3,j)
2262           dx_normj=dc_norm(1,j)
2263           dy_normj=dc_norm(2,j)
2264           dz_normj=dc_norm(3,j)
2265           xj=c(1,j)+0.5D0*dxj-xmedi
2266           yj=c(2,j)+0.5D0*dyj-ymedi
2267           zj=c(3,j)+0.5D0*dzj-zmedi
2268           rij=xj*xj+yj*yj+zj*zj
2269           rrmij=1.0D0/rij
2270           rij=dsqrt(rij)
2271           rmij=1.0D0/rij
2272           r3ij=rrmij*rmij
2273           r6ij=r3ij*r3ij
2274           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2275           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2276           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2277           fac=cosa-3.0D0*cosb*cosg
2278           ev1=aaa*r6ij*r6ij
2279 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2280           if (j.eq.i+2) ev1=scal_el*ev1
2281           ev2=bbb*r6ij
2282           fac3=ael6i*r6ij
2283           fac4=ael3i*r3ij
2284           evdwij=ev1+ev2
2285           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2286           el2=fac4*fac
2287           eesij=el1+el2
2288 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2289           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2290           ees=ees+eesij
2291           evdw1=evdw1+evdwij
2292 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2293 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2294 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2295 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2296
2297           if (energy_dec) then
2298               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2299               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2300           endif
2301
2302 C
2303 C Calculate contributions to the Cartesian gradient.
2304 C
2305 #ifdef SPLITELE
2306           facvdw=-6*rrmij*(ev1+evdwij)
2307           facel=-3*rrmij*(el1+eesij)
2308           fac1=fac
2309           erij(1)=xj*rmij
2310           erij(2)=yj*rmij
2311           erij(3)=zj*rmij
2312 *
2313 * Radial derivatives. First process both termini of the fragment (i,j)
2314 *
2315           ggg(1)=facel*xj
2316           ggg(2)=facel*yj
2317           ggg(3)=facel*zj
2318           do k=1,3
2319             ghalf=0.5D0*ggg(k)
2320             gelc(k,i)=gelc(k,i)+ghalf
2321             gelc(k,j)=gelc(k,j)+ghalf
2322           enddo
2323 *
2324 * Loop over residues i+1 thru j-1.
2325 *
2326           do k=i+1,j-1
2327             do l=1,3
2328               gelc(l,k)=gelc(l,k)+ggg(l)
2329             enddo
2330           enddo
2331           ggg(1)=facvdw*xj
2332           ggg(2)=facvdw*yj
2333           ggg(3)=facvdw*zj
2334           do k=1,3
2335             ghalf=0.5D0*ggg(k)
2336             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2337             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2338           enddo
2339 *
2340 * Loop over residues i+1 thru j-1.
2341 *
2342           do k=i+1,j-1
2343             do l=1,3
2344               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2345             enddo
2346           enddo
2347 #else
2348           facvdw=ev1+evdwij
2349           facel=el1+eesij
2350           fac1=fac
2351           fac=-3*rrmij*(facvdw+facvdw+facel)
2352           erij(1)=xj*rmij
2353           erij(2)=yj*rmij
2354           erij(3)=zj*rmij
2355 *
2356 * Radial derivatives. First process both termini of the fragment (i,j)
2357 *
2358           ggg(1)=fac*xj
2359           ggg(2)=fac*yj
2360           ggg(3)=fac*zj
2361           do k=1,3
2362             ghalf=0.5D0*ggg(k)
2363             gelc(k,i)=gelc(k,i)+ghalf
2364             gelc(k,j)=gelc(k,j)+ghalf
2365           enddo
2366 *
2367 * Loop over residues i+1 thru j-1.
2368 *
2369           do k=i+1,j-1
2370             do l=1,3
2371               gelc(l,k)=gelc(l,k)+ggg(l)
2372             enddo
2373           enddo
2374 #endif
2375 *
2376 * Angular part
2377 *
2378           ecosa=2.0D0*fac3*fac1+fac4
2379           fac4=-3.0D0*fac4
2380           fac3=-6.0D0*fac3
2381           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2382           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2383           do k=1,3
2384             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2385             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2386           enddo
2387 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2388 cd   &          (dcosg(k),k=1,3)
2389           do k=1,3
2390             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2391           enddo
2392           do k=1,3
2393             ghalf=0.5D0*ggg(k)
2394             gelc(k,i)=gelc(k,i)+ghalf
2395      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2396      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2397             gelc(k,j)=gelc(k,j)+ghalf
2398      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2399      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2400           enddo
2401           do k=i+1,j-1
2402             do l=1,3
2403               gelc(l,k)=gelc(l,k)+ggg(l)
2404             enddo
2405           enddo
2406
2407           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2408      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2409      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2410 C
2411 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2412 C   energy of a peptide unit is assumed in the form of a second-order
2413 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2414 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2415 C   are computed for EVERY pair of non-contiguous peptide groups.
2416 C
2417           if (j.lt.nres-1) then
2418             j1=j+1
2419             j2=j-1
2420           else
2421             j1=j-1
2422             j2=j-2
2423           endif
2424           kkk=0
2425           do k=1,2
2426             do l=1,2
2427               kkk=kkk+1
2428               muij(kkk)=mu(k,i)*mu(l,j)
2429             enddo
2430           enddo
2431 cd         write (iout,*) 'EELEC: i',i,' j',j
2432 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2433 cd          write(iout,*) 'muij',muij
2434           ury=scalar(uy(1,i),erij)
2435           urz=scalar(uz(1,i),erij)
2436           vry=scalar(uy(1,j),erij)
2437           vrz=scalar(uz(1,j),erij)
2438           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2439           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2440           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2441           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2442 C For diagnostics only
2443 cd          a22=1.0d0
2444 cd          a23=1.0d0
2445 cd          a32=1.0d0
2446 cd          a33=1.0d0
2447           fac=dsqrt(-ael6i)*r3ij
2448 cd          write (2,*) 'fac=',fac
2449 C For diagnostics only
2450 cd          fac=1.0d0
2451           a22=a22*fac
2452           a23=a23*fac
2453           a32=a32*fac
2454           a33=a33*fac
2455 cd          write (iout,'(4i5,4f10.5)')
2456 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2457 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2458 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2459 cd     &      uy(:,j),uz(:,j)
2460 cd          write (iout,'(4f10.5)')
2461 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2462 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2463 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2464 cd           write (iout,'(9f10.5/)')
2465 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2466 C Derivatives of the elements of A in virtual-bond vectors
2467           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2468 cd          do k=1,3
2469 cd            do l=1,3
2470 cd              erder(k,l)=0.0d0
2471 cd            enddo
2472 cd          enddo
2473           do k=1,3
2474             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2475             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2476             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2477             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2478             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2479             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2480             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2481             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2482             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2483             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2484             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2485             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2486           enddo
2487 cd          do k=1,3
2488 cd            do l=1,3
2489 cd              uryg(k,l)=0.0d0
2490 cd              urzg(k,l)=0.0d0
2491 cd              vryg(k,l)=0.0d0
2492 cd              vrzg(k,l)=0.0d0
2493 cd            enddo
2494 cd          enddo
2495 C Compute radial contributions to the gradient
2496           facr=-3.0d0*rrmij
2497           a22der=a22*facr
2498           a23der=a23*facr
2499           a32der=a32*facr
2500           a33der=a33*facr
2501 cd          a22der=0.0d0
2502 cd          a23der=0.0d0
2503 cd          a32der=0.0d0
2504 cd          a33der=0.0d0
2505           agg(1,1)=a22der*xj
2506           agg(2,1)=a22der*yj
2507           agg(3,1)=a22der*zj
2508           agg(1,2)=a23der*xj
2509           agg(2,2)=a23der*yj
2510           agg(3,2)=a23der*zj
2511           agg(1,3)=a32der*xj
2512           agg(2,3)=a32der*yj
2513           agg(3,3)=a32der*zj
2514           agg(1,4)=a33der*xj
2515           agg(2,4)=a33der*yj
2516           agg(3,4)=a33der*zj
2517 C Add the contributions coming from er
2518           fac3=-3.0d0*fac
2519           do k=1,3
2520             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2521             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2522             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2523             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2524           enddo
2525           do k=1,3
2526 C Derivatives in DC(i)
2527             ghalf1=0.5d0*agg(k,1)
2528             ghalf2=0.5d0*agg(k,2)
2529             ghalf3=0.5d0*agg(k,3)
2530             ghalf4=0.5d0*agg(k,4)
2531             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2532      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2533             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2534      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2535             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2536      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2537             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2538      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2539 C Derivatives in DC(i+1)
2540             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2541      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2542             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2543      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2544             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2545      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2546             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2547      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2548 C Derivatives in DC(j)
2549             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2550      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2551             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2552      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2553             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2554      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2555             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2556      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2557 C Derivatives in DC(j+1) or DC(nres-1)
2558             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2559      &      -3.0d0*vryg(k,3)*ury)
2560             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2561      &      -3.0d0*vrzg(k,3)*ury)
2562             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2563      &      -3.0d0*vryg(k,3)*urz)
2564             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2565      &      -3.0d0*vrzg(k,3)*urz)
2566 cd            aggi(k,1)=ghalf1
2567 cd            aggi(k,2)=ghalf2
2568 cd            aggi(k,3)=ghalf3
2569 cd            aggi(k,4)=ghalf4
2570 C Derivatives in DC(i+1)
2571 cd            aggi1(k,1)=agg(k,1)
2572 cd            aggi1(k,2)=agg(k,2)
2573 cd            aggi1(k,3)=agg(k,3)
2574 cd            aggi1(k,4)=agg(k,4)
2575 C Derivatives in DC(j)
2576 cd            aggj(k,1)=ghalf1
2577 cd            aggj(k,2)=ghalf2
2578 cd            aggj(k,3)=ghalf3
2579 cd            aggj(k,4)=ghalf4
2580 C Derivatives in DC(j+1)
2581 cd            aggj1(k,1)=0.0d0
2582 cd            aggj1(k,2)=0.0d0
2583 cd            aggj1(k,3)=0.0d0
2584 cd            aggj1(k,4)=0.0d0
2585             if (j.eq.nres-1 .and. i.lt.j-2) then
2586               do l=1,4
2587                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2588 cd                aggj1(k,l)=agg(k,l)
2589               enddo
2590             endif
2591           enddo
2592 c          goto 11111
2593 C Check the loc-el terms by numerical integration
2594           acipa(1,1)=a22
2595           acipa(1,2)=a23
2596           acipa(2,1)=a32
2597           acipa(2,2)=a33
2598           a22=-a22
2599           a23=-a23
2600           do l=1,2
2601             do k=1,3
2602               agg(k,l)=-agg(k,l)
2603               aggi(k,l)=-aggi(k,l)
2604               aggi1(k,l)=-aggi1(k,l)
2605               aggj(k,l)=-aggj(k,l)
2606               aggj1(k,l)=-aggj1(k,l)
2607             enddo
2608           enddo
2609           if (j.lt.nres-1) then
2610             a22=-a22
2611             a32=-a32
2612             do l=1,3,2
2613               do k=1,3
2614                 agg(k,l)=-agg(k,l)
2615                 aggi(k,l)=-aggi(k,l)
2616                 aggi1(k,l)=-aggi1(k,l)
2617                 aggj(k,l)=-aggj(k,l)
2618                 aggj1(k,l)=-aggj1(k,l)
2619               enddo
2620             enddo
2621           else
2622             a22=-a22
2623             a23=-a23
2624             a32=-a32
2625             a33=-a33
2626             do l=1,4
2627               do k=1,3
2628                 agg(k,l)=-agg(k,l)
2629                 aggi(k,l)=-aggi(k,l)
2630                 aggi1(k,l)=-aggi1(k,l)
2631                 aggj(k,l)=-aggj(k,l)
2632                 aggj1(k,l)=-aggj1(k,l)
2633               enddo
2634             enddo
2635           endif
2636           ENDIF ! WCORR
2637 11111     continue
2638           IF (wel_loc.gt.0.0d0) THEN
2639 C Contribution to the local-electrostatic energy coming from the i-j pair
2640           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2641      &     +a33*muij(4)
2642 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2643
2644           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2645      &            'eelloc',i,j,eel_loc_ij
2646
2647           eel_loc=eel_loc+eel_loc_ij
2648 C Partial derivatives in virtual-bond dihedral angles gamma
2649           if (i.gt.1)
2650      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2651      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2652      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2653           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2654      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2655      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2656 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2657 cd          write(iout,*) 'agg  ',agg
2658 cd          write(iout,*) 'aggi ',aggi
2659 cd          write(iout,*) 'aggi1',aggi1
2660 cd          write(iout,*) 'aggj ',aggj
2661 cd          write(iout,*) 'aggj1',aggj1
2662
2663 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2664           do l=1,3
2665             ggg(l)=agg(l,1)*muij(1)+
2666      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2667           enddo
2668           do k=i+2,j2
2669             do l=1,3
2670               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2671             enddo
2672           enddo
2673 C Remaining derivatives of eello
2674           do l=1,3
2675             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2676      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2677             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2678      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2679             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2680      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2681             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2682      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2683           enddo
2684           ENDIF
2685           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2686 C Contributions from turns
2687             a_temp(1,1)=a22
2688             a_temp(1,2)=a23
2689             a_temp(2,1)=a32
2690             a_temp(2,2)=a33
2691             call eturn34(i,j,eello_turn3,eello_turn4)
2692           endif
2693 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2694           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2695 C
2696 C Calculate the contact function. The ith column of the array JCONT will
2697 C contain the numbers of atoms that make contacts with the atom I (of numbers
2698 C greater than I). The arrays FACONT and GACONT will contain the values of
2699 C the contact function and its derivative.
2700 c           r0ij=1.02D0*rpp(iteli,itelj)
2701 c           r0ij=1.11D0*rpp(iteli,itelj)
2702             r0ij=2.20D0*rpp(iteli,itelj)
2703 c           r0ij=1.55D0*rpp(iteli,itelj)
2704             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2705             if (fcont.gt.0.0D0) then
2706               num_conti=num_conti+1
2707               if (num_conti.gt.maxconts) then
2708                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2709      &                         ' will skip next contacts for this conf.'
2710               else
2711                 jcont_hb(num_conti,i)=j
2712                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2713      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2714 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2715 C  terms.
2716                 d_cont(num_conti,i)=rij
2717 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2718 C     --- Electrostatic-interaction matrix ---
2719                 a_chuj(1,1,num_conti,i)=a22
2720                 a_chuj(1,2,num_conti,i)=a23
2721                 a_chuj(2,1,num_conti,i)=a32
2722                 a_chuj(2,2,num_conti,i)=a33
2723 C     --- Gradient of rij
2724                 do kkk=1,3
2725                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2726                 enddo
2727 c             if (i.eq.1) then
2728 c                a_chuj(1,1,num_conti,i)=-0.61d0
2729 c                a_chuj(1,2,num_conti,i)= 0.4d0
2730 c                a_chuj(2,1,num_conti,i)= 0.65d0
2731 c                a_chuj(2,2,num_conti,i)= 0.50d0
2732 c             else if (i.eq.2) then
2733 c                a_chuj(1,1,num_conti,i)= 0.0d0
2734 c                a_chuj(1,2,num_conti,i)= 0.0d0
2735 c                a_chuj(2,1,num_conti,i)= 0.0d0
2736 c                a_chuj(2,2,num_conti,i)= 0.0d0
2737 c             endif
2738 C     --- and its gradients
2739 cd                write (iout,*) 'i',i,' j',j
2740 cd                do kkk=1,3
2741 cd                write (iout,*) 'iii 1 kkk',kkk
2742 cd                write (iout,*) agg(kkk,:)
2743 cd                enddo
2744 cd                do kkk=1,3
2745 cd                write (iout,*) 'iii 2 kkk',kkk
2746 cd                write (iout,*) aggi(kkk,:)
2747 cd                enddo
2748 cd                do kkk=1,3
2749 cd                write (iout,*) 'iii 3 kkk',kkk
2750 cd                write (iout,*) aggi1(kkk,:)
2751 cd                enddo
2752 cd                do kkk=1,3
2753 cd                write (iout,*) 'iii 4 kkk',kkk
2754 cd                write (iout,*) aggj(kkk,:)
2755 cd                enddo
2756 cd                do kkk=1,3
2757 cd                write (iout,*) 'iii 5 kkk',kkk
2758 cd                write (iout,*) aggj1(kkk,:)
2759 cd                enddo
2760                 kkll=0
2761                 do k=1,2
2762                   do l=1,2
2763                     kkll=kkll+1
2764                     do m=1,3
2765                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2766                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2767                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2768                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2769                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2770 c                      do mm=1,5
2771 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2772 c                      enddo
2773                     enddo
2774                   enddo
2775                 enddo
2776                 ENDIF
2777                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2778 C Calculate contact energies
2779                 cosa4=4.0D0*cosa
2780                 wij=cosa-3.0D0*cosb*cosg
2781                 cosbg1=cosb+cosg
2782                 cosbg2=cosb-cosg
2783 c               fac3=dsqrt(-ael6i)/r0ij**3
2784                 fac3=dsqrt(-ael6i)*r3ij
2785 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2786                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
2787                 if (ees0tmp.gt.0) then
2788                   ees0pij=dsqrt(ees0tmp)
2789                 else
2790                   ees0pij=0
2791                 endif
2792 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2793                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
2794                 if (ees0tmp.gt.0) then
2795                   ees0mij=dsqrt(ees0tmp)
2796                 else
2797                   ees0mij=0
2798                 endif
2799 c               ees0mij=0.0D0
2800                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2801                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2802 C Diagnostics. Comment out or remove after debugging!
2803 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2804 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2805 c               ees0m(num_conti,i)=0.0D0
2806 C End diagnostics.
2807 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2808 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2809 C Angular derivatives of the contact function
2810                 ees0pij1=fac3/ees0pij
2811                 ees0mij1=fac3/ees0mij
2812                 fac3p=-3.0D0*fac3*rrmij
2813                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2814                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2815 c               ees0mij1=0.0D0
2816                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2817                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2818                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2819                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2820                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2821                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2822                 ecosap=ecosa1+ecosa2
2823                 ecosbp=ecosb1+ecosb2
2824                 ecosgp=ecosg1+ecosg2
2825                 ecosam=ecosa1-ecosa2
2826                 ecosbm=ecosb1-ecosb2
2827                 ecosgm=ecosg1-ecosg2
2828 C Diagnostics
2829 c               ecosap=ecosa1
2830 c               ecosbp=ecosb1
2831 c               ecosgp=ecosg1
2832 c               ecosam=0.0D0
2833 c               ecosbm=0.0D0
2834 c               ecosgm=0.0D0
2835 C End diagnostics
2836                 facont_hb(num_conti,i)=fcont
2837                 fprimcont=fprimcont/rij
2838 cd              facont_hb(num_conti,i)=1.0D0
2839 C Following line is for diagnostics.
2840 cd              fprimcont=0.0D0
2841                 do k=1,3
2842                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2843                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2844                 enddo
2845                 do k=1,3
2846                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2847                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2848                 enddo
2849                 gggp(1)=gggp(1)+ees0pijp*xj
2850                 gggp(2)=gggp(2)+ees0pijp*yj
2851                 gggp(3)=gggp(3)+ees0pijp*zj
2852                 gggm(1)=gggm(1)+ees0mijp*xj
2853                 gggm(2)=gggm(2)+ees0mijp*yj
2854                 gggm(3)=gggm(3)+ees0mijp*zj
2855 C Derivatives due to the contact function
2856                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2857                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2858                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2859                 do k=1,3
2860                   ghalfp=0.5D0*gggp(k)
2861                   ghalfm=0.5D0*gggm(k)
2862                   gacontp_hb1(k,num_conti,i)=ghalfp
2863      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2864      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2865                   gacontp_hb2(k,num_conti,i)=ghalfp
2866      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2867      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2868                   gacontp_hb3(k,num_conti,i)=gggp(k)
2869                   gacontm_hb1(k,num_conti,i)=ghalfm
2870      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2871      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2872                   gacontm_hb2(k,num_conti,i)=ghalfm
2873      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2874      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2875                   gacontm_hb3(k,num_conti,i)=gggm(k)
2876                 enddo
2877 C Diagnostics. Comment out or remove after debugging!
2878 cdiag           do k=1,3
2879 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2880 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2881 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2882 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2883 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2884 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2885 cdiag           enddo
2886               ENDIF ! wcorr
2887               endif  ! num_conti.le.maxconts
2888             endif  ! fcont.gt.0
2889           endif    ! j.gt.i+1
2890         enddo ! j
2891         num_cont_hb(i)=num_conti
2892       enddo   ! i
2893 c      write (iout,*) "Number of loop steps in EELEC:",ind
2894 cd      do i=1,nres
2895 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2896 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2897 cd      enddo
2898 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2899 ccc      eel_loc=eel_loc+eello_turn3
2900       return
2901       end
2902 C-----------------------------------------------------------------------------
2903       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2904 C Third- and fourth-order contributions from turns
2905       implicit real*8 (a-h,o-z)
2906       include 'DIMENSIONS'
2907       include 'COMMON.IOUNITS'
2908       include 'COMMON.GEO'
2909       include 'COMMON.VAR'
2910       include 'COMMON.LOCAL'
2911       include 'COMMON.CHAIN'
2912       include 'COMMON.DERIV'
2913       include 'COMMON.INTERACT'
2914       include 'COMMON.CONTACTS'
2915       include 'COMMON.TORSION'
2916       include 'COMMON.VECTORS'
2917       include 'COMMON.FFIELD'
2918       include 'COMMON.CONTROL'
2919       dimension ggg(3)
2920       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2921      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2922      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2923       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2924      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
2925       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2926       if (j.eq.i+2) then
2927 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2928 C
2929 C               Third-order contributions
2930 C
2931 C                 (i+2)o----(i+3)
2932 C                      | |
2933 C                      | |
2934 C                 (i+1)o----i
2935 C
2936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2937 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2938         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2939         call transpose2(auxmat(1,1),auxmat1(1,1))
2940         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2941         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2942         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2943      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
2944 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2945 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2946 cd     &    ' eello_turn3_num',4*eello_turn3_num
2947 C Derivatives in gamma(i)
2948         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2949         call transpose2(auxmat2(1,1),auxmat3(1,1))
2950         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
2951         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2952 C Derivatives in gamma(i+1)
2953         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2954         call transpose2(auxmat2(1,1),auxmat3(1,1))
2955         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
2956         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2957      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2958 C Cartesian derivatives
2959         do l=1,3
2960           a_temp(1,1)=aggi(l,1)
2961           a_temp(1,2)=aggi(l,2)
2962           a_temp(2,1)=aggi(l,3)
2963           a_temp(2,2)=aggi(l,4)
2964           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2965           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2966      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2967           a_temp(1,1)=aggi1(l,1)
2968           a_temp(1,2)=aggi1(l,2)
2969           a_temp(2,1)=aggi1(l,3)
2970           a_temp(2,2)=aggi1(l,4)
2971           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2972           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2973      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2974           a_temp(1,1)=aggj(l,1)
2975           a_temp(1,2)=aggj(l,2)
2976           a_temp(2,1)=aggj(l,3)
2977           a_temp(2,2)=aggj(l,4)
2978           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2979           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2980      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2981           a_temp(1,1)=aggj1(l,1)
2982           a_temp(1,2)=aggj1(l,2)
2983           a_temp(2,1)=aggj1(l,3)
2984           a_temp(2,2)=aggj1(l,4)
2985           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2986           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2987      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2988         enddo
2989       else if (j.eq.i+3) then
2990 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2991 C
2992 C               Fourth-order contributions
2993 C
2994 C                 (i+3)o----(i+4)
2995 C                     /  |
2996 C               (i+2)o   |
2997 C                     \  |
2998 C                 (i+1)o----i
2999 C
3000 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3001 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3002         iti1=itortyp(itype(i+1))
3003         iti2=itortyp(itype(i+2))
3004         iti3=itortyp(itype(i+3))
3005         call transpose2(EUg(1,1,i+1),e1t(1,1))
3006         call transpose2(Eug(1,1,i+2),e2t(1,1))
3007         call transpose2(Eug(1,1,i+3),e3t(1,1))
3008         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3009         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3010         s1=scalar2(b1(1,iti2),auxvec(1))
3011         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3012         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3013         s2=scalar2(b1(1,iti1),auxvec(1))
3014         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3015         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3016         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3017         eello_turn4=eello_turn4-(s1+s2+s3)
3018         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3019      &      'eturn4',i,j,-(s1+s2+s3)
3020 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3021 cd     &    ' eello_turn4_num',8*eello_turn4_num
3022 C Derivatives in gamma(i)
3023         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3024         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3025         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3026         s1=scalar2(b1(1,iti2),auxvec(1))
3027         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3028         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3029         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3030 C Derivatives in gamma(i+1)
3031         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3032         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3033         s2=scalar2(b1(1,iti1),auxvec(1))
3034         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3035         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3036         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3037         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3038 C Derivatives in gamma(i+2)
3039         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3040         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3041         s1=scalar2(b1(1,iti2),auxvec(1))
3042         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3043         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3044         s2=scalar2(b1(1,iti1),auxvec(1))
3045         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3046         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3047         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3048         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3049 C Cartesian derivatives
3050 C Derivatives of this turn contributions in DC(i+2)
3051         if (j.lt.nres-1) then
3052           do l=1,3
3053             a_temp(1,1)=agg(l,1)
3054             a_temp(1,2)=agg(l,2)
3055             a_temp(2,1)=agg(l,3)
3056             a_temp(2,2)=agg(l,4)
3057             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3058             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3059             s1=scalar2(b1(1,iti2),auxvec(1))
3060             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3061             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3062             s2=scalar2(b1(1,iti1),auxvec(1))
3063             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3064             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3065             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3066             ggg(l)=-(s1+s2+s3)
3067             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3068           enddo
3069         endif
3070 C Remaining derivatives of this turn contribution
3071         do l=1,3
3072           a_temp(1,1)=aggi(l,1)
3073           a_temp(1,2)=aggi(l,2)
3074           a_temp(2,1)=aggi(l,3)
3075           a_temp(2,2)=aggi(l,4)
3076           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3077           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3078           s1=scalar2(b1(1,iti2),auxvec(1))
3079           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3080           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3081           s2=scalar2(b1(1,iti1),auxvec(1))
3082           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3083           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3084           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3085           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3086           a_temp(1,1)=aggi1(l,1)
3087           a_temp(1,2)=aggi1(l,2)
3088           a_temp(2,1)=aggi1(l,3)
3089           a_temp(2,2)=aggi1(l,4)
3090           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3091           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3092           s1=scalar2(b1(1,iti2),auxvec(1))
3093           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3094           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3095           s2=scalar2(b1(1,iti1),auxvec(1))
3096           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3097           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3098           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3099           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3100           a_temp(1,1)=aggj(l,1)
3101           a_temp(1,2)=aggj(l,2)
3102           a_temp(2,1)=aggj(l,3)
3103           a_temp(2,2)=aggj(l,4)
3104           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3105           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3106           s1=scalar2(b1(1,iti2),auxvec(1))
3107           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3108           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3109           s2=scalar2(b1(1,iti1),auxvec(1))
3110           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3111           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3112           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3113           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3114           a_temp(1,1)=aggj1(l,1)
3115           a_temp(1,2)=aggj1(l,2)
3116           a_temp(2,1)=aggj1(l,3)
3117           a_temp(2,2)=aggj1(l,4)
3118           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3119           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3120           s1=scalar2(b1(1,iti2),auxvec(1))
3121           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3122           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3123           s2=scalar2(b1(1,iti1),auxvec(1))
3124           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3125           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3126           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3127           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3128         enddo
3129       endif
3130       return
3131       end
3132 C-----------------------------------------------------------------------------
3133       subroutine vecpr(u,v,w)
3134       implicit real*8(a-h,o-z)
3135       dimension u(3),v(3),w(3)
3136       w(1)=u(2)*v(3)-u(3)*v(2)
3137       w(2)=-u(1)*v(3)+u(3)*v(1)
3138       w(3)=u(1)*v(2)-u(2)*v(1)
3139       return
3140       end
3141 C-----------------------------------------------------------------------------
3142       subroutine unormderiv(u,ugrad,unorm,ungrad)
3143 C This subroutine computes the derivatives of a normalized vector u, given
3144 C the derivatives computed without normalization conditions, ugrad. Returns
3145 C ungrad.
3146       implicit none
3147       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3148       double precision vec(3)
3149       double precision scalar
3150       integer i,j
3151 c      write (2,*) 'ugrad',ugrad
3152 c      write (2,*) 'u',u
3153       do i=1,3
3154         vec(i)=scalar(ugrad(1,i),u(1))
3155       enddo
3156 c      write (2,*) 'vec',vec
3157       do i=1,3
3158         do j=1,3
3159           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3160         enddo
3161       enddo
3162 c      write (2,*) 'ungrad',ungrad
3163       return
3164       end
3165 C-----------------------------------------------------------------------------
3166       subroutine escp_soft_sphere(evdw2,evdw2_14)
3167 C
3168 C This subroutine calculates the excluded-volume interaction energy between
3169 C peptide-group centers and side chains and its gradient in virtual-bond and
3170 C side-chain vectors.
3171 C
3172       implicit real*8 (a-h,o-z)
3173       include 'DIMENSIONS'
3174       include 'COMMON.GEO'
3175       include 'COMMON.VAR'
3176       include 'COMMON.LOCAL'
3177       include 'COMMON.CHAIN'
3178       include 'COMMON.DERIV'
3179       include 'COMMON.INTERACT'
3180       include 'COMMON.FFIELD'
3181       include 'COMMON.IOUNITS'
3182       include 'COMMON.CONTROL'
3183       dimension ggg(3)
3184       evdw2=0.0D0
3185       evdw2_14=0.0d0
3186       r0_scp=4.5d0
3187 cd    print '(a)','Enter ESCP'
3188 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3189       do i=iatscp_s,iatscp_e
3190         iteli=itel(i)
3191         xi=0.5D0*(c(1,i)+c(1,i+1))
3192         yi=0.5D0*(c(2,i)+c(2,i+1))
3193         zi=0.5D0*(c(3,i)+c(3,i+1))
3194
3195         do iint=1,nscp_gr(i)
3196
3197         do j=iscpstart(i,iint),iscpend(i,iint)
3198           itypj=itype(j)
3199 C Uncomment following three lines for SC-p interactions
3200 c         xj=c(1,nres+j)-xi
3201 c         yj=c(2,nres+j)-yi
3202 c         zj=c(3,nres+j)-zi
3203 C Uncomment following three lines for Ca-p interactions
3204           xj=c(1,j)-xi
3205           yj=c(2,j)-yi
3206           zj=c(3,j)-zi
3207           rij=xj*xj+yj*yj+zj*zj
3208           r0ij=r0_scp
3209           r0ijsq=r0ij*r0ij
3210           if (rij.lt.r0ijsq) then
3211             evdwij=0.25d0*(rij-r0ijsq)**2
3212             fac=rij-r0ijsq
3213           else
3214             evdwij=0.0d0
3215             fac=0.0d0
3216           endif
3217           evdw2=evdw2+evdwij
3218 C
3219 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3220 C
3221           ggg(1)=xj*fac
3222           ggg(2)=yj*fac
3223           ggg(3)=zj*fac
3224           if (j.lt.i) then
3225 cd          write (iout,*) 'j<i'
3226 C Uncomment following three lines for SC-p interactions
3227 c           do k=1,3
3228 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3229 c           enddo
3230           else
3231 cd          write (iout,*) 'j>i'
3232             do k=1,3
3233               ggg(k)=-ggg(k)
3234 C Uncomment following line for SC-p interactions
3235 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3236             enddo
3237           endif
3238           do k=1,3
3239             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3240           enddo
3241           kstart=min0(i+1,j)
3242           kend=max0(i-1,j-1)
3243 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3244 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3245           do k=kstart,kend
3246             do l=1,3
3247               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3248             enddo
3249           enddo
3250         enddo
3251
3252         enddo ! iint
3253       enddo ! i
3254       return
3255       end
3256 C-----------------------------------------------------------------------------
3257       subroutine escp(evdw2,evdw2_14)
3258 C
3259 C This subroutine calculates the excluded-volume interaction energy between
3260 C peptide-group centers and side chains and its gradient in virtual-bond and
3261 C side-chain vectors.
3262 C
3263       implicit real*8 (a-h,o-z)
3264       include 'DIMENSIONS'
3265       include 'COMMON.GEO'
3266       include 'COMMON.VAR'
3267       include 'COMMON.LOCAL'
3268       include 'COMMON.CHAIN'
3269       include 'COMMON.DERIV'
3270       include 'COMMON.INTERACT'
3271       include 'COMMON.FFIELD'
3272       include 'COMMON.IOUNITS'
3273       include 'COMMON.CONTROL'
3274       dimension ggg(3)
3275       evdw2=0.0D0
3276       evdw2_14=0.0d0
3277 cd    print '(a)','Enter ESCP'
3278 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3279       do i=iatscp_s,iatscp_e
3280         iteli=itel(i)
3281         xi=0.5D0*(c(1,i)+c(1,i+1))
3282         yi=0.5D0*(c(2,i)+c(2,i+1))
3283         zi=0.5D0*(c(3,i)+c(3,i+1))
3284
3285         do iint=1,nscp_gr(i)
3286
3287         do j=iscpstart(i,iint),iscpend(i,iint)
3288           itypj=itype(j)
3289 C Uncomment following three lines for SC-p interactions
3290 c         xj=c(1,nres+j)-xi
3291 c         yj=c(2,nres+j)-yi
3292 c         zj=c(3,nres+j)-zi
3293 C Uncomment following three lines for Ca-p interactions
3294           xj=c(1,j)-xi
3295           yj=c(2,j)-yi
3296           zj=c(3,j)-zi
3297           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3298           fac=rrij**expon2
3299           e1=fac*fac*aad(itypj,iteli)
3300           e2=fac*bad(itypj,iteli)
3301           if (iabs(j-i) .le. 2) then
3302             e1=scal14*e1
3303             e2=scal14*e2
3304             evdw2_14=evdw2_14+e1+e2
3305           endif
3306           evdwij=e1+e2
3307           evdw2=evdw2+evdwij
3308           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3309      &        'evdw2',i,j,evdwij
3310 C
3311 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3312 C
3313           fac=-(evdwij+e1)*rrij
3314           ggg(1)=xj*fac
3315           ggg(2)=yj*fac
3316           ggg(3)=zj*fac
3317           if (j.lt.i) then
3318 cd          write (iout,*) 'j<i'
3319 C Uncomment following three lines for SC-p interactions
3320 c           do k=1,3
3321 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3322 c           enddo
3323           else
3324 cd          write (iout,*) 'j>i'
3325             do k=1,3
3326               ggg(k)=-ggg(k)
3327 C Uncomment following line for SC-p interactions
3328 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3329             enddo
3330           endif
3331           do k=1,3
3332             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3333           enddo
3334           kstart=min0(i+1,j)
3335           kend=max0(i-1,j-1)
3336 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3337 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3338           do k=kstart,kend
3339             do l=1,3
3340               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3341             enddo
3342           enddo
3343         enddo
3344
3345         enddo ! iint
3346       enddo ! i
3347       do i=1,nct
3348         do j=1,3
3349           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3350           gradx_scp(j,i)=expon*gradx_scp(j,i)
3351         enddo
3352       enddo
3353 C******************************************************************************
3354 C
3355 C                              N O T E !!!
3356 C
3357 C To save time the factor EXPON has been extracted from ALL components
3358 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3359 C use!
3360 C
3361 C******************************************************************************
3362       return
3363       end
3364 C--------------------------------------------------------------------------
3365       subroutine edis(ehpb)
3366 C
3367 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3368 C
3369       implicit real*8 (a-h,o-z)
3370       include 'DIMENSIONS'
3371       include 'COMMON.SBRIDGE'
3372       include 'COMMON.CHAIN'
3373       include 'COMMON.DERIV'
3374       include 'COMMON.VAR'
3375       include 'COMMON.INTERACT'
3376       dimension ggg(3)
3377       ehpb=0.0D0
3378 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3379 cd    print *,'link_start=',link_start,' link_end=',link_end
3380       if (link_end.eq.0) return
3381       do i=link_start,link_end
3382 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3383 C CA-CA distance used in regularization of structure.
3384         ii=ihpb(i)
3385         jj=jhpb(i)
3386 C iii and jjj point to the residues for which the distance is assigned.
3387         if (ii.gt.nres) then
3388           iii=ii-nres
3389           jjj=jj-nres
3390         else
3391           iii=ii
3392           jjj=jj
3393         endif
3394 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3395 C    distance and angle dependent SS bond potential.
3396         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3397           call ssbond_ene(iii,jjj,eij)
3398           ehpb=ehpb+2*eij
3399         else
3400 C Calculate the distance between the two points and its difference from the
3401 C target distance.
3402         dd=dist(ii,jj)
3403         rdis=dd-dhpb(i)
3404 C Get the force constant corresponding to this distance.
3405         waga=forcon(i)
3406 C Calculate the contribution to energy.
3407         ehpb=ehpb+waga*rdis*rdis
3408 C
3409 C Evaluate gradient.
3410 C
3411         fac=waga*rdis/dd
3412 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3413 cd   &   ' waga=',waga,' fac=',fac
3414         do j=1,3
3415           ggg(j)=fac*(c(j,jj)-c(j,ii))
3416         enddo
3417 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3418 C If this is a SC-SC distance, we need to calculate the contributions to the
3419 C Cartesian gradient in the SC vectors (ghpbx).
3420         if (iii.lt.ii) then
3421           do j=1,3
3422             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3423             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3424           enddo
3425         endif
3426         do j=iii,jjj-1
3427           do k=1,3
3428             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3429           enddo
3430         enddo
3431         endif
3432       enddo
3433       ehpb=0.5D0*ehpb
3434       return
3435       end
3436 C--------------------------------------------------------------------------
3437       subroutine ssbond_ene(i,j,eij)
3438 C
3439 C Calculate the distance and angle dependent SS-bond potential energy
3440 C using a free-energy function derived based on RHF/6-31G** ab initio
3441 C calculations of diethyl disulfide.
3442 C
3443 C A. Liwo and U. Kozlowska, 11/24/03
3444 C
3445       implicit real*8 (a-h,o-z)
3446       include 'DIMENSIONS'
3447       include 'COMMON.SBRIDGE'
3448       include 'COMMON.CHAIN'
3449       include 'COMMON.DERIV'
3450       include 'COMMON.LOCAL'
3451       include 'COMMON.INTERACT'
3452       include 'COMMON.VAR'
3453       include 'COMMON.IOUNITS'
3454       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3455       itypi=itype(i)
3456       xi=c(1,nres+i)
3457       yi=c(2,nres+i)
3458       zi=c(3,nres+i)
3459       dxi=dc_norm(1,nres+i)
3460       dyi=dc_norm(2,nres+i)
3461       dzi=dc_norm(3,nres+i)
3462       dsci_inv=dsc_inv(itypi)
3463       itypj=itype(j)
3464       dscj_inv=dsc_inv(itypj)
3465       xj=c(1,nres+j)-xi
3466       yj=c(2,nres+j)-yi
3467       zj=c(3,nres+j)-zi
3468       dxj=dc_norm(1,nres+j)
3469       dyj=dc_norm(2,nres+j)
3470       dzj=dc_norm(3,nres+j)
3471       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3472       rij=dsqrt(rrij)
3473       erij(1)=xj*rij
3474       erij(2)=yj*rij
3475       erij(3)=zj*rij
3476       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3477       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3478       om12=dxi*dxj+dyi*dyj+dzi*dzj
3479       do k=1,3
3480         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3481         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3482       enddo
3483       rij=1.0d0/rij
3484       deltad=rij-d0cm
3485       deltat1=1.0d0-om1
3486       deltat2=1.0d0+om2
3487       deltat12=om2-om1+2.0d0
3488       cosphi=om12-om1*om2
3489       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3490      &  +akct*deltad*deltat12
3491      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3492 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3493 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3494 c     &  " deltat12",deltat12," eij",eij
3495       ed=2*akcm*deltad+akct*deltat12
3496       pom1=akct*deltad
3497       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3498       eom1=-2*akth*deltat1-pom1-om2*pom2
3499       eom2= 2*akth*deltat2+pom1-om1*pom2
3500       eom12=pom2
3501       do k=1,3
3502         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3503       enddo
3504       do k=1,3
3505         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3506      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3507         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3508      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3509       enddo
3510 C
3511 C Calculate the components of the gradient in DC and X
3512 C
3513       do k=i,j-1
3514         do l=1,3
3515           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3516         enddo
3517       enddo
3518       return
3519       end
3520 C--------------------------------------------------------------------------
3521       subroutine ebond(estr)
3522 c
3523 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3524 c
3525       implicit real*8 (a-h,o-z)
3526       include 'DIMENSIONS'
3527       include 'COMMON.LOCAL'
3528       include 'COMMON.GEO'
3529       include 'COMMON.INTERACT'
3530       include 'COMMON.DERIV'
3531       include 'COMMON.VAR'
3532       include 'COMMON.CHAIN'
3533       include 'COMMON.IOUNITS'
3534       include 'COMMON.NAMES'
3535       include 'COMMON.FFIELD'
3536       include 'COMMON.CONTROL'
3537       include 'COMMON.SETUP'
3538       double precision u(3),ud(3)
3539       estr=0.0d0
3540       do i=ibondp_start,ibondp_end
3541         diff = vbld(i)-vbldp0
3542 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3543         estr=estr+diff*diff
3544         do j=1,3
3545           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3546         enddo
3547 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
3548       enddo
3549       estr=0.5d0*AKP*estr
3550 c
3551 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3552 c
3553       do i=ibond_start,ibond_end
3554         iti=itype(i)
3555         if (iti.ne.10) then
3556           nbi=nbondterm(iti)
3557           if (nbi.eq.1) then
3558             diff=vbld(i+nres)-vbldsc0(1,iti)
3559 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3560 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3561             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3562             do j=1,3
3563               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3564             enddo
3565           else
3566             do j=1,nbi
3567               diff=vbld(i+nres)-vbldsc0(j,iti)
3568               ud(j)=aksc(j,iti)*diff
3569               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3570             enddo
3571             uprod=u(1)
3572             do j=2,nbi
3573               uprod=uprod*u(j)
3574             enddo
3575             usum=0.0d0
3576             usumsqder=0.0d0
3577             do j=1,nbi
3578               uprod1=1.0d0
3579               uprod2=1.0d0
3580               do k=1,nbi
3581                 if (k.ne.j) then
3582                   uprod1=uprod1*u(k)
3583                   uprod2=uprod2*u(k)*u(k)
3584                 endif
3585               enddo
3586               usum=usum+uprod1
3587               usumsqder=usumsqder+ud(j)*uprod2
3588             enddo
3589             estr=estr+uprod/usum
3590             do j=1,3
3591              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3592             enddo
3593           endif
3594         endif
3595       enddo
3596       return
3597       end
3598 #ifdef CRYST_THETA
3599 C--------------------------------------------------------------------------
3600       subroutine ebend(etheta)
3601 C
3602 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3603 C angles gamma and its derivatives in consecutive thetas and gammas.
3604 C
3605       implicit real*8 (a-h,o-z)
3606       include 'DIMENSIONS'
3607       include 'COMMON.LOCAL'
3608       include 'COMMON.GEO'
3609       include 'COMMON.INTERACT'
3610       include 'COMMON.DERIV'
3611       include 'COMMON.VAR'
3612       include 'COMMON.CHAIN'
3613       include 'COMMON.IOUNITS'
3614       include 'COMMON.NAMES'
3615       include 'COMMON.FFIELD'
3616       include 'COMMON.CONTROL'
3617       common /calcthet/ term1,term2,termm,diffak,ratak,
3618      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3619      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3620       double precision y(2),z(2)
3621       delta=0.02d0*pi
3622 c      time11=dexp(-2*time)
3623 c      time12=1.0d0
3624       etheta=0.0D0
3625 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3626       do i=ithet_start,ithet_end
3627 C Zero the energy function and its derivative at 0 or pi.
3628         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3629         it=itype(i-1)
3630         if (i.gt.3) then
3631 #ifdef OSF
3632           phii=phi(i)
3633           if (phii.ne.phii) phii=150.0
3634 #else
3635           phii=phi(i)
3636 #endif
3637           y(1)=dcos(phii)
3638           y(2)=dsin(phii)
3639         else
3640           y(1)=0.0D0
3641           y(2)=0.0D0
3642         endif
3643         if (i.lt.nres) then
3644 #ifdef OSF
3645           phii1=phi(i+1)
3646           if (phii1.ne.phii1) phii1=150.0
3647           phii1=pinorm(phii1)
3648           z(1)=cos(phii1)
3649 #else
3650           phii1=phi(i+1)
3651           z(1)=dcos(phii1)
3652 #endif
3653           z(2)=dsin(phii1)
3654         else
3655           z(1)=0.0D0
3656           z(2)=0.0D0
3657         endif
3658 C Calculate the "mean" value of theta from the part of the distribution
3659 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3660 C In following comments this theta will be referred to as t_c.
3661         thet_pred_mean=0.0d0
3662         do k=1,2
3663           athetk=athet(k,it)
3664           bthetk=bthet(k,it)
3665           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3666         enddo
3667         dthett=thet_pred_mean*ssd
3668         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3669 C Derivatives of the "mean" values in gamma1 and gamma2.
3670         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3671         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3672         if (theta(i).gt.pi-delta) then
3673           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3674      &         E_tc0)
3675           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3676           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3677           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3678      &        E_theta)
3679           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3680      &        E_tc)
3681         else if (theta(i).lt.delta) then
3682           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3683           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3684           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3685      &        E_theta)
3686           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3687           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3688      &        E_tc)
3689         else
3690           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3691      &        E_theta,E_tc)
3692         endif
3693         etheta=etheta+ethetai
3694         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
3695      &      'ebend',i,ethetai
3696         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3697         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3698         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3699       enddo
3700 C Ufff.... We've done all this!!!
3701       return
3702       end
3703 C---------------------------------------------------------------------------
3704       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3705      &     E_tc)
3706       implicit real*8 (a-h,o-z)
3707       include 'DIMENSIONS'
3708       include 'COMMON.LOCAL'
3709       include 'COMMON.IOUNITS'
3710       common /calcthet/ term1,term2,termm,diffak,ratak,
3711      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3712      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3713 C Calculate the contributions to both Gaussian lobes.
3714 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3715 C The "polynomial part" of the "standard deviation" of this part of
3716 C the distribution.
3717         sig=polthet(3,it)
3718         do j=2,0,-1
3719           sig=sig*thet_pred_mean+polthet(j,it)
3720         enddo
3721 C Derivative of the "interior part" of the "standard deviation of the"
3722 C gamma-dependent Gaussian lobe in t_c.
3723         sigtc=3*polthet(3,it)
3724         do j=2,1,-1
3725           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3726         enddo
3727         sigtc=sig*sigtc
3728 C Set the parameters of both Gaussian lobes of the distribution.
3729 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3730         fac=sig*sig+sigc0(it)
3731         sigcsq=fac+fac
3732         sigc=1.0D0/sigcsq
3733 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3734         sigsqtc=-4.0D0*sigcsq*sigtc
3735 c       print *,i,sig,sigtc,sigsqtc
3736 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3737         sigtc=-sigtc/(fac*fac)
3738 C Following variable is sigma(t_c)**(-2)
3739         sigcsq=sigcsq*sigcsq
3740         sig0i=sig0(it)
3741         sig0inv=1.0D0/sig0i**2
3742         delthec=thetai-thet_pred_mean
3743         delthe0=thetai-theta0i
3744         term1=-0.5D0*sigcsq*delthec*delthec
3745         term2=-0.5D0*sig0inv*delthe0*delthe0
3746 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3747 C NaNs in taking the logarithm. We extract the largest exponent which is added
3748 C to the energy (this being the log of the distribution) at the end of energy
3749 C term evaluation for this virtual-bond angle.
3750         if (term1.gt.term2) then
3751           termm=term1
3752           term2=dexp(term2-termm)
3753           term1=1.0d0
3754         else
3755           termm=term2
3756           term1=dexp(term1-termm)
3757           term2=1.0d0
3758         endif
3759 C The ratio between the gamma-independent and gamma-dependent lobes of
3760 C the distribution is a Gaussian function of thet_pred_mean too.
3761         diffak=gthet(2,it)-thet_pred_mean
3762         ratak=diffak/gthet(3,it)**2
3763         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3764 C Let's differentiate it in thet_pred_mean NOW.
3765         aktc=ak*ratak
3766 C Now put together the distribution terms to make complete distribution.
3767         termexp=term1+ak*term2
3768         termpre=sigc+ak*sig0i
3769 C Contribution of the bending energy from this theta is just the -log of
3770 C the sum of the contributions from the two lobes and the pre-exponential
3771 C factor. Simple enough, isn't it?
3772         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3773 C NOW the derivatives!!!
3774 C 6/6/97 Take into account the deformation.
3775         E_theta=(delthec*sigcsq*term1
3776      &       +ak*delthe0*sig0inv*term2)/termexp
3777         E_tc=((sigtc+aktc*sig0i)/termpre
3778      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3779      &       aktc*term2)/termexp)
3780       return
3781       end
3782 c-----------------------------------------------------------------------------
3783       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3784       implicit real*8 (a-h,o-z)
3785       include 'DIMENSIONS'
3786       include 'COMMON.LOCAL'
3787       include 'COMMON.IOUNITS'
3788       common /calcthet/ term1,term2,termm,diffak,ratak,
3789      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3790      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3791       delthec=thetai-thet_pred_mean
3792       delthe0=thetai-theta0i
3793 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3794       t3 = thetai-thet_pred_mean
3795       t6 = t3**2
3796       t9 = term1
3797       t12 = t3*sigcsq
3798       t14 = t12+t6*sigsqtc
3799       t16 = 1.0d0
3800       t21 = thetai-theta0i
3801       t23 = t21**2
3802       t26 = term2
3803       t27 = t21*t26
3804       t32 = termexp
3805       t40 = t32**2
3806       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3807      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3808      & *(-t12*t9-ak*sig0inv*t27)
3809       return
3810       end
3811 #else
3812 C--------------------------------------------------------------------------
3813       subroutine ebend(etheta)
3814 C
3815 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3816 C angles gamma and its derivatives in consecutive thetas and gammas.
3817 C ab initio-derived potentials from
3818 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3819 C
3820       implicit real*8 (a-h,o-z)
3821       include 'DIMENSIONS'
3822       include 'COMMON.LOCAL'
3823       include 'COMMON.GEO'
3824       include 'COMMON.INTERACT'
3825       include 'COMMON.DERIV'
3826       include 'COMMON.VAR'
3827       include 'COMMON.CHAIN'
3828       include 'COMMON.IOUNITS'
3829       include 'COMMON.NAMES'
3830       include 'COMMON.FFIELD'
3831       include 'COMMON.CONTROL'
3832       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3833      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3834      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3835      & sinph1ph2(maxdouble,maxdouble)
3836       logical lprn /.false./, lprn1 /.false./
3837       etheta=0.0D0
3838       do i=ithet_start,ithet_end
3839         dethetai=0.0d0
3840         dephii=0.0d0
3841         dephii1=0.0d0
3842         theti2=0.5d0*theta(i)
3843         ityp2=ithetyp(itype(i-1))
3844         do k=1,nntheterm
3845           coskt(k)=dcos(k*theti2)
3846           sinkt(k)=dsin(k*theti2)
3847         enddo
3848         if (i.gt.3) then
3849 #ifdef OSF
3850           phii=phi(i)
3851           if (phii.ne.phii) phii=150.0
3852 #else
3853           phii=phi(i)
3854 #endif
3855           ityp1=ithetyp(itype(i-2))
3856           do k=1,nsingle
3857             cosph1(k)=dcos(k*phii)
3858             sinph1(k)=dsin(k*phii)
3859           enddo
3860         else
3861           phii=0.0d0
3862           ityp1=nthetyp+1
3863           do k=1,nsingle
3864             cosph1(k)=0.0d0
3865             sinph1(k)=0.0d0
3866           enddo
3867         endif
3868         if (i.lt.nres) then
3869 #ifdef OSF
3870           phii1=phi(i+1)
3871           if (phii1.ne.phii1) phii1=150.0
3872           phii1=pinorm(phii1)
3873 #else
3874           phii1=phi(i+1)
3875 #endif
3876           ityp3=ithetyp(itype(i))
3877           do k=1,nsingle
3878             cosph2(k)=dcos(k*phii1)
3879             sinph2(k)=dsin(k*phii1)
3880           enddo
3881         else
3882           phii1=0.0d0
3883           ityp3=nthetyp+1
3884           do k=1,nsingle
3885             cosph2(k)=0.0d0
3886             sinph2(k)=0.0d0
3887           enddo
3888         endif
3889         ethetai=aa0thet(ityp1,ityp2,ityp3)
3890         do k=1,ndouble
3891           do l=1,k-1
3892             ccl=cosph1(l)*cosph2(k-l)
3893             ssl=sinph1(l)*sinph2(k-l)
3894             scl=sinph1(l)*cosph2(k-l)
3895             csl=cosph1(l)*sinph2(k-l)
3896             cosph1ph2(l,k)=ccl-ssl
3897             cosph1ph2(k,l)=ccl+ssl
3898             sinph1ph2(l,k)=scl+csl
3899             sinph1ph2(k,l)=scl-csl
3900           enddo
3901         enddo
3902         if (lprn) then
3903         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3904      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3905         write (iout,*) "coskt and sinkt"
3906         do k=1,nntheterm
3907           write (iout,*) k,coskt(k),sinkt(k)
3908         enddo
3909         endif
3910         do k=1,ntheterm
3911           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
3912           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
3913      &      *coskt(k)
3914           if (lprn)
3915      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
3916      &     " ethetai",ethetai
3917         enddo
3918         if (lprn) then
3919         write (iout,*) "cosph and sinph"
3920         do k=1,nsingle
3921           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3922         enddo
3923         write (iout,*) "cosph1ph2 and sinph2ph2"
3924         do k=2,ndouble
3925           do l=1,k-1
3926             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3927      &         sinph1ph2(l,k),sinph1ph2(k,l)
3928           enddo
3929         enddo
3930         write(iout,*) "ethetai",ethetai
3931         endif
3932         do m=1,ntheterm2
3933           do k=1,nsingle
3934             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
3935      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
3936      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
3937      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
3938             ethetai=ethetai+sinkt(m)*aux
3939             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3940             dephii=dephii+k*sinkt(m)*(
3941      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
3942      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
3943             dephii1=dephii1+k*sinkt(m)*(
3944      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
3945      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
3946             if (lprn)
3947      &      write (iout,*) "m",m," k",k," bbthet",
3948      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
3949      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
3950      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
3951      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3952           enddo
3953         enddo
3954         if (lprn)
3955      &  write(iout,*) "ethetai",ethetai
3956         do m=1,ntheterm3
3957           do k=2,ndouble
3958             do l=1,k-1
3959               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3960      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
3961      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3962      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
3963               ethetai=ethetai+sinkt(m)*aux
3964               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3965               dephii=dephii+l*sinkt(m)*(
3966      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
3967      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3968      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3969      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3970               dephii1=dephii1+(k-l)*sinkt(m)*(
3971      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3972      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3973      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
3974      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3975               if (lprn) then
3976               write (iout,*) "m",m," k",k," l",l," ffthet",
3977      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
3978      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
3979      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
3980      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3981               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3982      &            cosph1ph2(k,l)*sinkt(m),
3983      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3984               endif
3985             enddo
3986           enddo
3987         enddo
3988 10      continue
3989         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3990      &   i,theta(i)*rad2deg,phii*rad2deg,
3991      &   phii1*rad2deg,ethetai
3992         etheta=etheta+ethetai
3993         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3994         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3995         gloc(nphi+i-2,icg)=wang*dethetai
3996       enddo
3997       return
3998       end
3999 #endif
4000 #ifdef CRYST_SC
4001 c-----------------------------------------------------------------------------
4002       subroutine esc(escloc)
4003 C Calculate the local energy of a side chain and its derivatives in the
4004 C corresponding virtual-bond valence angles THETA and the spherical angles
4005 C ALPHA and OMEGA.
4006       implicit real*8 (a-h,o-z)
4007       include 'DIMENSIONS'
4008       include 'COMMON.GEO'
4009       include 'COMMON.LOCAL'
4010       include 'COMMON.VAR'
4011       include 'COMMON.INTERACT'
4012       include 'COMMON.DERIV'
4013       include 'COMMON.CHAIN'
4014       include 'COMMON.IOUNITS'
4015       include 'COMMON.NAMES'
4016       include 'COMMON.FFIELD'
4017       include 'COMMON.CONTROL'
4018       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4019      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4020       common /sccalc/ time11,time12,time112,theti,it,nlobit
4021       delta=0.02d0*pi
4022       escloc=0.0D0
4023 c     write (iout,'(a)') 'ESC'
4024       do i=loc_start,loc_end
4025         it=itype(i)
4026         if (it.eq.10) goto 1
4027         nlobit=nlob(it)
4028 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4029 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4030         theti=theta(i+1)-pipol
4031         x(1)=dtan(theti)
4032         x(2)=alph(i)
4033         x(3)=omeg(i)
4034
4035         if (x(2).gt.pi-delta) then
4036           xtemp(1)=x(1)
4037           xtemp(2)=pi-delta
4038           xtemp(3)=x(3)
4039           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4040           xtemp(2)=pi
4041           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4042           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4043      &        escloci,dersc(2))
4044           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4045      &        ddersc0(1),dersc(1))
4046           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4047      &        ddersc0(3),dersc(3))
4048           xtemp(2)=pi-delta
4049           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4050           xtemp(2)=pi
4051           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4052           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4053      &            dersc0(2),esclocbi,dersc02)
4054           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4055      &            dersc12,dersc01)
4056           call splinthet(x(2),0.5d0*delta,ss,ssd)
4057           dersc0(1)=dersc01
4058           dersc0(2)=dersc02
4059           dersc0(3)=0.0d0
4060           do k=1,3
4061             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4062           enddo
4063           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4064 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4065 c    &             esclocbi,ss,ssd
4066           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4067 c         escloci=esclocbi
4068 c         write (iout,*) escloci
4069         else if (x(2).lt.delta) then
4070           xtemp(1)=x(1)
4071           xtemp(2)=delta
4072           xtemp(3)=x(3)
4073           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4074           xtemp(2)=0.0d0
4075           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4076           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4077      &        escloci,dersc(2))
4078           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4079      &        ddersc0(1),dersc(1))
4080           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4081      &        ddersc0(3),dersc(3))
4082           xtemp(2)=delta
4083           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4084           xtemp(2)=0.0d0
4085           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4086           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4087      &            dersc0(2),esclocbi,dersc02)
4088           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4089      &            dersc12,dersc01)
4090           dersc0(1)=dersc01
4091           dersc0(2)=dersc02
4092           dersc0(3)=0.0d0
4093           call splinthet(x(2),0.5d0*delta,ss,ssd)
4094           do k=1,3
4095             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4096           enddo
4097           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4098 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4099 c    &             esclocbi,ss,ssd
4100           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4101 c         write (iout,*) escloci
4102         else
4103           call enesc(x,escloci,dersc,ddummy,.false.)
4104         endif
4105
4106         escloc=escloc+escloci
4107         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4108      &     'escloc',i,escloci
4109 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4110
4111         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4112      &   wscloc*dersc(1)
4113         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4114         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4115     1   continue
4116       enddo
4117       return
4118       end
4119 C---------------------------------------------------------------------------
4120       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4121       implicit real*8 (a-h,o-z)
4122       include 'DIMENSIONS'
4123       include 'COMMON.GEO'
4124       include 'COMMON.LOCAL'
4125       include 'COMMON.IOUNITS'
4126       common /sccalc/ time11,time12,time112,theti,it,nlobit
4127       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4128       double precision contr(maxlob,-1:1)
4129       logical mixed
4130 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4131         escloc_i=0.0D0
4132         do j=1,3
4133           dersc(j)=0.0D0
4134           if (mixed) ddersc(j)=0.0d0
4135         enddo
4136         x3=x(3)
4137
4138 C Because of periodicity of the dependence of the SC energy in omega we have
4139 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4140 C To avoid underflows, first compute & store the exponents.
4141
4142         do iii=-1,1
4143
4144           x(3)=x3+iii*dwapi
4145
4146           do j=1,nlobit
4147             do k=1,3
4148               z(k)=x(k)-censc(k,j,it)
4149             enddo
4150             do k=1,3
4151               Axk=0.0D0
4152               do l=1,3
4153                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4154               enddo
4155               Ax(k,j,iii)=Axk
4156             enddo
4157             expfac=0.0D0
4158             do k=1,3
4159               expfac=expfac+Ax(k,j,iii)*z(k)
4160             enddo
4161             contr(j,iii)=expfac
4162           enddo ! j
4163
4164         enddo ! iii
4165
4166         x(3)=x3
4167 C As in the case of ebend, we want to avoid underflows in exponentiation and
4168 C subsequent NaNs and INFs in energy calculation.
4169 C Find the largest exponent
4170         emin=contr(1,-1)
4171         do iii=-1,1
4172           do j=1,nlobit
4173             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4174           enddo
4175         enddo
4176         emin=0.5D0*emin
4177 cd      print *,'it=',it,' emin=',emin
4178
4179 C Compute the contribution to SC energy and derivatives
4180         do iii=-1,1
4181
4182           do j=1,nlobit
4183 #ifdef OSF
4184             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4185             if(adexp.ne.adexp) adexp=1.0
4186             expfac=dexp(adexp)
4187 #else
4188             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4189 #endif
4190 cd          print *,'j=',j,' expfac=',expfac
4191             escloc_i=escloc_i+expfac
4192             do k=1,3
4193               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4194             enddo
4195             if (mixed) then
4196               do k=1,3,2
4197                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4198      &            +gaussc(k,2,j,it))*expfac
4199               enddo
4200             endif
4201           enddo
4202
4203         enddo ! iii
4204
4205         dersc(1)=dersc(1)/cos(theti)**2
4206         ddersc(1)=ddersc(1)/cos(theti)**2
4207         ddersc(3)=ddersc(3)
4208
4209         escloci=-(dlog(escloc_i)-emin)
4210         do j=1,3
4211           dersc(j)=dersc(j)/escloc_i
4212         enddo
4213         if (mixed) then
4214           do j=1,3,2
4215             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4216           enddo
4217         endif
4218       return
4219       end
4220 C------------------------------------------------------------------------------
4221       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4222       implicit real*8 (a-h,o-z)
4223       include 'DIMENSIONS'
4224       include 'COMMON.GEO'
4225       include 'COMMON.LOCAL'
4226       include 'COMMON.IOUNITS'
4227       common /sccalc/ time11,time12,time112,theti,it,nlobit
4228       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4229       double precision contr(maxlob)
4230       logical mixed
4231
4232       escloc_i=0.0D0
4233
4234       do j=1,3
4235         dersc(j)=0.0D0
4236       enddo
4237
4238       do j=1,nlobit
4239         do k=1,2
4240           z(k)=x(k)-censc(k,j,it)
4241         enddo
4242         z(3)=dwapi
4243         do k=1,3
4244           Axk=0.0D0
4245           do l=1,3
4246             Axk=Axk+gaussc(l,k,j,it)*z(l)
4247           enddo
4248           Ax(k,j)=Axk
4249         enddo
4250         expfac=0.0D0
4251         do k=1,3
4252           expfac=expfac+Ax(k,j)*z(k)
4253         enddo
4254         contr(j)=expfac
4255       enddo ! j
4256
4257 C As in the case of ebend, we want to avoid underflows in exponentiation and
4258 C subsequent NaNs and INFs in energy calculation.
4259 C Find the largest exponent
4260       emin=contr(1)
4261       do j=1,nlobit
4262         if (emin.gt.contr(j)) emin=contr(j)
4263       enddo
4264       emin=0.5D0*emin
4265
4266 C Compute the contribution to SC energy and derivatives
4267
4268       dersc12=0.0d0
4269       do j=1,nlobit
4270         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4271         escloc_i=escloc_i+expfac
4272         do k=1,2
4273           dersc(k)=dersc(k)+Ax(k,j)*expfac
4274         enddo
4275         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4276      &            +gaussc(1,2,j,it))*expfac
4277         dersc(3)=0.0d0
4278       enddo
4279
4280       dersc(1)=dersc(1)/cos(theti)**2
4281       dersc12=dersc12/cos(theti)**2
4282       escloci=-(dlog(escloc_i)-emin)
4283       do j=1,2
4284         dersc(j)=dersc(j)/escloc_i
4285       enddo
4286       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4287       return
4288       end
4289 #else
4290 c----------------------------------------------------------------------------------
4291       subroutine esc(escloc)
4292 C Calculate the local energy of a side chain and its derivatives in the
4293 C corresponding virtual-bond valence angles THETA and the spherical angles
4294 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4295 C added by Urszula Kozlowska. 07/11/2007
4296 C
4297       implicit real*8 (a-h,o-z)
4298       include 'DIMENSIONS'
4299       include 'COMMON.GEO'
4300       include 'COMMON.LOCAL'
4301       include 'COMMON.VAR'
4302       include 'COMMON.SCROT'
4303       include 'COMMON.INTERACT'
4304       include 'COMMON.DERIV'
4305       include 'COMMON.CHAIN'
4306       include 'COMMON.IOUNITS'
4307       include 'COMMON.NAMES'
4308       include 'COMMON.FFIELD'
4309       include 'COMMON.CONTROL'
4310       include 'COMMON.VECTORS'
4311       double precision x_prime(3),y_prime(3),z_prime(3)
4312      &    , sumene,dsc_i,dp2_i,x(65),
4313      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4314      &    de_dxx,de_dyy,de_dzz,de_dt
4315       double precision s1_t,s1_6_t,s2_t,s2_6_t
4316       double precision
4317      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4318      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4319      & dt_dCi(3),dt_dCi1(3)
4320       common /sccalc/ time11,time12,time112,theti,it,nlobit
4321       delta=0.02d0*pi
4322       escloc=0.0D0
4323       do i=loc_start,loc_end
4324         costtab(i+1) =dcos(theta(i+1))
4325         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4326         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4327         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4328         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4329         cosfac=dsqrt(cosfac2)
4330         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4331         sinfac=dsqrt(sinfac2)
4332         it=itype(i)
4333         if (it.eq.10) goto 1
4334 c
4335 C  Compute the axes of tghe local cartesian coordinates system; store in
4336 c   x_prime, y_prime and z_prime
4337 c
4338         do j=1,3
4339           x_prime(j) = 0.00
4340           y_prime(j) = 0.00
4341           z_prime(j) = 0.00
4342         enddo
4343 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4344 C     &   dc_norm(3,i+nres)
4345         do j = 1,3
4346           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4347           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4348         enddo
4349         do j = 1,3
4350           z_prime(j) = -uz(j,i-1)
4351         enddo
4352 c       write (2,*) "i",i
4353 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4354 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4355 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4356 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4357 c      & " xy",scalar(x_prime(1),y_prime(1)),
4358 c      & " xz",scalar(x_prime(1),z_prime(1)),
4359 c      & " yy",scalar(y_prime(1),y_prime(1)),
4360 c      & " yz",scalar(y_prime(1),z_prime(1)),
4361 c      & " zz",scalar(z_prime(1),z_prime(1))
4362 c
4363 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4364 C to local coordinate system. Store in xx, yy, zz.
4365 c
4366         xx=0.0d0
4367         yy=0.0d0
4368         zz=0.0d0
4369         do j = 1,3
4370           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4371           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4372           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4373         enddo
4374
4375         xxtab(i)=xx
4376         yytab(i)=yy
4377         zztab(i)=zz
4378 C
4379 C Compute the energy of the ith side cbain
4380 C
4381 c        write (2,*) "xx",xx," yy",yy," zz",zz
4382         it=itype(i)
4383         do j = 1,65
4384           x(j) = sc_parmin(j,it)
4385         enddo
4386 #ifdef CHECK_COORD
4387 Cc diagnostics - remove later
4388         xx1 = dcos(alph(2))
4389         yy1 = dsin(alph(2))*dcos(omeg(2))
4390         zz1 = -dsin(alph(2))*dsin(omeg(2))
4391         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4392      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4393      &    xx1,yy1,zz1
4394 C,"  --- ", xx_w,yy_w,zz_w
4395 c end diagnostics
4396 #endif
4397         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4398      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4399      &   + x(10)*yy*zz
4400         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4401      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4402      & + x(20)*yy*zz
4403         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4404      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4405      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4406      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4407      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4408      &  +x(40)*xx*yy*zz
4409         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4410      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4411      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4412      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4413      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4414      &  +x(60)*xx*yy*zz
4415         dsc_i   = 0.743d0+x(61)
4416         dp2_i   = 1.9d0+x(62)
4417         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4418      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4419         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4420      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4421         s1=(1+x(63))/(0.1d0 + dscp1)
4422         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4423         s2=(1+x(65))/(0.1d0 + dscp2)
4424         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4425         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4426      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4427 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4428 c     &   sumene4,
4429 c     &   dscp1,dscp2,sumene
4430 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4431         escloc = escloc + sumene
4432 c        write (2,*) "i",i," escloc",sumene,escloc
4433 #ifdef DEBUG
4434 C
4435 C This section to check the numerical derivatives of the energy of ith side
4436 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4437 C #define DEBUG in the code to turn it on.
4438 C
4439         write (2,*) "sumene               =",sumene
4440         aincr=1.0d-7
4441         xxsave=xx
4442         xx=xx+aincr
4443         write (2,*) xx,yy,zz
4444         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4445         de_dxx_num=(sumenep-sumene)/aincr
4446         xx=xxsave
4447         write (2,*) "xx+ sumene from enesc=",sumenep
4448         yysave=yy
4449         yy=yy+aincr
4450         write (2,*) xx,yy,zz
4451         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4452         de_dyy_num=(sumenep-sumene)/aincr
4453         yy=yysave
4454         write (2,*) "yy+ sumene from enesc=",sumenep
4455         zzsave=zz
4456         zz=zz+aincr
4457         write (2,*) xx,yy,zz
4458         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4459         de_dzz_num=(sumenep-sumene)/aincr
4460         zz=zzsave
4461         write (2,*) "zz+ sumene from enesc=",sumenep
4462         costsave=cost2tab(i+1)
4463         sintsave=sint2tab(i+1)
4464         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4465         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4466         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4467         de_dt_num=(sumenep-sumene)/aincr
4468         write (2,*) " t+ sumene from enesc=",sumenep
4469         cost2tab(i+1)=costsave
4470         sint2tab(i+1)=sintsave
4471 C End of diagnostics section.
4472 #endif
4473 C
4474 C Compute the gradient of esc
4475 C
4476         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4477         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4478         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4479         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4480         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4481         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4482         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4483         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4484         pom1=(sumene3*sint2tab(i+1)+sumene1)
4485      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4486         pom2=(sumene4*cost2tab(i+1)+sumene2)
4487      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4488         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4489         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4490      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4491      &  +x(40)*yy*zz
4492         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4493         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4494      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4495      &  +x(60)*yy*zz
4496         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4497      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4498      &        +(pom1+pom2)*pom_dx
4499 #ifdef DEBUG
4500         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4501 #endif
4502 C
4503         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4504         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4505      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4506      &  +x(40)*xx*zz
4507         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4508         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4509      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4510      &  +x(59)*zz**2 +x(60)*xx*zz
4511         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4512      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4513      &        +(pom1-pom2)*pom_dy
4514 #ifdef DEBUG
4515         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4516 #endif
4517 C
4518         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4519      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4520      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4521      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4522      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4523      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4524      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4525      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4526 #ifdef DEBUG
4527         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4528 #endif
4529 C
4530         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4531      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4532      &  +pom1*pom_dt1+pom2*pom_dt2
4533 #ifdef DEBUG
4534         write(2,*), "de_dt = ", de_dt,de_dt_num
4535 #endif
4536 c
4537 C
4538        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4539        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4540        cosfac2xx=cosfac2*xx
4541        sinfac2yy=sinfac2*yy
4542        do k = 1,3
4543          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4544      &      vbld_inv(i+1)
4545          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4546      &      vbld_inv(i)
4547          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4548          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4549 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4550 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4551 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4552 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4553          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4554          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4555          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4556          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4557          dZZ_Ci1(k)=0.0d0
4558          dZZ_Ci(k)=0.0d0
4559          do j=1,3
4560            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4561            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4562          enddo
4563
4564          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4565          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4566          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4567 c
4568          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4569          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4570        enddo
4571
4572        do k=1,3
4573          dXX_Ctab(k,i)=dXX_Ci(k)
4574          dXX_C1tab(k,i)=dXX_Ci1(k)
4575          dYY_Ctab(k,i)=dYY_Ci(k)
4576          dYY_C1tab(k,i)=dYY_Ci1(k)
4577          dZZ_Ctab(k,i)=dZZ_Ci(k)
4578          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4579          dXX_XYZtab(k,i)=dXX_XYZ(k)
4580          dYY_XYZtab(k,i)=dYY_XYZ(k)
4581          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4582        enddo
4583
4584        do k = 1,3
4585 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4586 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4587 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4588 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4589 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4590 c     &    dt_dci(k)
4591 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4592 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4593          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4594      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4595          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4596      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4597          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4598      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4599        enddo
4600 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4601 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4602
4603 C to check gradient call subroutine check_grad
4604
4605     1 continue
4606       enddo
4607       return
4608       end
4609 c------------------------------------------------------------------------------
4610       double precision function enesc(x,xx,yy,zz,cost2,sint2)
4611       implicit none
4612       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
4613      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
4614       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4615      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4616      &   + x(10)*yy*zz
4617       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4618      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4619      & + x(20)*yy*zz
4620       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4621      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4622      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4623      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4624      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4625      &  +x(40)*xx*yy*zz
4626       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4627      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4628      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4629      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4630      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4631      &  +x(60)*xx*yy*zz
4632       dsc_i   = 0.743d0+x(61)
4633       dp2_i   = 1.9d0+x(62)
4634       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4635      &          *(xx*cost2+yy*sint2))
4636       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4637      &          *(xx*cost2-yy*sint2))
4638       s1=(1+x(63))/(0.1d0 + dscp1)
4639       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4640       s2=(1+x(65))/(0.1d0 + dscp2)
4641       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4642       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
4643      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
4644       enesc=sumene
4645       return
4646       end
4647 #endif
4648 c------------------------------------------------------------------------------
4649       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4650 C
4651 C This procedure calculates two-body contact function g(rij) and its derivative:
4652 C
4653 C           eps0ij                                     !       x < -1
4654 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4655 C            0                                         !       x > 1
4656 C
4657 C where x=(rij-r0ij)/delta
4658 C
4659 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4660 C
4661       implicit none
4662       double precision rij,r0ij,eps0ij,fcont,fprimcont
4663       double precision x,x2,x4,delta
4664 c     delta=0.02D0*r0ij
4665 c      delta=0.2D0*r0ij
4666       x=(rij-r0ij)/delta
4667       if (x.lt.-1.0D0) then
4668         fcont=eps0ij
4669         fprimcont=0.0D0
4670       else if (x.le.1.0D0) then
4671         x2=x*x
4672         x4=x2*x2
4673         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4674         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4675       else
4676         fcont=0.0D0
4677         fprimcont=0.0D0
4678       endif
4679       return
4680       end
4681 c------------------------------------------------------------------------------
4682       subroutine splinthet(theti,delta,ss,ssder)
4683       implicit real*8 (a-h,o-z)
4684       include 'DIMENSIONS'
4685       include 'COMMON.VAR'
4686       include 'COMMON.GEO'
4687       thetup=pi-delta
4688       thetlow=delta
4689       if (theti.gt.pipol) then
4690         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4691       else
4692         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4693         ssder=-ssder
4694       endif
4695       return
4696       end
4697 c------------------------------------------------------------------------------
4698       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4699       implicit none
4700       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4701       double precision ksi,ksi2,ksi3,a1,a2,a3
4702       a1=fprim0*delta/(f1-f0)
4703       a2=3.0d0-2.0d0*a1
4704       a3=a1-2.0d0
4705       ksi=(x-x0)/delta
4706       ksi2=ksi*ksi
4707       ksi3=ksi2*ksi
4708       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4709       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4710       return
4711       end
4712 c------------------------------------------------------------------------------
4713       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4714       implicit none
4715       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4716       double precision ksi,ksi2,ksi3,a1,a2,a3
4717       ksi=(x-x0)/delta
4718       ksi2=ksi*ksi
4719       ksi3=ksi2*ksi
4720       a1=fprim0x*delta
4721       a2=3*(f1x-f0x)-2*fprim0x*delta
4722       a3=fprim0x*delta-2*(f1x-f0x)
4723       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4724       return
4725       end
4726 C-----------------------------------------------------------------------------
4727 #ifdef CRYST_TOR
4728 C-----------------------------------------------------------------------------
4729       subroutine etor(etors,edihcnstr)
4730       implicit real*8 (a-h,o-z)
4731       include 'DIMENSIONS'
4732       include 'COMMON.VAR'
4733       include 'COMMON.GEO'
4734       include 'COMMON.LOCAL'
4735       include 'COMMON.TORSION'
4736       include 'COMMON.INTERACT'
4737       include 'COMMON.DERIV'
4738       include 'COMMON.CHAIN'
4739       include 'COMMON.NAMES'
4740       include 'COMMON.IOUNITS'
4741       include 'COMMON.FFIELD'
4742       include 'COMMON.TORCNSTR'
4743       include 'COMMON.CONTROL'
4744       logical lprn
4745 C Set lprn=.true. for debugging
4746       lprn=.false.
4747 c      lprn=.true.
4748       etors=0.0D0
4749       do i=iphi_start,iphi_end
4750       etors_ii=0.0D0
4751         itori=itortyp(itype(i-2))
4752         itori1=itortyp(itype(i-1))
4753         phii=phi(i)
4754         gloci=0.0D0
4755 C Proline-Proline pair is a special case...
4756         if (itori.eq.3 .and. itori1.eq.3) then
4757           if (phii.gt.-dwapi3) then
4758             cosphi=dcos(3*phii)
4759             fac=1.0D0/(1.0D0-cosphi)
4760             etorsi=v1(1,3,3)*fac
4761             etorsi=etorsi+etorsi
4762             etors=etors+etorsi-v1(1,3,3)
4763             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
4764             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4765           endif
4766           do j=1,3
4767             v1ij=v1(j+1,itori,itori1)
4768             v2ij=v2(j+1,itori,itori1)
4769             cosphi=dcos(j*phii)
4770             sinphi=dsin(j*phii)
4771             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4772             if (energy_dec) etors_ii=etors_ii+
4773      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4774             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4775           enddo
4776         else
4777           do j=1,nterm_old
4778             v1ij=v1(j,itori,itori1)
4779             v2ij=v2(j,itori,itori1)
4780             cosphi=dcos(j*phii)
4781             sinphi=dsin(j*phii)
4782             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4783             if (energy_dec) etors_ii=etors_ii+
4784      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4785             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4786           enddo
4787         endif
4788         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4789              'etor',i,etors_ii
4790         if (lprn)
4791      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4792      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4793      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4794         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
4795 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4796       enddo
4797 ! 6/20/98 - dihedral angle constraints
4798       edihcnstr=0.0d0
4799       do i=1,ndih_constr
4800         itori=idih_constr(i)
4801         phii=phi(itori)
4802         difi=phii-phi0(i)
4803         if (difi.gt.drange(i)) then
4804           difi=difi-drange(i)
4805           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4806           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4807         else if (difi.lt.-drange(i)) then
4808           difi=difi+drange(i)
4809           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4810           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4811         endif
4812 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4813 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4814       enddo
4815 !      write (iout,*) 'edihcnstr',edihcnstr
4816       return
4817       end
4818 c------------------------------------------------------------------------------
4819       subroutine etor_d(etors_d)
4820       etors_d=0.0d0
4821       return
4822       end
4823 c----------------------------------------------------------------------------
4824 #else
4825       subroutine etor(etors,edihcnstr)
4826       implicit real*8 (a-h,o-z)
4827       include 'DIMENSIONS'
4828       include 'COMMON.VAR'
4829       include 'COMMON.GEO'
4830       include 'COMMON.LOCAL'
4831       include 'COMMON.TORSION'
4832       include 'COMMON.INTERACT'
4833       include 'COMMON.DERIV'
4834       include 'COMMON.CHAIN'
4835       include 'COMMON.NAMES'
4836       include 'COMMON.IOUNITS'
4837       include 'COMMON.FFIELD'
4838       include 'COMMON.TORCNSTR'
4839       include 'COMMON.CONTROL'
4840       logical lprn
4841 C Set lprn=.true. for debugging
4842       lprn=.false.
4843 c     lprn=.true.
4844       etors=0.0D0
4845       do i=iphi_start,iphi_end
4846       etors_ii=0.0D0
4847         itori=itortyp(itype(i-2))
4848         itori1=itortyp(itype(i-1))
4849         phii=phi(i)
4850         gloci=0.0D0
4851 C Regular cosine and sine terms
4852         do j=1,nterm(itori,itori1)
4853           v1ij=v1(j,itori,itori1)
4854           v2ij=v2(j,itori,itori1)
4855           cosphi=dcos(j*phii)
4856           sinphi=dsin(j*phii)
4857           etors=etors+v1ij*cosphi+v2ij*sinphi
4858           if (energy_dec) etors_ii=etors_ii+
4859      &                v1ij*cosphi+v2ij*sinphi
4860           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4861         enddo
4862 C Lorentz terms
4863 C                         v1
4864 C  E = SUM ----------------------------------- - v1
4865 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4866 C
4867         cosphi=dcos(0.5d0*phii)
4868         sinphi=dsin(0.5d0*phii)
4869         do j=1,nlor(itori,itori1)
4870           vl1ij=vlor1(j,itori,itori1)
4871           vl2ij=vlor2(j,itori,itori1)
4872           vl3ij=vlor3(j,itori,itori1)
4873           pom=vl2ij*cosphi+vl3ij*sinphi
4874           pom1=1.0d0/(pom*pom+1.0d0)
4875           etors=etors+vl1ij*pom1
4876           if (energy_dec) etors_ii=etors_ii+
4877      &                vl1ij*pom1
4878           pom=-pom*pom1*pom1
4879           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4880         enddo
4881 C Subtract the constant term
4882         etors=etors-v0(itori,itori1)
4883           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4884      &         'etor',i,etors_ii-v0(itori,itori1)
4885         if (lprn)
4886      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4887      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4888      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4889         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
4890 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4891       enddo
4892 ! 6/20/98 - dihedral angle constraints
4893       edihcnstr=0.0d0
4894 c      do i=1,ndih_constr
4895       do i=idihconstr_start,idihconstr_end
4896         itori=idih_constr(i)
4897         phii=phi(itori)
4898         difi=pinorm(phii-phi0(i))
4899         if (difi.gt.drange(i)) then
4900           difi=difi-drange(i)
4901           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4902           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4903         else if (difi.lt.-drange(i)) then
4904           difi=difi+drange(i)
4905           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4906           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4907         else
4908           difi=0.0
4909         endif
4910 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
4911 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
4912 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4913       enddo
4914 cd       write (iout,*) 'edihcnstr',edihcnstr
4915       return
4916       end
4917 c----------------------------------------------------------------------------
4918       subroutine etor_d(etors_d)
4919 C 6/23/01 Compute double torsional energy
4920       implicit real*8 (a-h,o-z)
4921       include 'DIMENSIONS'
4922       include 'COMMON.VAR'
4923       include 'COMMON.GEO'
4924       include 'COMMON.LOCAL'
4925       include 'COMMON.TORSION'
4926       include 'COMMON.INTERACT'
4927       include 'COMMON.DERIV'
4928       include 'COMMON.CHAIN'
4929       include 'COMMON.NAMES'
4930       include 'COMMON.IOUNITS'
4931       include 'COMMON.FFIELD'
4932       include 'COMMON.TORCNSTR'
4933       logical lprn
4934 C Set lprn=.true. for debugging
4935       lprn=.false.
4936 c     lprn=.true.
4937       etors_d=0.0D0
4938       do i=iphid_start,iphid_end
4939         itori=itortyp(itype(i-2))
4940         itori1=itortyp(itype(i-1))
4941         itori2=itortyp(itype(i))
4942         phii=phi(i)
4943         phii1=phi(i+1)
4944         gloci1=0.0D0
4945         gloci2=0.0D0
4946 C Regular cosine and sine terms
4947         do j=1,ntermd_1(itori,itori1,itori2)
4948           v1cij=v1c(1,j,itori,itori1,itori2)
4949           v1sij=v1s(1,j,itori,itori1,itori2)
4950           v2cij=v1c(2,j,itori,itori1,itori2)
4951           v2sij=v1s(2,j,itori,itori1,itori2)
4952           cosphi1=dcos(j*phii)
4953           sinphi1=dsin(j*phii)
4954           cosphi2=dcos(j*phii1)
4955           sinphi2=dsin(j*phii1)
4956           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4957      &     v2cij*cosphi2+v2sij*sinphi2
4958           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4959           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4960         enddo
4961         do k=2,ntermd_2(itori,itori1,itori2)
4962           do l=1,k-1
4963             v1cdij = v2c(k,l,itori,itori1,itori2)
4964             v2cdij = v2c(l,k,itori,itori1,itori2)
4965             v1sdij = v2s(k,l,itori,itori1,itori2)
4966             v2sdij = v2s(l,k,itori,itori1,itori2)
4967             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4968             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4969             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4970             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4971             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4972      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4973             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4974      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4975             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4976      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4977           enddo
4978         enddo
4979         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
4980         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
4981       enddo
4982       return
4983       end
4984 #endif
4985 c------------------------------------------------------------------------------
4986       subroutine eback_sc_corr(esccor)
4987 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4988 c        conformational states; temporarily implemented as differences
4989 c        between UNRES torsional potentials (dependent on three types of
4990 c        residues) and the torsional potentials dependent on all 20 types
4991 c        of residues computed from AM1  energy surfaces of terminally-blocked
4992 c        amino-acid residues.
4993       implicit real*8 (a-h,o-z)
4994       include 'DIMENSIONS'
4995       include 'COMMON.VAR'
4996       include 'COMMON.GEO'
4997       include 'COMMON.LOCAL'
4998       include 'COMMON.TORSION'
4999       include 'COMMON.SCCOR'
5000       include 'COMMON.INTERACT'
5001       include 'COMMON.DERIV'
5002       include 'COMMON.CHAIN'
5003       include 'COMMON.NAMES'
5004       include 'COMMON.IOUNITS'
5005       include 'COMMON.FFIELD'
5006       include 'COMMON.CONTROL'
5007       logical lprn
5008 C Set lprn=.true. for debugging
5009       lprn=.false.
5010 c      lprn=.true.
5011 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5012       esccor=0.0D0
5013       do i=iphi_start,iphi_end
5014         esccor_ii=0.0D0
5015         itori=itype(i-2)
5016         itori1=itype(i-1)
5017         phii=phi(i)
5018         gloci=0.0D0
5019         do j=1,nterm_sccor
5020           v1ij=v1sccor(j,itori,itori1)
5021           v2ij=v2sccor(j,itori,itori1)
5022           cosphi=dcos(j*phii)
5023           sinphi=dsin(j*phii)
5024           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5025           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5026         enddo
5027         if (lprn)
5028      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5029      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5030      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5031         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5032       enddo
5033       return
5034       end
5035 c----------------------------------------------------------------------------
5036       subroutine multibody(ecorr)
5037 C This subroutine calculates multi-body contributions to energy following
5038 C the idea of Skolnick et al. If side chains I and J make a contact and
5039 C at the same time side chains I+1 and J+1 make a contact, an extra
5040 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5041       implicit real*8 (a-h,o-z)
5042       include 'DIMENSIONS'
5043       include 'COMMON.IOUNITS'
5044       include 'COMMON.DERIV'
5045       include 'COMMON.INTERACT'
5046       include 'COMMON.CONTACTS'
5047       double precision gx(3),gx1(3)
5048       logical lprn
5049
5050 C Set lprn=.true. for debugging
5051       lprn=.false.
5052
5053       if (lprn) then
5054         write (iout,'(a)') 'Contact function values:'
5055         do i=nnt,nct-2
5056           write (iout,'(i2,20(1x,i2,f10.5))')
5057      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5058         enddo
5059       endif
5060       ecorr=0.0D0
5061       do i=nnt,nct
5062         do j=1,3
5063           gradcorr(j,i)=0.0D0
5064           gradxorr(j,i)=0.0D0
5065         enddo
5066       enddo
5067       do i=nnt,nct-2
5068
5069         DO ISHIFT = 3,4
5070
5071         i1=i+ishift
5072         num_conti=num_cont(i)
5073         num_conti1=num_cont(i1)
5074         do jj=1,num_conti
5075           j=jcont(jj,i)
5076           do kk=1,num_conti1
5077             j1=jcont(kk,i1)
5078             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5079 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5080 cd   &                   ' ishift=',ishift
5081 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5082 C The system gains extra energy.
5083               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5084             endif   ! j1==j+-ishift
5085           enddo     ! kk
5086         enddo       ! jj
5087
5088         ENDDO ! ISHIFT
5089
5090       enddo         ! i
5091       return
5092       end
5093 c------------------------------------------------------------------------------
5094       double precision function esccorr(i,j,k,l,jj,kk)
5095       implicit real*8 (a-h,o-z)
5096       include 'DIMENSIONS'
5097       include 'COMMON.IOUNITS'
5098       include 'COMMON.DERIV'
5099       include 'COMMON.INTERACT'
5100       include 'COMMON.CONTACTS'
5101       double precision gx(3),gx1(3)
5102       logical lprn
5103       lprn=.false.
5104       eij=facont(jj,i)
5105       ekl=facont(kk,k)
5106 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5107 C Calculate the multi-body contribution to energy.
5108 C Calculate multi-body contributions to the gradient.
5109 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5110 cd   & k,l,(gacont(m,kk,k),m=1,3)
5111       do m=1,3
5112         gx(m) =ekl*gacont(m,jj,i)
5113         gx1(m)=eij*gacont(m,kk,k)
5114         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5115         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5116         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5117         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5118       enddo
5119       do m=i,j-1
5120         do ll=1,3
5121           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5122         enddo
5123       enddo
5124       do m=k,l-1
5125         do ll=1,3
5126           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5127         enddo
5128       enddo
5129       esccorr=-eij*ekl
5130       return
5131       end
5132 c------------------------------------------------------------------------------
5133 #ifdef MPI
5134       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5135       implicit real*8 (a-h,o-z)
5136       include 'DIMENSIONS'
5137       integer dimen1,dimen2,atom,indx
5138       double precision buffer(dimen1,dimen2)
5139       double precision zapas
5140       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5141      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5142      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5143      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5144       num_kont=num_cont_hb(atom)
5145       do i=1,num_kont
5146         do k=1,8
5147           do j=1,3
5148             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5149           enddo ! j
5150         enddo ! k
5151         buffer(i,indx+25)=facont_hb(i,atom)
5152         buffer(i,indx+26)=ees0p(i,atom)
5153         buffer(i,indx+27)=ees0m(i,atom)
5154         buffer(i,indx+28)=d_cont(i,atom)
5155         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
5156       enddo ! i
5157       buffer(1,indx+30)=dfloat(num_kont)
5158       return
5159       end
5160 c------------------------------------------------------------------------------
5161       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5162       implicit real*8 (a-h,o-z)
5163       include 'DIMENSIONS'
5164       integer dimen1,dimen2,atom,indx
5165       double precision buffer(dimen1,dimen2)
5166       double precision zapas
5167       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5168      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5169      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5170      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5171       num_kont=buffer(1,indx+30)
5172       num_kont_old=num_cont_hb(atom)
5173       num_cont_hb(atom)=num_kont+num_kont_old
5174       do i=1,num_kont
5175         ii=i+num_kont_old
5176         do k=1,8
5177           do j=1,3
5178             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5179           enddo ! j
5180         enddo ! k
5181         facont_hb(ii,atom)=buffer(i,indx+25)
5182         ees0p(ii,atom)=buffer(i,indx+26)
5183         ees0m(ii,atom)=buffer(i,indx+27)
5184         d_cont(i,atom)=buffer(i,indx+28)
5185         jcont_hb(ii,atom)=buffer(i,indx+29)
5186       enddo ! i
5187       return
5188       end
5189 c------------------------------------------------------------------------------
5190 #endif
5191       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5192 C This subroutine calculates multi-body contributions to hydrogen-bonding
5193       implicit real*8 (a-h,o-z)
5194       include 'DIMENSIONS'
5195       include 'COMMON.IOUNITS'
5196 #ifdef MPI
5197       include "mpif.h"
5198       parameter (max_cont=maxconts)
5199       parameter (max_dim=2*(8*3+6))
5200       parameter (msglen1=max_cont*max_dim)
5201       parameter (msglen2=2*msglen1)
5202       integer source,CorrelType,CorrelID,Error
5203       double precision buffer(max_cont,max_dim)
5204       integer status(MPI_STATUS_SIZE)
5205 #endif
5206       include 'COMMON.SETUP'
5207       include 'COMMON.FFIELD'
5208       include 'COMMON.DERIV'
5209       include 'COMMON.INTERACT'
5210       include 'COMMON.CONTACTS'
5211       include 'COMMON.CONTROL'
5212       double precision gx(3),gx1(3),time00
5213       logical lprn,ldone
5214
5215 C Set lprn=.true. for debugging
5216       lprn=.false.
5217 #ifdef MPI
5218       n_corr=0
5219       n_corr1=0
5220       if (nfgtasks.le.1) goto 30
5221       if (lprn) then
5222         write (iout,'(a)') 'Contact function values:'
5223         do i=nnt,nct-2
5224           write (iout,'(2i3,50(1x,i2,f5.2))')
5225      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5226      &    j=1,num_cont_hb(i))
5227         enddo
5228       endif
5229 C Caution! Following code assumes that electrostatic interactions concerning
5230 C a given atom are split among at most two processors!
5231       CorrelType=477
5232       CorrelID=fg_rank+1
5233       ldone=.false.
5234       do i=1,max_cont
5235         do j=1,max_dim
5236           buffer(i,j)=0.0D0
5237         enddo
5238       enddo
5239       mm=mod(fg_rank,2)
5240 c      write (*,*) 'MyRank',MyRank,' mm',mm
5241       if (mm) 20,20,10
5242    10 continue
5243 c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5244       if (fg_rank.gt.0) then
5245 C Send correlation contributions to the preceding processor
5246         msglen=msglen1
5247         nn=num_cont_hb(iatel_s)
5248         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5249 c        write (*,*) 'The BUFFER array:'
5250 c        do i=1,nn
5251 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5252 c        enddo
5253         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5254           msglen=msglen2
5255           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5256 C Clear the contacts of the atom passed to the neighboring processor
5257         nn=num_cont_hb(iatel_s+1)
5258 c        do i=1,nn
5259 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5260 c        enddo
5261             num_cont_hb(iatel_s)=0
5262         endif
5263 cd      write (iout,*) 'Processor ',fg_rank,MyRank,
5264 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5265 cd   & ' msglen=',msglen
5266 c        write (*,*) 'Processor ',fg_rank,MyRank,
5267 c     & ' is sending correlation contribution to processor',fg_rank-1,
5268 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5269         time00=MPI_Wtime()
5270         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5271      &    CorrelType,FG_COMM,IERROR)
5272         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5273 cd      write (iout,*) 'Processor ',fg_rank,
5274 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5275 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5276 c        write (*,*) 'Processor ',fg_rank,
5277 c     & ' has sent correlation contribution to processor',fg_rank-1,
5278 c     & ' msglen=',msglen,' CorrelID=',CorrelID
5279 c        msglen=msglen1
5280       endif ! (fg_rank.gt.0)
5281       if (ldone) goto 30
5282       ldone=.true.
5283    20 continue
5284 c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5285       if (fg_rank.lt.nfgtasks-1) then
5286 C Receive correlation contributions from the next processor
5287         msglen=msglen1
5288         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5289 cd      write (iout,*) 'Processor',fg_rank,
5290 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5291 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5292 c        write (*,*) 'Processor',fg_rank,
5293 c     &' is receiving correlation contribution from processor',fg_rank+1,
5294 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5295         time00=MPI_Wtime()
5296         nbytes=-1
5297         do while (nbytes.le.0)
5298           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5299           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5300         enddo
5301 c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
5302         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5303      &    fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5304         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5305 c        write (*,*) 'Processor',fg_rank,
5306 c     &' has received correlation contribution from processor',fg_rank+1,
5307 c     & ' msglen=',msglen,' nbytes=',nbytes
5308 c        write (*,*) 'The received BUFFER array:'
5309 c        do i=1,max_cont
5310 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
5311 c        enddo
5312         if (msglen.eq.msglen1) then
5313           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5314         else if (msglen.eq.msglen2)  then
5315           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5316           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5317         else
5318           write (iout,*)
5319      & 'ERROR!!!! message length changed while processing correlations.'
5320           write (*,*)
5321      & 'ERROR!!!! message length changed while processing correlations.'
5322           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5323         endif ! msglen.eq.msglen1
5324       endif ! fg_rank.lt.nfgtasks-1
5325       if (ldone) goto 30
5326       ldone=.true.
5327       goto 10
5328    30 continue
5329 #endif
5330       if (lprn) then
5331         write (iout,'(a)') 'Contact function values:'
5332         do i=nnt,nct-2
5333           write (iout,'(2i3,50(1x,i2,f5.2))')
5334      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5335      &    j=1,num_cont_hb(i))
5336         enddo
5337       endif
5338       ecorr=0.0D0
5339 C Remove the loop below after debugging !!!
5340       do i=nnt,nct
5341         do j=1,3
5342           gradcorr(j,i)=0.0D0
5343           gradxorr(j,i)=0.0D0
5344         enddo
5345       enddo
5346 C Calculate the local-electrostatic correlation terms
5347       do i=iatel_s,iatel_e+1
5348         i1=i+1
5349         num_conti=num_cont_hb(i)
5350         num_conti1=num_cont_hb(i+1)
5351         do jj=1,num_conti
5352           j=jcont_hb(jj,i)
5353           do kk=1,num_conti1
5354             j1=jcont_hb(kk,i1)
5355 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5356 c     &         ' jj=',jj,' kk=',kk
5357             if (j1.eq.j+1 .or. j1.eq.j-1) then
5358 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5359 C The system gains extra energy.
5360               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5361               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5362      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5363               n_corr=n_corr+1
5364             else if (j1.eq.j) then
5365 C Contacts I-J and I-(J+1) occur simultaneously.
5366 C The system loses extra energy.
5367 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5368             endif
5369           enddo ! kk
5370           do kk=1,num_conti
5371             j1=jcont_hb(kk,i)
5372 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5373 c    &         ' jj=',jj,' kk=',kk
5374             if (j1.eq.j+1) then
5375 C Contacts I-J and (I+1)-J occur simultaneously.
5376 C The system loses extra energy.
5377 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5378             endif ! j1==j+1
5379           enddo ! kk
5380         enddo ! jj
5381       enddo ! i
5382       return
5383       end
5384 c------------------------------------------------------------------------------
5385       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5386      &  n_corr1)
5387 C This subroutine calculates multi-body contributions to hydrogen-bonding
5388       implicit real*8 (a-h,o-z)
5389       include 'DIMENSIONS'
5390       include 'COMMON.IOUNITS'
5391 #ifdef MPI
5392       include 'mpif.h'
5393       parameter (max_cont=maxconts)
5394       parameter (max_dim=2*(8*3+6))
5395 c      parameter (msglen1=max_cont*max_dim*4)
5396       parameter (msglen1=max_cont*max_dim/2)
5397       parameter (msglen2=2*msglen1)
5398       integer source,CorrelType,CorrelID,Error
5399       double precision buffer(max_cont,max_dim)
5400       integer status(MPI_STATUS_SIZE)
5401 #endif
5402       include 'COMMON.SETUP'
5403       include 'COMMON.FFIELD'
5404       include 'COMMON.DERIV'
5405       include 'COMMON.INTERACT'
5406       include 'COMMON.CONTACTS'
5407       include 'COMMON.CONTROL'
5408       double precision gx(3),gx1(3)
5409       logical lprn,ldone
5410 C Set lprn=.true. for debugging
5411       lprn=.false.
5412       eturn6=0.0d0
5413 #ifdef MPI
5414       n_corr=0
5415       n_corr1=0
5416       if (fgProcs.le.1) goto 30
5417       if (lprn) then
5418         write (iout,'(a)') 'Contact function values:'
5419         do i=nnt,nct-2
5420           write (iout,'(2i3,50(1x,i2,f5.2))')
5421      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5422      &    j=1,num_cont_hb(i))
5423         enddo
5424       endif
5425 C Caution! Following code assumes that electrostatic interactions concerning
5426 C a given atom are split among at most two processors!
5427       CorrelType=477
5428       CorrelID=MyID+1
5429       ldone=.false.
5430       do i=1,max_cont
5431         do j=1,max_dim
5432           buffer(i,j)=0.0D0
5433         enddo
5434       enddo
5435       mm=mod(MyRank,2)
5436 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5437       if (mm) 20,20,10
5438    10 continue
5439 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5440       if (MyRank.gt.0) then
5441 C Send correlation contributions to the preceding processor
5442         msglen=msglen1
5443         nn=num_cont_hb(iatel_s)
5444         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5445 cd      write (iout,*) 'The BUFFER array:'
5446 cd      do i=1,nn
5447 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5448 cd      enddo
5449         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5450           msglen=msglen2
5451             call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5452 C Clear the contacts of the atom passed to the neighboring processor
5453         nn=num_cont_hb(iatel_s+1)
5454 cd      do i=1,nn
5455 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5456 cd      enddo
5457             num_cont_hb(iatel_s)=0
5458         endif
5459 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5460 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5461 cd   & ' msglen=',msglen
5462 cd      write (*,*) 'Processor ',MyID,MyRank,
5463 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5464 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5465         time00=MPI_Wtime()
5466         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5467      &     CorrelType,FG_COMM,IERROR)
5468         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5469 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5470 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5471 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5472 cd      write (*,*) 'Processor ',fg_rank,
5473 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5474 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5475         msglen=msglen1
5476       endif ! (MyRank.gt.0)
5477       if (ldone) goto 30
5478       ldone=.true.
5479    20 continue
5480 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5481       if (fg_rank.lt.nfgtasks-1) then
5482 C Receive correlation contributions from the next processor
5483         msglen=msglen1
5484         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5485 cd      write (iout,*) 'Processor',fg_rank,
5486 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5487 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5488 cd      write (*,*) 'Processor',fg_rank,
5489 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5490 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5491         time00=MPI_Wtime()
5492         nbytes=-1
5493         do while (nbytes.le.0)
5494           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5495           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5496         enddo
5497 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5498         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5499      &    fg_rank+1,CorrelType,status,IERROR)
5500         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5501 cd      write (iout,*) 'Processor',fg_rank,
5502 cd   & ' has received correlation contribution from processor',fg_rank+1,
5503 cd   & ' msglen=',msglen,' nbytes=',nbytes
5504 cd      write (iout,*) 'The received BUFFER array:'
5505 cd      do i=1,max_cont
5506 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5507 cd      enddo
5508         if (msglen.eq.msglen1) then
5509           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5510         else if (msglen.eq.msglen2)  then
5511           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5512           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5513         else
5514           write (iout,*)
5515      & 'ERROR!!!! message length changed while processing correlations.'
5516           write (*,*)
5517      & 'ERROR!!!! message length changed while processing correlations.'
5518           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5519         endif ! msglen.eq.msglen1
5520       endif ! fg_rank.lt.nfgtasks-1
5521       if (ldone) goto 30
5522       ldone=.true.
5523       goto 10
5524    30 continue
5525 #endif
5526       if (lprn) then
5527         write (iout,'(a)') 'Contact function values:'
5528         do i=nnt,nct-2
5529           write (iout,'(2i3,50(1x,i2,f5.2))')
5530      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5531      &    j=1,num_cont_hb(i))
5532         enddo
5533       endif
5534       ecorr=0.0D0
5535       ecorr5=0.0d0
5536       ecorr6=0.0d0
5537 C Remove the loop below after debugging !!!
5538       do i=nnt,nct
5539         do j=1,3
5540           gradcorr(j,i)=0.0D0
5541           gradxorr(j,i)=0.0D0
5542         enddo
5543       enddo
5544 C Calculate the dipole-dipole interaction energies
5545       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5546       do i=iatel_s,iatel_e+1
5547         num_conti=num_cont_hb(i)
5548         do jj=1,num_conti
5549           j=jcont_hb(jj,i)
5550 #ifdef MOMENT
5551           call dipole(i,j,jj)
5552 #endif
5553         enddo
5554       enddo
5555       endif
5556 C Calculate the local-electrostatic correlation terms
5557       do i=iatel_s,iatel_e+1
5558         i1=i+1
5559         num_conti=num_cont_hb(i)
5560         num_conti1=num_cont_hb(i+1)
5561         do jj=1,num_conti
5562           j=jcont_hb(jj,i)
5563           do kk=1,num_conti1
5564             j1=jcont_hb(kk,i1)
5565 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5566 c     &         ' jj=',jj,' kk=',kk
5567             if (j1.eq.j+1 .or. j1.eq.j-1) then
5568 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5569 C The system gains extra energy.
5570               n_corr=n_corr+1
5571               sqd1=dsqrt(d_cont(jj,i))
5572               sqd2=dsqrt(d_cont(kk,i1))
5573               sred_geom = sqd1*sqd2
5574               IF (sred_geom.lt.cutoff_corr) THEN
5575                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5576      &            ekont,fprimcont)
5577 cd               write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5578 cd     &         ' jj=',jj,' kk=',kk
5579                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5580                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5581                 do l=1,3
5582                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5583                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5584                 enddo
5585                 n_corr1=n_corr1+1
5586 cd               write (iout,*) 'sred_geom=',sred_geom,
5587 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5588                 call calc_eello(i,j,i+1,j1,jj,kk)
5589                 if (wcorr4.gt.0.0d0)
5590      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5591                   if (energy_dec.and.wcorr4.gt.0.0d0)
5592      1                 write (iout,'(a6,2i5,0pf7.3)')
5593      2                'ecorr4',i,j,eello4(i,j,i+1,j1,jj,kk)
5594                 if (wcorr5.gt.0.0d0)
5595      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5596                   if (energy_dec.and.wcorr5.gt.0.0d0)
5597      1                 write (iout,'(a6,2i5,0pf7.3)')
5598      2                'ecorr5',i,j,eello5(i,j,i+1,j1,jj,kk)
5599 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5600 cd                write(2,*)'ijkl',i,j,i+1,j1
5601                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5602      &               .or. wturn6.eq.0.0d0))then
5603 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5604                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5605                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5606      1                'ecorr6',i,j,eello6(i,j,i+1,j1,jj,kk)
5607 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5608 cd     &            'ecorr6=',ecorr6
5609 cd                write (iout,'(4e15.5)') sred_geom,
5610 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5611 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5612 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5613                 else if (wturn6.gt.0.0d0
5614      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5615 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5616                   eturn6=eturn6+eello_turn6(i,jj,kk)
5617                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5618      1                 'eturn6',i,j,eello_turn6(i,jj,kk)
5619 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5620                 endif
5621               ENDIF
5622 1111          continue
5623             else if (j1.eq.j) then
5624 C Contacts I-J and I-(J+1) occur simultaneously.
5625 C The system loses extra energy.
5626 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5627             endif
5628           enddo ! kk
5629           do kk=1,num_conti
5630             j1=jcont_hb(kk,i)
5631 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5632 c    &         ' jj=',jj,' kk=',kk
5633             if (j1.eq.j+1) then
5634 C Contacts I-J and (I+1)-J occur simultaneously.
5635 C The system loses extra energy.
5636 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5637             endif ! j1==j+1
5638           enddo ! kk
5639         enddo ! jj
5640       enddo ! i
5641       return
5642       end
5643 c------------------------------------------------------------------------------
5644       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5645       implicit real*8 (a-h,o-z)
5646       include 'DIMENSIONS'
5647       include 'COMMON.IOUNITS'
5648       include 'COMMON.DERIV'
5649       include 'COMMON.INTERACT'
5650       include 'COMMON.CONTACTS'
5651       double precision gx(3),gx1(3)
5652       logical lprn
5653       lprn=.false.
5654       eij=facont_hb(jj,i)
5655       ekl=facont_hb(kk,k)
5656       ees0pij=ees0p(jj,i)
5657       ees0pkl=ees0p(kk,k)
5658       ees0mij=ees0m(jj,i)
5659       ees0mkl=ees0m(kk,k)
5660       ekont=eij*ekl
5661       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5662 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5663 C Following 4 lines for diagnostics.
5664 cd    ees0pkl=0.0D0
5665 cd    ees0pij=1.0D0
5666 cd    ees0mkl=0.0D0
5667 cd    ees0mij=1.0D0
5668 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5669 c    &   ' and',k,l
5670 c     write (iout,*)'Contacts have occurred for peptide groups',
5671 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5672 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5673 C Calculate the multi-body contribution to energy.
5674       ecorr=ecorr+ekont*ees
5675 C Calculate multi-body contributions to the gradient.
5676       do ll=1,3
5677         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5678         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5679      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5680      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5681         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5682      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5683      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5684         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5685         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5686      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5687      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5688         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5689      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5690      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5691       enddo
5692       do m=i+1,j-1
5693         do ll=1,3
5694           gradcorr(ll,m)=gradcorr(ll,m)+
5695      &     ees*ekl*gacont_hbr(ll,jj,i)-
5696      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5697      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5698         enddo
5699       enddo
5700       do m=k+1,l-1
5701         do ll=1,3
5702           gradcorr(ll,m)=gradcorr(ll,m)+
5703      &     ees*eij*gacont_hbr(ll,kk,k)-
5704      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5705      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5706         enddo
5707       enddo
5708       ehbcorr=ekont*ees
5709       return
5710       end
5711 #ifdef MOMENT
5712 C---------------------------------------------------------------------------
5713       subroutine dipole(i,j,jj)
5714       implicit real*8 (a-h,o-z)
5715       include 'DIMENSIONS'
5716       include 'COMMON.IOUNITS'
5717       include 'COMMON.CHAIN'
5718       include 'COMMON.FFIELD'
5719       include 'COMMON.DERIV'
5720       include 'COMMON.INTERACT'
5721       include 'COMMON.CONTACTS'
5722       include 'COMMON.TORSION'
5723       include 'COMMON.VAR'
5724       include 'COMMON.GEO'
5725       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5726      &  auxmat(2,2)
5727       iti1 = itortyp(itype(i+1))
5728       if (j.lt.nres-1) then
5729         itj1 = itortyp(itype(j+1))
5730       else
5731         itj1=ntortyp+1
5732       endif
5733       do iii=1,2
5734         dipi(iii,1)=Ub2(iii,i)
5735         dipderi(iii)=Ub2der(iii,i)
5736         dipi(iii,2)=b1(iii,iti1)
5737         dipj(iii,1)=Ub2(iii,j)
5738         dipderj(iii)=Ub2der(iii,j)
5739         dipj(iii,2)=b1(iii,itj1)
5740       enddo
5741       kkk=0
5742       do iii=1,2
5743         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5744         do jjj=1,2
5745           kkk=kkk+1
5746           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5747         enddo
5748       enddo
5749       do kkk=1,5
5750         do lll=1,3
5751           mmm=0
5752           do iii=1,2
5753             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5754      &        auxvec(1))
5755             do jjj=1,2
5756               mmm=mmm+1
5757               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5758             enddo
5759           enddo
5760         enddo
5761       enddo
5762       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5763       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5764       do iii=1,2
5765         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5766       enddo
5767       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5768       do iii=1,2
5769         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5770       enddo
5771       return
5772       end
5773 #endif
5774 C---------------------------------------------------------------------------
5775       subroutine calc_eello(i,j,k,l,jj,kk)
5776 C
5777 C This subroutine computes matrices and vectors needed to calculate
5778 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5779 C
5780       implicit real*8 (a-h,o-z)
5781       include 'DIMENSIONS'
5782       include 'COMMON.IOUNITS'
5783       include 'COMMON.CHAIN'
5784       include 'COMMON.DERIV'
5785       include 'COMMON.INTERACT'
5786       include 'COMMON.CONTACTS'
5787       include 'COMMON.TORSION'
5788       include 'COMMON.VAR'
5789       include 'COMMON.GEO'
5790       include 'COMMON.FFIELD'
5791       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5792      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5793       logical lprn
5794       common /kutas/ lprn
5795 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5796 cd     & ' jj=',jj,' kk=',kk
5797 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5798       do iii=1,2
5799         do jjj=1,2
5800           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5801           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5802         enddo
5803       enddo
5804       call transpose2(aa1(1,1),aa1t(1,1))
5805       call transpose2(aa2(1,1),aa2t(1,1))
5806       do kkk=1,5
5807         do lll=1,3
5808           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5809      &      aa1tder(1,1,lll,kkk))
5810           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5811      &      aa2tder(1,1,lll,kkk))
5812         enddo
5813       enddo
5814       if (l.eq.j+1) then
5815 C parallel orientation of the two CA-CA-CA frames.
5816         if (i.gt.1) then
5817           iti=itortyp(itype(i))
5818         else
5819           iti=ntortyp+1
5820         endif
5821         itk1=itortyp(itype(k+1))
5822         itj=itortyp(itype(j))
5823         if (l.lt.nres-1) then
5824           itl1=itortyp(itype(l+1))
5825         else
5826           itl1=ntortyp+1
5827         endif
5828 C A1 kernel(j+1) A2T
5829 cd        do iii=1,2
5830 cd          write (iout,'(3f10.5,5x,3f10.5)')
5831 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5832 cd        enddo
5833         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5834      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5835      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5836 C Following matrices are needed only for 6-th order cumulants
5837         IF (wcorr6.gt.0.0d0) THEN
5838         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5839      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5840      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5841         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5842      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5843      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5844      &   ADtEAderx(1,1,1,1,1,1))
5845         lprn=.false.
5846         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5847      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5848      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5849      &   ADtEA1derx(1,1,1,1,1,1))
5850         ENDIF
5851 C End 6-th order cumulants
5852 cd        lprn=.false.
5853 cd        if (lprn) then
5854 cd        write (2,*) 'In calc_eello6'
5855 cd        do iii=1,2
5856 cd          write (2,*) 'iii=',iii
5857 cd          do kkk=1,5
5858 cd            write (2,*) 'kkk=',kkk
5859 cd            do jjj=1,2
5860 cd              write (2,'(3(2f10.5),5x)')
5861 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5862 cd            enddo
5863 cd          enddo
5864 cd        enddo
5865 cd        endif
5866         call transpose2(EUgder(1,1,k),auxmat(1,1))
5867         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5868         call transpose2(EUg(1,1,k),auxmat(1,1))
5869         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5870         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5871         do iii=1,2
5872           do kkk=1,5
5873             do lll=1,3
5874               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5875      &          EAEAderx(1,1,lll,kkk,iii,1))
5876             enddo
5877           enddo
5878         enddo
5879 C A1T kernel(i+1) A2
5880         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5881      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5882      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5883 C Following matrices are needed only for 6-th order cumulants
5884         IF (wcorr6.gt.0.0d0) THEN
5885         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5886      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5887      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5888         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5889      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5890      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5891      &   ADtEAderx(1,1,1,1,1,2))
5892         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5893      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5894      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5895      &   ADtEA1derx(1,1,1,1,1,2))
5896         ENDIF
5897 C End 6-th order cumulants
5898         call transpose2(EUgder(1,1,l),auxmat(1,1))
5899         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5900         call transpose2(EUg(1,1,l),auxmat(1,1))
5901         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5902         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5903         do iii=1,2
5904           do kkk=1,5
5905             do lll=1,3
5906               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5907      &          EAEAderx(1,1,lll,kkk,iii,2))
5908             enddo
5909           enddo
5910         enddo
5911 C AEAb1 and AEAb2
5912 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5913 C They are needed only when the fifth- or the sixth-order cumulants are
5914 C indluded.
5915         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5916         call transpose2(AEA(1,1,1),auxmat(1,1))
5917         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5918         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5919         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5920         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5921         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5922         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5923         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5924         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5925         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5926         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5927         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5928         call transpose2(AEA(1,1,2),auxmat(1,1))
5929         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5930         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5931         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5932         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5933         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5934         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5935         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5936         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5937         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5938         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5939         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5940 C Calculate the Cartesian derivatives of the vectors.
5941         do iii=1,2
5942           do kkk=1,5
5943             do lll=1,3
5944               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5945               call matvec2(auxmat(1,1),b1(1,iti),
5946      &          AEAb1derx(1,lll,kkk,iii,1,1))
5947               call matvec2(auxmat(1,1),Ub2(1,i),
5948      &          AEAb2derx(1,lll,kkk,iii,1,1))
5949               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5950      &          AEAb1derx(1,lll,kkk,iii,2,1))
5951               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5952      &          AEAb2derx(1,lll,kkk,iii,2,1))
5953               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5954               call matvec2(auxmat(1,1),b1(1,itj),
5955      &          AEAb1derx(1,lll,kkk,iii,1,2))
5956               call matvec2(auxmat(1,1),Ub2(1,j),
5957      &          AEAb2derx(1,lll,kkk,iii,1,2))
5958               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5959      &          AEAb1derx(1,lll,kkk,iii,2,2))
5960               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5961      &          AEAb2derx(1,lll,kkk,iii,2,2))
5962             enddo
5963           enddo
5964         enddo
5965         ENDIF
5966 C End vectors
5967       else
5968 C Antiparallel orientation of the two CA-CA-CA frames.
5969         if (i.gt.1) then
5970           iti=itortyp(itype(i))
5971         else
5972           iti=ntortyp+1
5973         endif
5974         itk1=itortyp(itype(k+1))
5975         itl=itortyp(itype(l))
5976         itj=itortyp(itype(j))
5977         if (j.lt.nres-1) then
5978           itj1=itortyp(itype(j+1))
5979         else
5980           itj1=ntortyp+1
5981         endif
5982 C A2 kernel(j-1)T A1T
5983         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5984      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5985      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5986 C Following matrices are needed only for 6-th order cumulants
5987         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5988      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5989         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5990      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5991      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5992         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5993      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5994      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5995      &   ADtEAderx(1,1,1,1,1,1))
5996         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5997      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5998      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5999      &   ADtEA1derx(1,1,1,1,1,1))
6000         ENDIF
6001 C End 6-th order cumulants
6002         call transpose2(EUgder(1,1,k),auxmat(1,1))
6003         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6004         call transpose2(EUg(1,1,k),auxmat(1,1))
6005         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6006         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6007         do iii=1,2
6008           do kkk=1,5
6009             do lll=1,3
6010               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6011      &          EAEAderx(1,1,lll,kkk,iii,1))
6012             enddo
6013           enddo
6014         enddo
6015 C A2T kernel(i+1)T A1
6016         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6017      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6018      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6019 C Following matrices are needed only for 6-th order cumulants
6020         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6021      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6022         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6023      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6024      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6025         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6026      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6027      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6028      &   ADtEAderx(1,1,1,1,1,2))
6029         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6030      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6031      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6032      &   ADtEA1derx(1,1,1,1,1,2))
6033         ENDIF
6034 C End 6-th order cumulants
6035         call transpose2(EUgder(1,1,j),auxmat(1,1))
6036         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6037         call transpose2(EUg(1,1,j),auxmat(1,1))
6038         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6039         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6040         do iii=1,2
6041           do kkk=1,5
6042             do lll=1,3
6043               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6044      &          EAEAderx(1,1,lll,kkk,iii,2))
6045             enddo
6046           enddo
6047         enddo
6048 C AEAb1 and AEAb2
6049 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6050 C They are needed only when the fifth- or the sixth-order cumulants are
6051 C indluded.
6052         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6053      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6054         call transpose2(AEA(1,1,1),auxmat(1,1))
6055         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6056         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6057         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6058         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6059         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6060         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6061         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6062         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6063         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6064         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6065         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6066         call transpose2(AEA(1,1,2),auxmat(1,1))
6067         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6068         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6069         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6070         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6071         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6072         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6073         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6074         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6075         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6076         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6077         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6078 C Calculate the Cartesian derivatives of the vectors.
6079         do iii=1,2
6080           do kkk=1,5
6081             do lll=1,3
6082               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6083               call matvec2(auxmat(1,1),b1(1,iti),
6084      &          AEAb1derx(1,lll,kkk,iii,1,1))
6085               call matvec2(auxmat(1,1),Ub2(1,i),
6086      &          AEAb2derx(1,lll,kkk,iii,1,1))
6087               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6088      &          AEAb1derx(1,lll,kkk,iii,2,1))
6089               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6090      &          AEAb2derx(1,lll,kkk,iii,2,1))
6091               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6092               call matvec2(auxmat(1,1),b1(1,itl),
6093      &          AEAb1derx(1,lll,kkk,iii,1,2))
6094               call matvec2(auxmat(1,1),Ub2(1,l),
6095      &          AEAb2derx(1,lll,kkk,iii,1,2))
6096               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6097      &          AEAb1derx(1,lll,kkk,iii,2,2))
6098               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6099      &          AEAb2derx(1,lll,kkk,iii,2,2))
6100             enddo
6101           enddo
6102         enddo
6103         ENDIF
6104 C End vectors
6105       endif
6106       return
6107       end
6108 C---------------------------------------------------------------------------
6109       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6110      &  KK,KKderg,AKA,AKAderg,AKAderx)
6111       implicit none
6112       integer nderg
6113       logical transp
6114       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6115      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6116      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6117       integer iii,kkk,lll
6118       integer jjj,mmm
6119       logical lprn
6120       common /kutas/ lprn
6121       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6122       do iii=1,nderg
6123         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6124      &    AKAderg(1,1,iii))
6125       enddo
6126 cd      if (lprn) write (2,*) 'In kernel'
6127       do kkk=1,5
6128 cd        if (lprn) write (2,*) 'kkk=',kkk
6129         do lll=1,3
6130           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6131      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6132 cd          if (lprn) then
6133 cd            write (2,*) 'lll=',lll
6134 cd            write (2,*) 'iii=1'
6135 cd            do jjj=1,2
6136 cd              write (2,'(3(2f10.5),5x)')
6137 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6138 cd            enddo
6139 cd          endif
6140           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6141      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6142 cd          if (lprn) then
6143 cd            write (2,*) 'lll=',lll
6144 cd            write (2,*) 'iii=2'
6145 cd            do jjj=1,2
6146 cd              write (2,'(3(2f10.5),5x)')
6147 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6148 cd            enddo
6149 cd          endif
6150         enddo
6151       enddo
6152       return
6153       end
6154 C---------------------------------------------------------------------------
6155       double precision function eello4(i,j,k,l,jj,kk)
6156       implicit real*8 (a-h,o-z)
6157       include 'DIMENSIONS'
6158       include 'COMMON.IOUNITS'
6159       include 'COMMON.CHAIN'
6160       include 'COMMON.DERIV'
6161       include 'COMMON.INTERACT'
6162       include 'COMMON.CONTACTS'
6163       include 'COMMON.TORSION'
6164       include 'COMMON.VAR'
6165       include 'COMMON.GEO'
6166       double precision pizda(2,2),ggg1(3),ggg2(3)
6167 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6168 cd        eello4=0.0d0
6169 cd        return
6170 cd      endif
6171 cd      print *,'eello4:',i,j,k,l,jj,kk
6172 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6173 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6174 cold      eij=facont_hb(jj,i)
6175 cold      ekl=facont_hb(kk,k)
6176 cold      ekont=eij*ekl
6177       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6178 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6179       gcorr_loc(k-1)=gcorr_loc(k-1)
6180      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6181       if (l.eq.j+1) then
6182         gcorr_loc(l-1)=gcorr_loc(l-1)
6183      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6184       else
6185         gcorr_loc(j-1)=gcorr_loc(j-1)
6186      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6187       endif
6188       do iii=1,2
6189         do kkk=1,5
6190           do lll=1,3
6191             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6192      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6193 cd            derx(lll,kkk,iii)=0.0d0
6194           enddo
6195         enddo
6196       enddo
6197 cd      gcorr_loc(l-1)=0.0d0
6198 cd      gcorr_loc(j-1)=0.0d0
6199 cd      gcorr_loc(k-1)=0.0d0
6200 cd      eel4=1.0d0
6201 cd      write (iout,*)'Contacts have occurred for peptide groups',
6202 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6203 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6204       if (j.lt.nres-1) then
6205         j1=j+1
6206         j2=j-1
6207       else
6208         j1=j-1
6209         j2=j-2
6210       endif
6211       if (l.lt.nres-1) then
6212         l1=l+1
6213         l2=l-1
6214       else
6215         l1=l-1
6216         l2=l-2
6217       endif
6218       do ll=1,3
6219 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6220         ggg1(ll)=eel4*g_contij(ll,1)
6221         ggg2(ll)=eel4*g_contij(ll,2)
6222         ghalf=0.5d0*ggg1(ll)
6223 cd        ghalf=0.0d0
6224         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6225         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6226         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6227         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6228 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6229         ghalf=0.5d0*ggg2(ll)
6230 cd        ghalf=0.0d0
6231         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6232         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6233         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6234         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6235       enddo
6236 cd      goto 1112
6237       do m=i+1,j-1
6238         do ll=1,3
6239 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6240           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6241         enddo
6242       enddo
6243       do m=k+1,l-1
6244         do ll=1,3
6245 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6246           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6247         enddo
6248       enddo
6249 1112  continue
6250       do m=i+2,j2
6251         do ll=1,3
6252           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6253         enddo
6254       enddo
6255       do m=k+2,l2
6256         do ll=1,3
6257           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6258         enddo
6259       enddo
6260 cd      do iii=1,nres-3
6261 cd        write (2,*) iii,gcorr_loc(iii)
6262 cd      enddo
6263       eello4=ekont*eel4
6264 cd      write (2,*) 'ekont',ekont
6265 cd      write (iout,*) 'eello4',ekont*eel4
6266       return
6267       end
6268 C---------------------------------------------------------------------------
6269       double precision function eello5(i,j,k,l,jj,kk)
6270       implicit real*8 (a-h,o-z)
6271       include 'DIMENSIONS'
6272       include 'COMMON.IOUNITS'
6273       include 'COMMON.CHAIN'
6274       include 'COMMON.DERIV'
6275       include 'COMMON.INTERACT'
6276       include 'COMMON.CONTACTS'
6277       include 'COMMON.TORSION'
6278       include 'COMMON.VAR'
6279       include 'COMMON.GEO'
6280       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6281       double precision ggg1(3),ggg2(3)
6282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6283 C                                                                              C
6284 C                            Parallel chains                                   C
6285 C                                                                              C
6286 C          o             o                   o             o                   C
6287 C         /l\           / \             \   / \           / \   /              C
6288 C        /   \         /   \             \ /   \         /   \ /               C
6289 C       j| o |l1       | o |              o| o |         | o |o                C
6290 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6291 C      \i/   \         /   \ /             /   \         /   \                 C
6292 C       o    k1             o                                                  C
6293 C         (I)          (II)                (III)          (IV)                 C
6294 C                                                                              C
6295 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6296 C                                                                              C
6297 C                            Antiparallel chains                               C
6298 C                                                                              C
6299 C          o             o                   o             o                   C
6300 C         /j\           / \             \   / \           / \   /              C
6301 C        /   \         /   \             \ /   \         /   \ /               C
6302 C      j1| o |l        | o |              o| o |         | o |o                C
6303 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6304 C      \i/   \         /   \ /             /   \         /   \                 C
6305 C       o     k1            o                                                  C
6306 C         (I)          (II)                (III)          (IV)                 C
6307 C                                                                              C
6308 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6309 C                                                                              C
6310 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6311 C                                                                              C
6312 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6313 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6314 cd        eello5=0.0d0
6315 cd        return
6316 cd      endif
6317 cd      write (iout,*)
6318 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6319 cd     &   ' and',k,l
6320       itk=itortyp(itype(k))
6321       itl=itortyp(itype(l))
6322       itj=itortyp(itype(j))
6323       eello5_1=0.0d0
6324       eello5_2=0.0d0
6325       eello5_3=0.0d0
6326       eello5_4=0.0d0
6327 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6328 cd     &   eel5_3_num,eel5_4_num)
6329       do iii=1,2
6330         do kkk=1,5
6331           do lll=1,3
6332             derx(lll,kkk,iii)=0.0d0
6333           enddo
6334         enddo
6335       enddo
6336 cd      eij=facont_hb(jj,i)
6337 cd      ekl=facont_hb(kk,k)
6338 cd      ekont=eij*ekl
6339 cd      write (iout,*)'Contacts have occurred for peptide groups',
6340 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6341 cd      goto 1111
6342 C Contribution from the graph I.
6343 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6344 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6345       call transpose2(EUg(1,1,k),auxmat(1,1))
6346       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6347       vv(1)=pizda(1,1)-pizda(2,2)
6348       vv(2)=pizda(1,2)+pizda(2,1)
6349       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6350      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6351 C Explicit gradient in virtual-dihedral angles.
6352       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6353      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6354      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6355       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6356       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6357       vv(1)=pizda(1,1)-pizda(2,2)
6358       vv(2)=pizda(1,2)+pizda(2,1)
6359       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6360      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6361      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6362       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6363       vv(1)=pizda(1,1)-pizda(2,2)
6364       vv(2)=pizda(1,2)+pizda(2,1)
6365       if (l.eq.j+1) then
6366         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6367      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6368      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6369       else
6370         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6371      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6372      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6373       endif
6374 C Cartesian gradient
6375       do iii=1,2
6376         do kkk=1,5
6377           do lll=1,3
6378             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6379      &        pizda(1,1))
6380             vv(1)=pizda(1,1)-pizda(2,2)
6381             vv(2)=pizda(1,2)+pizda(2,1)
6382             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6383      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6384      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6385           enddo
6386         enddo
6387       enddo
6388 c      goto 1112
6389 c1111  continue
6390 C Contribution from graph II
6391       call transpose2(EE(1,1,itk),auxmat(1,1))
6392       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6393       vv(1)=pizda(1,1)+pizda(2,2)
6394       vv(2)=pizda(2,1)-pizda(1,2)
6395       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6396      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6397 C Explicit gradient in virtual-dihedral angles.
6398       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6399      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6400       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6401       vv(1)=pizda(1,1)+pizda(2,2)
6402       vv(2)=pizda(2,1)-pizda(1,2)
6403       if (l.eq.j+1) then
6404         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6405      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6406      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6407       else
6408         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6409      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6410      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6411       endif
6412 C Cartesian gradient
6413       do iii=1,2
6414         do kkk=1,5
6415           do lll=1,3
6416             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6417      &        pizda(1,1))
6418             vv(1)=pizda(1,1)+pizda(2,2)
6419             vv(2)=pizda(2,1)-pizda(1,2)
6420             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6421      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6422      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6423           enddo
6424         enddo
6425       enddo
6426 cd      goto 1112
6427 cd1111  continue
6428       if (l.eq.j+1) then
6429 cd        goto 1110
6430 C Parallel orientation
6431 C Contribution from graph III
6432         call transpose2(EUg(1,1,l),auxmat(1,1))
6433         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6434         vv(1)=pizda(1,1)-pizda(2,2)
6435         vv(2)=pizda(1,2)+pizda(2,1)
6436         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6437      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6438 C Explicit gradient in virtual-dihedral angles.
6439         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6440      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6441      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6442         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6443         vv(1)=pizda(1,1)-pizda(2,2)
6444         vv(2)=pizda(1,2)+pizda(2,1)
6445         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6446      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6447      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6448         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6449         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6450         vv(1)=pizda(1,1)-pizda(2,2)
6451         vv(2)=pizda(1,2)+pizda(2,1)
6452         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6453      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6454      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6455 C Cartesian gradient
6456         do iii=1,2
6457           do kkk=1,5
6458             do lll=1,3
6459               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6460      &          pizda(1,1))
6461               vv(1)=pizda(1,1)-pizda(2,2)
6462               vv(2)=pizda(1,2)+pizda(2,1)
6463               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6464      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6465      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6466             enddo
6467           enddo
6468         enddo
6469 cd        goto 1112
6470 C Contribution from graph IV
6471 cd1110    continue
6472         call transpose2(EE(1,1,itl),auxmat(1,1))
6473         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6474         vv(1)=pizda(1,1)+pizda(2,2)
6475         vv(2)=pizda(2,1)-pizda(1,2)
6476         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6477      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6478 C Explicit gradient in virtual-dihedral angles.
6479         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6480      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6481         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6482         vv(1)=pizda(1,1)+pizda(2,2)
6483         vv(2)=pizda(2,1)-pizda(1,2)
6484         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6485      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6486      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6487 C Cartesian gradient
6488         do iii=1,2
6489           do kkk=1,5
6490             do lll=1,3
6491               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6492      &          pizda(1,1))
6493               vv(1)=pizda(1,1)+pizda(2,2)
6494               vv(2)=pizda(2,1)-pizda(1,2)
6495               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6496      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6497      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6498             enddo
6499           enddo
6500         enddo
6501       else
6502 C Antiparallel orientation
6503 C Contribution from graph III
6504 c        goto 1110
6505         call transpose2(EUg(1,1,j),auxmat(1,1))
6506         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6507         vv(1)=pizda(1,1)-pizda(2,2)
6508         vv(2)=pizda(1,2)+pizda(2,1)
6509         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6510      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6511 C Explicit gradient in virtual-dihedral angles.
6512         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6513      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6514      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6515         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6516         vv(1)=pizda(1,1)-pizda(2,2)
6517         vv(2)=pizda(1,2)+pizda(2,1)
6518         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6519      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6520      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6521         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6522         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6523         vv(1)=pizda(1,1)-pizda(2,2)
6524         vv(2)=pizda(1,2)+pizda(2,1)
6525         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6526      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6527      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6528 C Cartesian gradient
6529         do iii=1,2
6530           do kkk=1,5
6531             do lll=1,3
6532               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6533      &          pizda(1,1))
6534               vv(1)=pizda(1,1)-pizda(2,2)
6535               vv(2)=pizda(1,2)+pizda(2,1)
6536               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6537      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6538      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6539             enddo
6540           enddo
6541         enddo
6542 cd        goto 1112
6543 C Contribution from graph IV
6544 1110    continue
6545         call transpose2(EE(1,1,itj),auxmat(1,1))
6546         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6547         vv(1)=pizda(1,1)+pizda(2,2)
6548         vv(2)=pizda(2,1)-pizda(1,2)
6549         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6550      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6551 C Explicit gradient in virtual-dihedral angles.
6552         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6553      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6554         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6555         vv(1)=pizda(1,1)+pizda(2,2)
6556         vv(2)=pizda(2,1)-pizda(1,2)
6557         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6558      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6559      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6560 C Cartesian gradient
6561         do iii=1,2
6562           do kkk=1,5
6563             do lll=1,3
6564               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6565      &          pizda(1,1))
6566               vv(1)=pizda(1,1)+pizda(2,2)
6567               vv(2)=pizda(2,1)-pizda(1,2)
6568               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6569      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6570      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6571             enddo
6572           enddo
6573         enddo
6574       endif
6575 1112  continue
6576       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6577 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6578 cd        write (2,*) 'ijkl',i,j,k,l
6579 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6580 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6581 cd      endif
6582 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6583 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6584 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6585 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6586       if (j.lt.nres-1) then
6587         j1=j+1
6588         j2=j-1
6589       else
6590         j1=j-1
6591         j2=j-2
6592       endif
6593       if (l.lt.nres-1) then
6594         l1=l+1
6595         l2=l-1
6596       else
6597         l1=l-1
6598         l2=l-2
6599       endif
6600 cd      eij=1.0d0
6601 cd      ekl=1.0d0
6602 cd      ekont=1.0d0
6603 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6604       do ll=1,3
6605         ggg1(ll)=eel5*g_contij(ll,1)
6606         ggg2(ll)=eel5*g_contij(ll,2)
6607 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6608         ghalf=0.5d0*ggg1(ll)
6609 cd        ghalf=0.0d0
6610         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6611         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6612         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6613         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6614 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6615         ghalf=0.5d0*ggg2(ll)
6616 cd        ghalf=0.0d0
6617         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6618         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6619         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6620         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6621       enddo
6622 cd      goto 1112
6623       do m=i+1,j-1
6624         do ll=1,3
6625 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6626           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6627         enddo
6628       enddo
6629       do m=k+1,l-1
6630         do ll=1,3
6631 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6632           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6633         enddo
6634       enddo
6635 c1112  continue
6636       do m=i+2,j2
6637         do ll=1,3
6638           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6639         enddo
6640       enddo
6641       do m=k+2,l2
6642         do ll=1,3
6643           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6644         enddo
6645       enddo
6646 cd      do iii=1,nres-3
6647 cd        write (2,*) iii,g_corr5_loc(iii)
6648 cd      enddo
6649       eello5=ekont*eel5
6650 cd      write (2,*) 'ekont',ekont
6651 cd      write (iout,*) 'eello5',ekont*eel5
6652       return
6653       end
6654 c--------------------------------------------------------------------------
6655       double precision function eello6(i,j,k,l,jj,kk)
6656       implicit real*8 (a-h,o-z)
6657       include 'DIMENSIONS'
6658       include 'COMMON.IOUNITS'
6659       include 'COMMON.CHAIN'
6660       include 'COMMON.DERIV'
6661       include 'COMMON.INTERACT'
6662       include 'COMMON.CONTACTS'
6663       include 'COMMON.TORSION'
6664       include 'COMMON.VAR'
6665       include 'COMMON.GEO'
6666       include 'COMMON.FFIELD'
6667       double precision ggg1(3),ggg2(3)
6668 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6669 cd        eello6=0.0d0
6670 cd        return
6671 cd      endif
6672 cd      write (iout,*)
6673 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6674 cd     &   ' and',k,l
6675       eello6_1=0.0d0
6676       eello6_2=0.0d0
6677       eello6_3=0.0d0
6678       eello6_4=0.0d0
6679       eello6_5=0.0d0
6680       eello6_6=0.0d0
6681 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6682 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6683       do iii=1,2
6684         do kkk=1,5
6685           do lll=1,3
6686             derx(lll,kkk,iii)=0.0d0
6687           enddo
6688         enddo
6689       enddo
6690 cd      eij=facont_hb(jj,i)
6691 cd      ekl=facont_hb(kk,k)
6692 cd      ekont=eij*ekl
6693 cd      eij=1.0d0
6694 cd      ekl=1.0d0
6695 cd      ekont=1.0d0
6696       if (l.eq.j+1) then
6697         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6698         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6699         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6700         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6701         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6702         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6703       else
6704         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6705         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6706         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6707         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6708         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6709           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6710         else
6711           eello6_5=0.0d0
6712         endif
6713         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6714       endif
6715 C If turn contributions are considered, they will be handled separately.
6716       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6717 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6718 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6719 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6720 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6721 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6722 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6723 cd      goto 1112
6724       if (j.lt.nres-1) then
6725         j1=j+1
6726         j2=j-1
6727       else
6728         j1=j-1
6729         j2=j-2
6730       endif
6731       if (l.lt.nres-1) then
6732         l1=l+1
6733         l2=l-1
6734       else
6735         l1=l-1
6736         l2=l-2
6737       endif
6738       do ll=1,3
6739         ggg1(ll)=eel6*g_contij(ll,1)
6740         ggg2(ll)=eel6*g_contij(ll,2)
6741 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6742         ghalf=0.5d0*ggg1(ll)
6743 cd        ghalf=0.0d0
6744         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6745         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6746         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6747         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6748         ghalf=0.5d0*ggg2(ll)
6749 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6750 cd        ghalf=0.0d0
6751         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6752         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6753         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6754         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6755       enddo
6756 cd      goto 1112
6757       do m=i+1,j-1
6758         do ll=1,3
6759 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6760           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6761         enddo
6762       enddo
6763       do m=k+1,l-1
6764         do ll=1,3
6765 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6766           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6767         enddo
6768       enddo
6769 1112  continue
6770       do m=i+2,j2
6771         do ll=1,3
6772           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6773         enddo
6774       enddo
6775       do m=k+2,l2
6776         do ll=1,3
6777           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6778         enddo
6779       enddo
6780 cd      do iii=1,nres-3
6781 cd        write (2,*) iii,g_corr6_loc(iii)
6782 cd      enddo
6783       eello6=ekont*eel6
6784 cd      write (2,*) 'ekont',ekont
6785 cd      write (iout,*) 'eello6',ekont*eel6
6786       return
6787       end
6788 c--------------------------------------------------------------------------
6789       double precision function eello6_graph1(i,j,k,l,imat,swap)
6790       implicit real*8 (a-h,o-z)
6791       include 'DIMENSIONS'
6792       include 'COMMON.IOUNITS'
6793       include 'COMMON.CHAIN'
6794       include 'COMMON.DERIV'
6795       include 'COMMON.INTERACT'
6796       include 'COMMON.CONTACTS'
6797       include 'COMMON.TORSION'
6798       include 'COMMON.VAR'
6799       include 'COMMON.GEO'
6800       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6801       logical swap
6802       logical lprn
6803       common /kutas/ lprn
6804 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6805 C
6806 C      Parallel       Antiparallel
6807 C
6808 C          o             o
6809 C         /l\           /j\
6810 C        /   \         /   \
6811 C       /| o |         | o |\
6812 C     \ j|/k\|  /   \  |/k\|l /
6813 C      \ /   \ /     \ /   \ /
6814 C       o     o       o     o
6815 C       i             i
6816 C
6817 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6818       itk=itortyp(itype(k))
6819       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6820       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6821       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6822       call transpose2(EUgC(1,1,k),auxmat(1,1))
6823       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6824       vv1(1)=pizda1(1,1)-pizda1(2,2)
6825       vv1(2)=pizda1(1,2)+pizda1(2,1)
6826       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6827       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6828       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6829       s5=scalar2(vv(1),Dtobr2(1,i))
6830 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6831       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6832       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6833      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6834      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6835      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6836      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6837      & +scalar2(vv(1),Dtobr2der(1,i)))
6838       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6839       vv1(1)=pizda1(1,1)-pizda1(2,2)
6840       vv1(2)=pizda1(1,2)+pizda1(2,1)
6841       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6842       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6843       if (l.eq.j+1) then
6844         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6845      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6846      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6847      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6848      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6849       else
6850         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6851      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6852      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6853      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6854      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6855       endif
6856       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6857       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6858       vv1(1)=pizda1(1,1)-pizda1(2,2)
6859       vv1(2)=pizda1(1,2)+pizda1(2,1)
6860       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6861      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6862      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6863      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6864       do iii=1,2
6865         if (swap) then
6866           ind=3-iii
6867         else
6868           ind=iii
6869         endif
6870         do kkk=1,5
6871           do lll=1,3
6872             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6873             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6874             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6875             call transpose2(EUgC(1,1,k),auxmat(1,1))
6876             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6877      &        pizda1(1,1))
6878             vv1(1)=pizda1(1,1)-pizda1(2,2)
6879             vv1(2)=pizda1(1,2)+pizda1(2,1)
6880             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6881             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6882      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6883             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6884      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6885             s5=scalar2(vv(1),Dtobr2(1,i))
6886             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6887           enddo
6888         enddo
6889       enddo
6890       return
6891       end
6892 c----------------------------------------------------------------------------
6893       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6894       implicit real*8 (a-h,o-z)
6895       include 'DIMENSIONS'
6896       include 'COMMON.IOUNITS'
6897       include 'COMMON.CHAIN'
6898       include 'COMMON.DERIV'
6899       include 'COMMON.INTERACT'
6900       include 'COMMON.CONTACTS'
6901       include 'COMMON.TORSION'
6902       include 'COMMON.VAR'
6903       include 'COMMON.GEO'
6904       logical swap
6905       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6906      & auxvec1(2),auxvec2(1),auxmat1(2,2)
6907       logical lprn
6908       common /kutas/ lprn
6909 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6910 C
6911 C      Parallel       Antiparallel
6912 C
6913 C          o             o
6914 C     \   /l\           /j\   /
6915 C      \ /   \         /   \ /
6916 C       o| o |         | o |o
6917 C     \ j|/k\|      \  |/k\|l
6918 C      \ /   \       \ /   \
6919 C       o             o
6920 C       i             i
6921 C
6922 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6923 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6924 C AL 7/4/01 s1 would occur in the sixth-order moment,
6925 C           but not in a cluster cumulant
6926 #ifdef MOMENT
6927       s1=dip(1,jj,i)*dip(1,kk,k)
6928 #endif
6929       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6930       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6931       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6932       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6933       call transpose2(EUg(1,1,k),auxmat(1,1))
6934       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6935       vv(1)=pizda(1,1)-pizda(2,2)
6936       vv(2)=pizda(1,2)+pizda(2,1)
6937       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6938 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6939 #ifdef MOMENT
6940       eello6_graph2=-(s1+s2+s3+s4)
6941 #else
6942       eello6_graph2=-(s2+s3+s4)
6943 #endif
6944 c      eello6_graph2=-s3
6945 C Derivatives in gamma(i-1)
6946       if (i.gt.1) then
6947 #ifdef MOMENT
6948         s1=dipderg(1,jj,i)*dip(1,kk,k)
6949 #endif
6950         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6951         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6952         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6953         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6954 #ifdef MOMENT
6955         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6956 #else
6957         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6958 #endif
6959 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6960       endif
6961 C Derivatives in gamma(k-1)
6962 #ifdef MOMENT
6963       s1=dip(1,jj,i)*dipderg(1,kk,k)
6964 #endif
6965       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6966       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6967       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6968       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6969       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6970       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6971       vv(1)=pizda(1,1)-pizda(2,2)
6972       vv(2)=pizda(1,2)+pizda(2,1)
6973       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6974 #ifdef MOMENT
6975       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6976 #else
6977       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6978 #endif
6979 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6980 C Derivatives in gamma(j-1) or gamma(l-1)
6981       if (j.gt.1) then
6982 #ifdef MOMENT
6983         s1=dipderg(3,jj,i)*dip(1,kk,k)
6984 #endif
6985         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6986         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6987         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6988         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6989         vv(1)=pizda(1,1)-pizda(2,2)
6990         vv(2)=pizda(1,2)+pizda(2,1)
6991         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6992 #ifdef MOMENT
6993         if (swap) then
6994           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6995         else
6996           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6997         endif
6998 #endif
6999         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7000 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7001       endif
7002 C Derivatives in gamma(l-1) or gamma(j-1)
7003       if (l.gt.1) then
7004 #ifdef MOMENT
7005         s1=dip(1,jj,i)*dipderg(3,kk,k)
7006 #endif
7007         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7008         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7009         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7010         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7011         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7012         vv(1)=pizda(1,1)-pizda(2,2)
7013         vv(2)=pizda(1,2)+pizda(2,1)
7014         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7015 #ifdef MOMENT
7016         if (swap) then
7017           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7018         else
7019           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7020         endif
7021 #endif
7022         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7023 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7024       endif
7025 C Cartesian derivatives.
7026       if (lprn) then
7027         write (2,*) 'In eello6_graph2'
7028         do iii=1,2
7029           write (2,*) 'iii=',iii
7030           do kkk=1,5
7031             write (2,*) 'kkk=',kkk
7032             do jjj=1,2
7033               write (2,'(3(2f10.5),5x)')
7034      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7035             enddo
7036           enddo
7037         enddo
7038       endif
7039       do iii=1,2
7040         do kkk=1,5
7041           do lll=1,3
7042 #ifdef MOMENT
7043             if (iii.eq.1) then
7044               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7045             else
7046               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7047             endif
7048 #endif
7049             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7050      &        auxvec(1))
7051             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7052             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7053      &        auxvec(1))
7054             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7055             call transpose2(EUg(1,1,k),auxmat(1,1))
7056             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7057      &        pizda(1,1))
7058             vv(1)=pizda(1,1)-pizda(2,2)
7059             vv(2)=pizda(1,2)+pizda(2,1)
7060             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7061 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7062 #ifdef MOMENT
7063             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7064 #else
7065             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7066 #endif
7067             if (swap) then
7068               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7069             else
7070               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7071             endif
7072           enddo
7073         enddo
7074       enddo
7075       return
7076       end
7077 c----------------------------------------------------------------------------
7078       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7079       implicit real*8 (a-h,o-z)
7080       include 'DIMENSIONS'
7081       include 'COMMON.IOUNITS'
7082       include 'COMMON.CHAIN'
7083       include 'COMMON.DERIV'
7084       include 'COMMON.INTERACT'
7085       include 'COMMON.CONTACTS'
7086       include 'COMMON.TORSION'
7087       include 'COMMON.VAR'
7088       include 'COMMON.GEO'
7089       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7090       logical swap
7091 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7092 C
7093 C      Parallel       Antiparallel
7094 C
7095 C          o             o
7096 C         /l\   /   \   /j\
7097 C        /   \ /     \ /   \
7098 C       /| o |o       o| o |\
7099 C       j|/k\|  /      |/k\|l /
7100 C        /   \ /       /   \ /
7101 C       /     o       /     o
7102 C       i             i
7103 C
7104 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7105 C
7106 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7107 C           energy moment and not to the cluster cumulant.
7108       iti=itortyp(itype(i))
7109       if (j.lt.nres-1) then
7110         itj1=itortyp(itype(j+1))
7111       else
7112         itj1=ntortyp+1
7113       endif
7114       itk=itortyp(itype(k))
7115       itk1=itortyp(itype(k+1))
7116       if (l.lt.nres-1) then
7117         itl1=itortyp(itype(l+1))
7118       else
7119         itl1=ntortyp+1
7120       endif
7121 #ifdef MOMENT
7122       s1=dip(4,jj,i)*dip(4,kk,k)
7123 #endif
7124       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7125       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7126       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7127       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7128       call transpose2(EE(1,1,itk),auxmat(1,1))
7129       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7130       vv(1)=pizda(1,1)+pizda(2,2)
7131       vv(2)=pizda(2,1)-pizda(1,2)
7132       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7133 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7134 #ifdef MOMENT
7135       eello6_graph3=-(s1+s2+s3+s4)
7136 #else
7137       eello6_graph3=-(s2+s3+s4)
7138 #endif
7139 c      eello6_graph3=-s4
7140 C Derivatives in gamma(k-1)
7141       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7142       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7143       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7144       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7145 C Derivatives in gamma(l-1)
7146       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7147       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7148       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7149       vv(1)=pizda(1,1)+pizda(2,2)
7150       vv(2)=pizda(2,1)-pizda(1,2)
7151       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7152       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7153 C Cartesian derivatives.
7154       do iii=1,2
7155         do kkk=1,5
7156           do lll=1,3
7157 #ifdef MOMENT
7158             if (iii.eq.1) then
7159               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7160             else
7161               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7162             endif
7163 #endif
7164             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7165      &        auxvec(1))
7166             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7167             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7168      &        auxvec(1))
7169             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7170             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7171      &        pizda(1,1))
7172             vv(1)=pizda(1,1)+pizda(2,2)
7173             vv(2)=pizda(2,1)-pizda(1,2)
7174             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7175 #ifdef MOMENT
7176             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7177 #else
7178             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7179 #endif
7180             if (swap) then
7181               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7182             else
7183               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7184             endif
7185 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7186           enddo
7187         enddo
7188       enddo
7189       return
7190       end
7191 c----------------------------------------------------------------------------
7192       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7193       implicit real*8 (a-h,o-z)
7194       include 'DIMENSIONS'
7195       include 'COMMON.IOUNITS'
7196       include 'COMMON.CHAIN'
7197       include 'COMMON.DERIV'
7198       include 'COMMON.INTERACT'
7199       include 'COMMON.CONTACTS'
7200       include 'COMMON.TORSION'
7201       include 'COMMON.VAR'
7202       include 'COMMON.GEO'
7203       include 'COMMON.FFIELD'
7204       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7205      & auxvec1(2),auxmat1(2,2)
7206       logical swap
7207 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7208 C
7209 C      Parallel       Antiparallel
7210 C
7211 C          o             o
7212 C         /l\   /   \   /j\
7213 C        /   \ /     \ /   \
7214 C       /| o |o       o| o |\
7215 C     \ j|/k\|      \  |/k\|l
7216 C      \ /   \       \ /   \
7217 C       o     \       o     \
7218 C       i             i
7219 C
7220 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7221 C
7222 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7223 C           energy moment and not to the cluster cumulant.
7224 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7225       iti=itortyp(itype(i))
7226       itj=itortyp(itype(j))
7227       if (j.lt.nres-1) then
7228         itj1=itortyp(itype(j+1))
7229       else
7230         itj1=ntortyp+1
7231       endif
7232       itk=itortyp(itype(k))
7233       if (k.lt.nres-1) then
7234         itk1=itortyp(itype(k+1))
7235       else
7236         itk1=ntortyp+1
7237       endif
7238       itl=itortyp(itype(l))
7239       if (l.lt.nres-1) then
7240         itl1=itortyp(itype(l+1))
7241       else
7242         itl1=ntortyp+1
7243       endif
7244 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7245 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7246 cd     & ' itl',itl,' itl1',itl1
7247 #ifdef MOMENT
7248       if (imat.eq.1) then
7249         s1=dip(3,jj,i)*dip(3,kk,k)
7250       else
7251         s1=dip(2,jj,j)*dip(2,kk,l)
7252       endif
7253 #endif
7254       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7255       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7256       if (j.eq.l+1) then
7257         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7258         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7259       else
7260         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7261         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7262       endif
7263       call transpose2(EUg(1,1,k),auxmat(1,1))
7264       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7265       vv(1)=pizda(1,1)-pizda(2,2)
7266       vv(2)=pizda(2,1)+pizda(1,2)
7267       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7268 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7269 #ifdef MOMENT
7270       eello6_graph4=-(s1+s2+s3+s4)
7271 #else
7272       eello6_graph4=-(s2+s3+s4)
7273 #endif
7274 C Derivatives in gamma(i-1)
7275       if (i.gt.1) then
7276 #ifdef MOMENT
7277         if (imat.eq.1) then
7278           s1=dipderg(2,jj,i)*dip(3,kk,k)
7279         else
7280           s1=dipderg(4,jj,j)*dip(2,kk,l)
7281         endif
7282 #endif
7283         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7284         if (j.eq.l+1) then
7285           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7286           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7287         else
7288           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7289           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7290         endif
7291         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7292         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7293 cd          write (2,*) 'turn6 derivatives'
7294 #ifdef MOMENT
7295           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7296 #else
7297           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7298 #endif
7299         else
7300 #ifdef MOMENT
7301           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7302 #else
7303           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7304 #endif
7305         endif
7306       endif
7307 C Derivatives in gamma(k-1)
7308 #ifdef MOMENT
7309       if (imat.eq.1) then
7310         s1=dip(3,jj,i)*dipderg(2,kk,k)
7311       else
7312         s1=dip(2,jj,j)*dipderg(4,kk,l)
7313       endif
7314 #endif
7315       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7316       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7317       if (j.eq.l+1) then
7318         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7319         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7320       else
7321         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7322         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7323       endif
7324       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7325       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7326       vv(1)=pizda(1,1)-pizda(2,2)
7327       vv(2)=pizda(2,1)+pizda(1,2)
7328       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7329       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7330 #ifdef MOMENT
7331         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7332 #else
7333         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7334 #endif
7335       else
7336 #ifdef MOMENT
7337         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7338 #else
7339         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7340 #endif
7341       endif
7342 C Derivatives in gamma(j-1) or gamma(l-1)
7343       if (l.eq.j+1 .and. l.gt.1) then
7344         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7345         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7346         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7347         vv(1)=pizda(1,1)-pizda(2,2)
7348         vv(2)=pizda(2,1)+pizda(1,2)
7349         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7350         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7351       else if (j.gt.1) then
7352         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7353         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7354         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7355         vv(1)=pizda(1,1)-pizda(2,2)
7356         vv(2)=pizda(2,1)+pizda(1,2)
7357         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7358         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7359           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7360         else
7361           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7362         endif
7363       endif
7364 C Cartesian derivatives.
7365       do iii=1,2
7366         do kkk=1,5
7367           do lll=1,3
7368 #ifdef MOMENT
7369             if (iii.eq.1) then
7370               if (imat.eq.1) then
7371                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7372               else
7373                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7374               endif
7375             else
7376               if (imat.eq.1) then
7377                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7378               else
7379                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7380               endif
7381             endif
7382 #endif
7383             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7384      &        auxvec(1))
7385             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7386             if (j.eq.l+1) then
7387               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7388      &          b1(1,itj1),auxvec(1))
7389               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7390             else
7391               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7392      &          b1(1,itl1),auxvec(1))
7393               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7394             endif
7395             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7396      &        pizda(1,1))
7397             vv(1)=pizda(1,1)-pizda(2,2)
7398             vv(2)=pizda(2,1)+pizda(1,2)
7399             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7400             if (swap) then
7401               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7402 #ifdef MOMENT
7403                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7404      &             -(s1+s2+s4)
7405 #else
7406                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7407      &             -(s2+s4)
7408 #endif
7409                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7410               else
7411 #ifdef MOMENT
7412                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7413 #else
7414                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7415 #endif
7416                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7417               endif
7418             else
7419 #ifdef MOMENT
7420               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7421 #else
7422               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7423 #endif
7424               if (l.eq.j+1) then
7425                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7426               else
7427                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7428               endif
7429             endif
7430           enddo
7431         enddo
7432       enddo
7433       return
7434       end
7435 c----------------------------------------------------------------------------
7436       double precision function eello_turn6(i,jj,kk)
7437       implicit real*8 (a-h,o-z)
7438       include 'DIMENSIONS'
7439       include 'COMMON.IOUNITS'
7440       include 'COMMON.CHAIN'
7441       include 'COMMON.DERIV'
7442       include 'COMMON.INTERACT'
7443       include 'COMMON.CONTACTS'
7444       include 'COMMON.TORSION'
7445       include 'COMMON.VAR'
7446       include 'COMMON.GEO'
7447       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7448      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7449      &  ggg1(3),ggg2(3)
7450       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7451      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7452 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7453 C           the respective energy moment and not to the cluster cumulant.
7454       s1=0.0d0
7455       s8=0.0d0
7456       s13=0.0d0
7457 c
7458       eello_turn6=0.0d0
7459       j=i+4
7460       k=i+1
7461       l=i+3
7462       iti=itortyp(itype(i))
7463       itk=itortyp(itype(k))
7464       itk1=itortyp(itype(k+1))
7465       itl=itortyp(itype(l))
7466       itj=itortyp(itype(j))
7467 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7468 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7469 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7470 cd        eello6=0.0d0
7471 cd        return
7472 cd      endif
7473 cd      write (iout,*)
7474 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7475 cd     &   ' and',k,l
7476 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7477       do iii=1,2
7478         do kkk=1,5
7479           do lll=1,3
7480             derx_turn(lll,kkk,iii)=0.0d0
7481           enddo
7482         enddo
7483       enddo
7484 cd      eij=1.0d0
7485 cd      ekl=1.0d0
7486 cd      ekont=1.0d0
7487       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7488 cd      eello6_5=0.0d0
7489 cd      write (2,*) 'eello6_5',eello6_5
7490 #ifdef MOMENT
7491       call transpose2(AEA(1,1,1),auxmat(1,1))
7492       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7493       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7494       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7495 #endif
7496       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7497       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7498       s2 = scalar2(b1(1,itk),vtemp1(1))
7499 #ifdef MOMENT
7500       call transpose2(AEA(1,1,2),atemp(1,1))
7501       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7502       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7503       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7504 #endif
7505       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7506       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7507       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7508 #ifdef MOMENT
7509       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7510       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7511       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7512       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7513       ss13 = scalar2(b1(1,itk),vtemp4(1))
7514       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7515 #endif
7516 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7517 c      s1=0.0d0
7518 c      s2=0.0d0
7519 c      s8=0.0d0
7520 c      s12=0.0d0
7521 c      s13=0.0d0
7522       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7523 C Derivatives in gamma(i+2)
7524       s1d =0.0d0
7525       s8d =0.0d0
7526 #ifdef MOMENT
7527       call transpose2(AEA(1,1,1),auxmatd(1,1))
7528       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7529       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7530       call transpose2(AEAderg(1,1,2),atempd(1,1))
7531       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7532       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7533 #endif
7534       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7535       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7536       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7537 c      s1d=0.0d0
7538 c      s2d=0.0d0
7539 c      s8d=0.0d0
7540 c      s12d=0.0d0
7541 c      s13d=0.0d0
7542       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7543 C Derivatives in gamma(i+3)
7544 #ifdef MOMENT
7545       call transpose2(AEA(1,1,1),auxmatd(1,1))
7546       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7547       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7548       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7549 #endif
7550       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7551       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7552       s2d = scalar2(b1(1,itk),vtemp1d(1))
7553 #ifdef MOMENT
7554       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7555       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7556 #endif
7557       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7558 #ifdef MOMENT
7559       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7560       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7561       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7562 #endif
7563 c      s1d=0.0d0
7564 c      s2d=0.0d0
7565 c      s8d=0.0d0
7566 c      s12d=0.0d0
7567 c      s13d=0.0d0
7568 #ifdef MOMENT
7569       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7570      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7571 #else
7572       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7573      &               -0.5d0*ekont*(s2d+s12d)
7574 #endif
7575 C Derivatives in gamma(i+4)
7576       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7577       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7578       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7579 #ifdef MOMENT
7580       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7581       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7582       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7583 #endif
7584 c      s1d=0.0d0
7585 c      s2d=0.0d0
7586 c      s8d=0.0d0
7587 C      s12d=0.0d0
7588 c      s13d=0.0d0
7589 #ifdef MOMENT
7590       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7591 #else
7592       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7593 #endif
7594 C Derivatives in gamma(i+5)
7595 #ifdef MOMENT
7596       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7597       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7598       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7599 #endif
7600       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7601       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7602       s2d = scalar2(b1(1,itk),vtemp1d(1))
7603 #ifdef MOMENT
7604       call transpose2(AEA(1,1,2),atempd(1,1))
7605       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7606       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7607 #endif
7608       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7609       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7610 #ifdef MOMENT
7611       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7612       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7613       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7614 #endif
7615 c      s1d=0.0d0
7616 c      s2d=0.0d0
7617 c      s8d=0.0d0
7618 c      s12d=0.0d0
7619 c      s13d=0.0d0
7620 #ifdef MOMENT
7621       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7622      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7623 #else
7624       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7625      &               -0.5d0*ekont*(s2d+s12d)
7626 #endif
7627 C Cartesian derivatives
7628       do iii=1,2
7629         do kkk=1,5
7630           do lll=1,3
7631 #ifdef MOMENT
7632             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7633             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7634             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7635 #endif
7636             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7637             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7638      &          vtemp1d(1))
7639             s2d = scalar2(b1(1,itk),vtemp1d(1))
7640 #ifdef MOMENT
7641             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7642             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7643             s8d = -(atempd(1,1)+atempd(2,2))*
7644      &           scalar2(cc(1,1,itl),vtemp2(1))
7645 #endif
7646             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7647      &           auxmatd(1,1))
7648             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7649             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7650 c      s1d=0.0d0
7651 c      s2d=0.0d0
7652 c      s8d=0.0d0
7653 c      s12d=0.0d0
7654 c      s13d=0.0d0
7655 #ifdef MOMENT
7656             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7657      &        - 0.5d0*(s1d+s2d)
7658 #else
7659             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7660      &        - 0.5d0*s2d
7661 #endif
7662 #ifdef MOMENT
7663             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7664      &        - 0.5d0*(s8d+s12d)
7665 #else
7666             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7667      &        - 0.5d0*s12d
7668 #endif
7669           enddo
7670         enddo
7671       enddo
7672 #ifdef MOMENT
7673       do kkk=1,5
7674         do lll=1,3
7675           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7676      &      achuj_tempd(1,1))
7677           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7678           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7679           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7680           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7681           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7682      &      vtemp4d(1))
7683           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7684           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7685           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7686         enddo
7687       enddo
7688 #endif
7689 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7690 cd     &  16*eel_turn6_num
7691 cd      goto 1112
7692       if (j.lt.nres-1) then
7693         j1=j+1
7694         j2=j-1
7695       else
7696         j1=j-1
7697         j2=j-2
7698       endif
7699       if (l.lt.nres-1) then
7700         l1=l+1
7701         l2=l-1
7702       else
7703         l1=l-1
7704         l2=l-2
7705       endif
7706       do ll=1,3
7707         ggg1(ll)=eel_turn6*g_contij(ll,1)
7708         ggg2(ll)=eel_turn6*g_contij(ll,2)
7709         ghalf=0.5d0*ggg1(ll)
7710 cd        ghalf=0.0d0
7711         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7712      &    +ekont*derx_turn(ll,2,1)
7713         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7714         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7715      &    +ekont*derx_turn(ll,4,1)
7716         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7717         ghalf=0.5d0*ggg2(ll)
7718 cd        ghalf=0.0d0
7719         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7720      &    +ekont*derx_turn(ll,2,2)
7721         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7722         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7723      &    +ekont*derx_turn(ll,4,2)
7724         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7725       enddo
7726 cd      goto 1112
7727       do m=i+1,j-1
7728         do ll=1,3
7729           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7730         enddo
7731       enddo
7732       do m=k+1,l-1
7733         do ll=1,3
7734           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7735         enddo
7736       enddo
7737 1112  continue
7738       do m=i+2,j2
7739         do ll=1,3
7740           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7741         enddo
7742       enddo
7743       do m=k+2,l2
7744         do ll=1,3
7745           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7746         enddo
7747       enddo
7748 cd      do iii=1,nres-3
7749 cd        write (2,*) iii,g_corr6_loc(iii)
7750 cd      enddo
7751       eello_turn6=ekont*eel_turn6
7752 cd      write (2,*) 'ekont',ekont
7753 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7754       return
7755       end
7756
7757 C-----------------------------------------------------------------------------
7758       double precision function scalar(u,v)
7759 !DIR$ INLINEALWAYS scalar
7760 #ifndef OSF
7761 cDEC$ ATTRIBUTES FORCEINLINE::scalar
7762 #endif
7763       implicit none
7764       double precision u(3),v(3)
7765 cd      double precision sc
7766 cd      integer i
7767 cd      sc=0.0d0
7768 cd      do i=1,3
7769 cd        sc=sc+u(i)*v(i)
7770 cd      enddo
7771 cd      scalar=sc
7772
7773       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
7774       return
7775       end
7776 crc-------------------------------------------------
7777       SUBROUTINE MATVEC2(A1,V1,V2)
7778 !DIR$ INLINEALWAYS MATVEC2
7779 #ifndef OSF
7780 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
7781 #endif
7782       implicit real*8 (a-h,o-z)
7783       include 'DIMENSIONS'
7784       DIMENSION A1(2,2),V1(2),V2(2)
7785 c      DO 1 I=1,2
7786 c        VI=0.0
7787 c        DO 3 K=1,2
7788 c    3     VI=VI+A1(I,K)*V1(K)
7789 c        Vaux(I)=VI
7790 c    1 CONTINUE
7791
7792       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7793       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7794
7795       v2(1)=vaux1
7796       v2(2)=vaux2
7797       END
7798 C---------------------------------------
7799       SUBROUTINE MATMAT2(A1,A2,A3)
7800 #ifndef OSF
7801 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
7802 #endif
7803       implicit real*8 (a-h,o-z)
7804       include 'DIMENSIONS'
7805       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7806 c      DIMENSION AI3(2,2)
7807 c        DO  J=1,2
7808 c          A3IJ=0.0
7809 c          DO K=1,2
7810 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7811 c          enddo
7812 c          A3(I,J)=A3IJ
7813 c       enddo
7814 c      enddo
7815
7816       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7817       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7818       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7819       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7820
7821       A3(1,1)=AI3_11
7822       A3(2,1)=AI3_21
7823       A3(1,2)=AI3_12
7824       A3(2,2)=AI3_22
7825       END
7826
7827 c-------------------------------------------------------------------------
7828       double precision function scalar2(u,v)
7829 !DIR$ INLINEALWAYS scalar2
7830       implicit none
7831       double precision u(2),v(2)
7832       double precision sc
7833       integer i
7834       scalar2=u(1)*v(1)+u(2)*v(2)
7835       return
7836       end
7837
7838 C-----------------------------------------------------------------------------
7839
7840       subroutine transpose2(a,at)
7841 !DIR$ INLINEALWAYS transpose2
7842 #ifndef OSF
7843 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
7844 #endif
7845       implicit none
7846       double precision a(2,2),at(2,2)
7847       at(1,1)=a(1,1)
7848       at(1,2)=a(2,1)
7849       at(2,1)=a(1,2)
7850       at(2,2)=a(2,2)
7851       return
7852       end
7853 c--------------------------------------------------------------------------
7854       subroutine transpose(n,a,at)
7855       implicit none
7856       integer n,i,j
7857       double precision a(n,n),at(n,n)
7858       do i=1,n
7859         do j=1,n
7860           at(j,i)=a(i,j)
7861         enddo
7862       enddo
7863       return
7864       end
7865 C---------------------------------------------------------------------------
7866       subroutine prodmat3(a1,a2,kk,transp,prod)
7867 !DIR$ INLINEALWAYS prodmat3
7868 #ifndef OSF
7869 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
7870 #endif
7871       implicit none
7872       integer i,j
7873       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7874       logical transp
7875 crc      double precision auxmat(2,2),prod_(2,2)
7876
7877       if (transp) then
7878 crc        call transpose2(kk(1,1),auxmat(1,1))
7879 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7880 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7881
7882            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7883      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7884            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7885      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7886            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7887      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7888            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7889      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7890
7891       else
7892 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7893 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7894
7895            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7896      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7897            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7898      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7899            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7900      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7901            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7902      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7903
7904       endif
7905 c      call transpose2(a2(1,1),a2t(1,1))
7906
7907 crc      print *,transp
7908 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7909 crc      print *,((prod(i,j),i=1,2),j=1,2)
7910
7911       return
7912       end
7913