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 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85 c        call chainbuild_cart
  86       endif
  87 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  88 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  89 #else
  90 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  91 c        call int_from_cart1(.false.)
  92 c      endif
  93 #endif
  94 C
  95 C Compute the side-chain and electrostatic interaction energy
  96 C
  97       goto (101,102,103,104,105,106) ipot
  98 C Lennard-Jones potential.
  99   101 call elj(evdw)
 100 cd    print '(a)','Exit ELJ'
 101       goto 107
 102 C Lennard-Jones-Kihara potential (shifted).
 103   102 call eljk(evdw)
 104       goto 107
 105 C Berne-Pechukas potential (dilated LJ, angular dependence).
 106   103 call ebp(evdw)
 107       goto 107
 108 C Gay-Berne potential (shifted LJ, angular dependence).
 109   104 call egb(evdw)
 110       goto 107
 111 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 112   105 call egbv(evdw)
 113       goto 107
 114 C Soft-sphere potential
 115   106 call e_softsphere(evdw)
 116 C
 117 C Calculate electrostatic (H-bonding) energy of the main chain.
 118 C
 119   107 continue
 120 c      print *,"Processor",myrank," computed USCSC"
 121       call vec_and_deriv
 122 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 123       if (ipot.lt.6) then
 124 #ifdef SPLITELE
 125          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 126      &       wturn3.gt.0d0.or.wturn4.gt.0d0) then
 127 #else
 128          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 129      &       wturn3.gt.0d0.or.wturn4.gt.0d0) then
 130 #endif
 131             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 132          else
 133             ees=0
 134             evdw1=0
 135             eel_loc=0
 136             eello_turn3=0
 137             eello_turn4=0
 138          endif
 139       else
 140 c        write (iout,*) "Soft-spheer ELEC potential"
 141         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 142      &   eello_turn4)
 143       endif
 144 c      print *,"Processor",myrank," computed UELEC"
 145 C
 146 C Calculate excluded-volume interaction energy between peptide groups
 147 C and side chains.
 148 C
 149       if (ipot.lt.6) then
 150        if(wscp.gt.0d0) then
 151         call escp(evdw2,evdw2_14)
 152        else
 153         evdw2=0
 154         evdw2_14=0
 155        endif
 156       else
 157 c        write (iout,*) "Soft-sphere SCP potential"
 158         call escp_soft_sphere(evdw2,evdw2_14)
 159       endif
 160 c
 161 c Calculate the bond-stretching energy
 162 c
 163       call ebond(estr)
 164 C
 165 C Calculate the disulfide-bridge and other energy and the contributions
 166 C from other distance constraints.
 167 cd    print *,'Calling EHPB'
 168       call edis(ehpb)
 169 cd    print *,'EHPB exitted succesfully.'
 170 C
 171 C Calculate the virtual-bond-angle energy.
 172 C
 173       if (wang.gt.0d0) then
 174         call ebend(ebe)
 175       else
 176         ebe=0
 177       endif
 178 c      print *,"Processor",myrank," computed UB"
 179 C
 180 C Calculate the SC local energy.
 181 C
 182       call esc(escloc)
 183 c      print *,"Processor",myrank," computed USC"
 184 C
 185 C Calculate the virtual-bond torsional energy.
 186 C
 187 cd    print *,'nterm=',nterm
 188       if (wtor.gt.0) then
 189        call etor(etors,edihcnstr)
 190       else
 191        etors=0
 192        edihcnstr=0
 193       endif
 194 c      print *,"Processor",myrank," computed Utor"
 195 C
 196 C 6/23/01 Calculate double-torsional energy
 197 C
 198       if (wtor_d.gt.0) then
 199        call etor_d(etors_d)
 200       else
 201        etors_d=0
 202       endif
 203 c      print *,"Processor",myrank," computed Utord"
 204 C
 205 C 21/5/07 Calculate local sicdechain correlation energy
 206 C
 207       if (wsccor.gt.0.0d0) then
 208         call eback_sc_corr(esccor)
 209       else
 210         esccor=0.0d0
 211       endif
 212 c      print *,"Processor",myrank," computed Usccorr"
 213 C
 214 C 12/1/95 Multi-body terms
 215 C
 216       n_corr=0
 217       n_corr1=0
 218       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 219      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 220          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 221 c         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
 222 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 223       else
 224          ecorr=0
 225          ecorr5=0
 226          ecorr6=0
 227          eturn6=0
 228       endif
 229       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 230          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 231       else
 232          ecorr=0
 233          ecorr5=0
 234          ecorr6=0
 235          eturn6=0
 236       endif
 237 c      print *,"Processor",myrank," computed Ucorr"
 238 C
 239 C If performing constraint dynamics, call the constraint energy
 240 C  after the equilibration time
 241       if(usampl.and.totT.gt.eq_time) then
 242          call EconstrQ
 243          call Econstr_back
 244       else
 245          Uconst=0.0d0
 246          Uconst_back=0.0d0
 247       endif
 248 c      print *,"Processor",myrank," computed Uconstr"
 249 c
 250 C Sum the energies
 251 C
 252       energia(1)=evdw
 253 #ifdef SCP14
 254       energia(2)=evdw2-evdw2_14
 255       energia(18)=evdw2_14
 256 #else
 257       energia(2)=evdw2
 258       energia(18)=0.0d0
 259 #endif
 260 #ifdef SPLITELE
 261       energia(3)=ees
 262       energia(16)=evdw1
 263 #else
 264       energia(3)=ees+evdw1
 265       energia(16)=0.0d0
 266 #endif
 267       energia(4)=ecorr
 268       energia(5)=ecorr5
 269       energia(6)=ecorr6
 270       energia(7)=eel_loc
 271       energia(8)=eello_turn3
 272       energia(9)=eello_turn4
 273       energia(10)=eturn6
 274       energia(11)=ebe
 275       energia(12)=escloc
 276       energia(13)=etors
 277       energia(14)=etors_d
 278       energia(15)=ehpb
 279       energia(19)=edihcnstr
 280       energia(17)=estr
 281       energia(20)=Uconst+Uconst_back
 282       energia(21)=esccor
 283 c      print *," Processor",myrank," calls SUM_ENERGY"
 284       call sum_energy(energia,.true.)
 285 c      print *," Processor",myrank," left SUM_ENERGY"
 286       return
 287       end
 288 c-------------------------------------------------------------------------------
 289       subroutine sum_energy(energia,reduce)
 290       implicit real*8 (a-h,o-z)
 291       include 'DIMENSIONS'
 292 #ifndef ISNAN
 293       external proc_proc
 294 #ifdef WINPGI
 295 cMS$ATTRIBUTES C ::  proc_proc
 296 #endif
 297 #endif
 298 #ifdef MPI
 299       include "mpif.h"
 300 #endif
 301       include 'COMMON.SETUP'
 302       include 'COMMON.IOUNITS'
 303       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 304       include 'COMMON.FFIELD'
 305       include 'COMMON.DERIV'
 306       include 'COMMON.INTERACT'
 307       include 'COMMON.SBRIDGE'
 308       include 'COMMON.CHAIN'
 309       include 'COMMON.VAR'
 310       include 'COMMON.CONTROL'
 311       include 'COMMON.TIME1'
 312       logical reduce
 313 #ifdef MPI
 314       if (nfgtasks.gt.1 .and. reduce) then
 315 #ifdef DEBUG
 316         write (iout,*) "energies before REDUCE"
 317         call enerprint(energia)
 318         call flush(iout)
 319 #endif
 320         do i=0,n_ene
 321           enebuff(i)=energia(i)
 322         enddo
 323         time00=MPI_Wtime()
 324         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 325      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 326 #ifdef DEBUG
 327         write (iout,*) "energies after REDUCE"
 328         call enerprint(energia)
 329         call flush(iout)
 330 #endif
 331         time_Reduce=time_Reduce+MPI_Wtime()-time00
 332       endif
 333       if (fg_rank.eq.0) then
 334 #endif
 335       evdw=energia(1)
 336 #ifdef SCP14
 337       evdw2=energia(2)+energia(18)
 338       evdw2_14=energia(18)
 339 #else
 340       evdw2=energia(2)
 341 #endif
 342 #ifdef SPLITELE
 343       ees=energia(3)
 344       evdw1=energia(16)
 345 #else
 346       ees=energia(3)
 347       evdw1=0.0d0
 348 #endif
 349       ecorr=energia(4)
 350       ecorr5=energia(5)
 351       ecorr6=energia(6)
 352       eel_loc=energia(7)
 353       eello_turn3=energia(8)
 354       eello_turn4=energia(9)
 355       eturn6=energia(10)
 356       ebe=energia(11)
 357       escloc=energia(12)
 358       etors=energia(13)
 359       etors_d=energia(14)
 360       ehpb=energia(15)
 361       edihcnstr=energia(19)
 362       estr=energia(17)
 363       Uconst=energia(20)
 364       esccor=energia(21)
 365 #ifdef SPLITELE
 366       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 367      & +wang*ebe+wtor*etors+wscloc*escloc
 368      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 369      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 370      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 371      & +wbond*estr+Uconst+wsccor*esccor
 372 #else
 373       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 374      & +wang*ebe+wtor*etors+wscloc*escloc
 375      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 376      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 377      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 378      & +wbond*estr+Uconst+wsccor*esccor
 379 #endif
 380       energia(0)=etot
 381 c detecting NaNQ
 382 #ifdef ISNAN
 383 #ifdef AIX
 384       if (isnan(etot).ne.0) energia(0)=1.0d+99
 385 #else
 386       if (isnan(etot)) energia(0)=1.0d+99
 387 #endif
 388 #else
 389       i=0
 390 #ifdef WINPGI
 391       idumm=proc_proc(etot,i)
 392 #else
 393       call proc_proc(etot,i)
 394 #endif
 395       if(i.eq.1)energia(0)=1.0d+99
 396 #endif
 397 #ifdef MPI
 398       endif
 399 #endif
 400       return
 401       end
 402 c-------------------------------------------------------------------------------
 403       subroutine sum_gradient
 404       implicit real*8 (a-h,o-z)
 405       include 'DIMENSIONS'
 406 #ifndef ISNAN
 407       external proc_proc
 408 #ifdef WINPGI
 409 cMS$ATTRIBUTES C ::  proc_proc
 410 #endif
 411 #endif
 412 #ifdef MPI
 413       include 'mpif.h'
 414       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 415      &  glocbuf(4*maxres)
 416 #endif
 417       include 'COMMON.SETUP'
 418       include 'COMMON.IOUNITS'
 419       include 'COMMON.FFIELD'
 420       include 'COMMON.DERIV'
 421       include 'COMMON.INTERACT'
 422       include 'COMMON.SBRIDGE'
 423       include 'COMMON.CHAIN'
 424       include 'COMMON.VAR'
 425       include 'COMMON.CONTROL'
 426       include 'COMMON.TIME1'
 427       include 'COMMON.MAXGRAD'
 428 C
 429 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 430 C            in virtual-bond-vector coordinates
 431 C
 432       write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 433       do i=1,nres-1
 434         write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 435      &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 436       enddo
 437       do i=nnt,nres-1
 438         do k=1,3
 439           gvdwc(k,i)=0.0d0
 440           gvdwc_scp(k,i)=0.0d0
 441         enddo
 442         do j=i+1,nres
 443           do k=1,3
 444             gvdwc(k,i)=gvdwc(k,i)+gvdwc(k,j)
 445             gvdwc_scp(k,i)=gvdwc_scp(k,i)+gvdwc_scp(k,j)
 446           enddo
 447         enddo
 448       enddo
 449       do i=nnt,nct-1
 450         do k=1,3
 451           gelc(k,i)=gelc(k,i)+0.5d0*gelc_long(k,i)
 452           gvdwpp(k,i)=0.5d0*gvdwpp(k,i)
 453 c          gel_loc(k,i)=gel_loc(k,i)+0.5d0*gel_loc_long(k,i)
 454           gvdwc_scp(k,i)=gvdwc_scp(k,i)+0.5d0*gvdwc_scpp(k,i)
 455         enddo
 456         do j=i+1,nct-1
 457           do k=1,3
 458             gelc(k,i)=gelc(k,i)+gelc_long(k,j)
 459             gvdwpp(k,i)=gvdwpp(k,i)+gvdwpp(k,j)
 460 c            if (i.lt.nres-2) then
 461 c              gel_loc(k,i)=gel_loc(k,i)+gel_loc_long(k,j)
 462 c            else
 463 c              gel_loc(k,i)=gel_loc(k,i)+gel_loc_long_j2(k,j)
 464 c            endif
 465             gvdwc_scp(k,i)=gvdwc_scp(k,i)+gvdwc_scpp(k,j)
 466           enddo
 467         enddo
 468       enddo
 469       do i=nnt,nres-1
 470         do k=1,3
 471           gel_loc(k,i)=gel_loc(k,i)+0.5d0*gel_loc_long(k,i)
 472         enddo
 473         do j=i+1,nres-1
 474           do k=1,3
 475 c            if (i.lt.nres-2) then
 476               gel_loc(k,i)=gel_loc(k,i)+gel_loc_long(k,j)
 477 c            else
 478 c              gel_loc(k,i)=gel_loc(k,i)+gel_loc_long_j2(k,j)
 479 c            endif
 480           enddo
 481         enddo
 482       enddo
 483       do k=1,3
 484         gvdwc_scp(k,nres)=0.0d0
 485         gvdwc(k,nres)=0.0d0
 486         gel_loc(k,nct)=0.0d0
 487         gel_loc(k,nres)=0.0d0
 488       enddo
 489 C
 490 C Sum up the components of the Cartesian gradient.
 491 C
 492 #ifdef SPLITELE
 493       do i=1,nct
 494         do j=1,3
 495           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 496      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 497      &                wbond*gradb(j,i)+
 498      &                wstrain*ghpbc(j,i)+
 499      &                wcorr*gradcorr(j,i)+
 500      &                wel_loc*gel_loc(j,i)+
 501      &                wturn3*gcorr3_turn(j,i)+
 502      &                wturn4*gcorr4_turn(j,i)+
 503      &                wcorr5*gradcorr5(j,i)+
 504      &                wcorr6*gradcorr6(j,i)+
 505      &                wturn6*gcorr6_turn(j,i)+
 506      &                wsccor*gsccorc(j,i)
 507      &               +wscloc*gscloc(j,i)
 508           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 509      &                  wbond*gradbx(j,i)+
 510      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 511      &                  wsccor*gsccorx(j,i)
 512      &                 +wscloc*gsclocx(j,i)
 513         enddo
 514       enddo
 515 #else
 516       do i=1,nct
 517         do j=1,3
 518           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 519      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 520      &                wbond*gradb(j,i)+
 521      &                wcorr*gradcorr(j,i)+
 522      &                wel_loc*gel_loc(j,i)+
 523      &                wturn3*gcorr3_turn(j,i)+
 524      &                wturn4*gcorr4_turn(j,i)+
 525      &                wcorr5*gradcorr5(j,i)+
 526      &                wcorr6*gradcorr6(j,i)+
 527      &                wturn6*gcorr6_turn(j,i)+
 528      &                wsccor*gsccorc(j,i)
 529      &               +wscloc*gscloc(j,i)
 530           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 531      &                  wbond*gradbx(j,i)+
 532      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 533      &                  wsccor*gsccorx(j,i)
 534      &                 +wscloc*gsclocx(j,i)
 535         enddo
 536       enddo
 537 #endif
 538       do i=1,nres-3
 539         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 540      &   +wcorr5*g_corr5_loc(i)
 541      &   +wcorr6*g_corr6_loc(i)
 542      &   +wturn4*gel_loc_turn4(i)
 543      &   +wturn3*gel_loc_turn3(i)
 544      &   +wturn6*gel_loc_turn6(i)
 545      &   +wel_loc*gel_loc_loc(i)
 546      &   +wsccor*gsccor_loc(i)
 547       enddo
 548 #ifdef MPI
 549       if (nfgtasks.gt.1) then
 550         do j=1,3
 551           do i=1,nres
 552             gradbufc(j,i)=gradc(j,i,icg)
 553             gradbufx(j,i)=gradx(j,i,icg)
 554           enddo
 555         enddo
 556         do i=1,4*nres
 557           glocbuf(i)=gloc(i,icg)
 558         enddo
 559 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 560         if (fg_rank.eq.0) call MPI_Bcast(1,1,MPI_INTEGER,
 561      &      king,FG_COMM,IERROR)
 562         time00=MPI_Wtime()
 563         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 564      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 565         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 566      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 567         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 568      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 569         time_reduce=time_reduce+MPI_Wtime()-time00
 570       endif
 571 #endif
 572       if (gnorm_check) then
 573 c
 574 c Compute the maximum elements of the gradient
 575 c
 576       gvdwc_max=0.0d0
 577       gvdwc_scp_max=0.0d0
 578       gelc_max=0.0d0
 579       gvdwpp_max=0.0d0
 580       gradb_max=0.0d0
 581       ghpbc_max=0.0d0
 582       gradcorr_max=0.0d0
 583       gel_loc_max=0.0d0
 584       gcorr3_turn_max=0.0d0
 585       gcorr4_turn_max=0.0d0
 586       gradcorr5_max=0.0d0
 587       gradcorr6_max=0.0d0
 588       gcorr6_turn_max=0.0d0
 589       gsccorc_max=0.0d0
 590       gscloc_max=0.0d0
 591       gvdwx_max=0.0d0
 592       gradx_scp_max=0.0d0
 593       ghpbx_max=0.0d0
 594       gradxorr_max=0.0d0
 595       gsccorx_max=0.0d0
 596       gsclocx_max=0.0d0
 597       do i=1,nct
 598         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 599         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 600         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 601         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 602      &   gvdwc_scp_max=gvdwc_scp_norm
 603         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 604         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 605         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 606         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 607         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 608         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 609         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 610         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 611         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 612         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 613         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 614         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 615         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 616      &    gcorr3_turn(1,i)))
 617         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 618      &    gcorr3_turn_max=gcorr3_turn_norm
 619         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 620      &    gcorr4_turn(1,i)))
 621         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 622      &    gcorr4_turn_max=gcorr4_turn_norm
 623         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 624         if (gradcorr5_norm.gt.gradcorr5_max)
 625      &    gradcorr5_max=gradcorr5_norm
 626         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 627         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 628         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 629      &    gcorr6_turn(1,i)))
 630         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 631      &    gcorr6_turn_max=gcorr6_turn_norm
 632         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 633         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 634         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 635         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 636         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 637         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 638         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 639         if (gradx_scp_norm.gt.gradx_scp_max)
 640      &    gradx_scp_max=gradx_scp_norm
 641         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 642         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 643         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 644         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 645         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 646         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 647         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 648         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 649       enddo
 650       if (gradout) then
 651 #ifdef AIX
 652         open(istat,file=statname,position="append")
 653 #else
 654         open(istat,file=statname,access="append")
 655 #endif
 656         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 657      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 658      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 659      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 660      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 661      &     gsccorx_max,gsclocx_max
 662         close(istat)
 663         if (gvdwc_max.gt.1.0d4) then
 664           write (iout,*) "gvdwc gvdwx gradb gradbx"
 665           do i=nnt,nct
 666             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 667      &        gradb(j,i),gradbx(j,i),j=1,3)
 668           enddo
 669           call pdbout(0.0d0,'cipiszcze',iout)
 670           call flush(iout)
 671         endif
 672       endif
 673       endif
 674 #ifdef DEBUG
 675       write (iout,*) "gradc gradx gloc"
 676       do i=1,nres
 677         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 678      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 679       enddo
 680 #endif
 681       return
 682       end
 683 c-------------------------------------------------------------------------------
 684       subroutine rescale_weights(t_bath)
 685       implicit real*8 (a-h,o-z)
 686       include 'DIMENSIONS'
 687       include 'COMMON.IOUNITS'
 688       include 'COMMON.FFIELD'
 689       include 'COMMON.SBRIDGE'
 690       double precision kfac /2.4d0/
 691       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 692 c      facT=temp0/t_bath
 693 c      facT=2*temp0/(t_bath+temp0)
 694       if (rescale_mode.eq.0) then
 695         facT=1.0d0
 696         facT2=1.0d0
 697         facT3=1.0d0
 698         facT4=1.0d0
 699         facT5=1.0d0
 700       else if (rescale_mode.eq.1) then
 701         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 702         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 703         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 704         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 705         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 706       else if (rescale_mode.eq.2) then
 707         x=t_bath/temp0
 708         x2=x*x
 709         x3=x2*x
 710         x4=x3*x
 711         x5=x4*x
 712         facT=licznik/dlog(dexp(x)+dexp(-x))
 713         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 714         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 715         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 716         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 717       else
 718         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 719         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 720 #ifdef MPI
 721        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 722 #endif
 723        stop 555
 724       endif
 725       welec=weights(3)*fact
 726       wcorr=weights(4)*fact3
 727       wcorr5=weights(5)*fact4
 728       wcorr6=weights(6)*fact5
 729       wel_loc=weights(7)*fact2
 730       wturn3=weights(8)*fact2
 731       wturn4=weights(9)*fact3
 732       wturn6=weights(10)*fact5
 733       wtor=weights(13)*fact
 734       wtor_d=weights(14)*fact2
 735       wsccor=weights(21)*fact
 736
 737       return
 738       end
 739 C------------------------------------------------------------------------
 740       subroutine enerprint(energia)
 741       implicit real*8 (a-h,o-z)
 742       include 'DIMENSIONS'
 743       include 'COMMON.IOUNITS'
 744       include 'COMMON.FFIELD'
 745       include 'COMMON.SBRIDGE'
 746       include 'COMMON.MD'
 747       double precision energia(0:n_ene)
 748       etot=energia(0)
 749       evdw=energia(1)
 750       evdw2=energia(2)
 751 #ifdef SCP14
 752       evdw2=energia(2)+energia(18)
 753 #else
 754       evdw2=energia(2)
 755 #endif
 756       ees=energia(3)
 757 #ifdef SPLITELE
 758       evdw1=energia(16)
 759 #endif
 760       ecorr=energia(4)
 761       ecorr5=energia(5)
 762       ecorr6=energia(6)
 763       eel_loc=energia(7)
 764       eello_turn3=energia(8)
 765       eello_turn4=energia(9)
 766       eello_turn6=energia(10)
 767       ebe=energia(11)
 768       escloc=energia(12)
 769       etors=energia(13)
 770       etors_d=energia(14)
 771       ehpb=energia(15)
 772       edihcnstr=energia(19)
 773       estr=energia(17)
 774       Uconst=energia(20)
 775       esccor=energia(21)
 776 #ifdef SPLITELE
 777       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 778      &  estr,wbond,ebe,wang,
 779      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 780      &  ecorr,wcorr,
 781      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 782      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 783      &  edihcnstr,ebr*nss,
 784      &  Uconst,etot
 785    10 format (/'Virtual-chain energies:'//
 786      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 787      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 788      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 789      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 790      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 791      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 792      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 793      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 794      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 795      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 796      & ' (SS bridges & dist. cnstr.)'/
 797      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 798      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 799      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 800      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 801      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 802      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 803      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 804      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 805      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 806      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 807      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 808      & 'ETOT=  ',1pE16.6,' (total)')
 809 #else
 810       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 811      &  estr,wbond,ebe,wang,
 812      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 813      &  ecorr,wcorr,
 814      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 815      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 816      &  ebr*nss,Uconst,etot
 817    10 format (/'Virtual-chain energies:'//
 818      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 819      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 820      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 821      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 822      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 823      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 824      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 825      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 826      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 827      & ' (SS bridges & dist. cnstr.)'/
 828      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 829      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 830      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 831      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 832      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 833      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 834      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 835      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 836      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 837      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 838      & 'UCONST=',1pE16.6,' (Constraint energy)'/
 839      & 'ETOT=  ',1pE16.6,' (total)')
 840 #endif
 841       return
 842       end
 843 C-----------------------------------------------------------------------
 844       subroutine elj(evdw)
 845 C
 846 C This subroutine calculates the interaction energy of nonbonded side chains
 847 C assuming the LJ potential of interaction.
 848 C
 849       implicit real*8 (a-h,o-z)
 850       include 'DIMENSIONS'
 851       parameter (accur=1.0d-10)
 852       include 'COMMON.GEO'
 853       include 'COMMON.VAR'
 854       include 'COMMON.LOCAL'
 855       include 'COMMON.CHAIN'
 856       include 'COMMON.DERIV'
 857       include 'COMMON.INTERACT'
 858       include 'COMMON.TORSION'
 859       include 'COMMON.SBRIDGE'
 860       include 'COMMON.NAMES'
 861       include 'COMMON.IOUNITS'
 862       include 'COMMON.CONTACTS'
 863       dimension gg(3)
 864 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 865       evdw=0.0D0
 866       do i=iatsc_s,iatsc_e
 867         itypi=itype(i)
 868         itypi1=itype(i+1)
 869         xi=c(1,nres+i)
 870         yi=c(2,nres+i)
 871         zi=c(3,nres+i)
 872 C Change 12/1/95
 873         num_conti=0
 874 C
 875 C Calculate SC interaction energy.
 876 C
 877         do iint=1,nint_gr(i)
 878 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 879 cd   &                  'iend=',iend(i,iint)
 880           do j=istart(i,iint),iend(i,iint)
 881             itypj=itype(j)
 882             xj=c(1,nres+j)-xi
 883             yj=c(2,nres+j)-yi
 884             zj=c(3,nres+j)-zi
 885 C Change 12/1/95 to calculate four-body interactions
 886             rij=xj*xj+yj*yj+zj*zj
 887             rrij=1.0D0/rij
 888 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 889             eps0ij=eps(itypi,itypj)
 890             fac=rrij**expon2
 891             e1=fac*fac*aa(itypi,itypj)
 892             e2=fac*bb(itypi,itypj)
 893             evdwij=e1+e2
 894 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 895 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 896 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 897 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 898 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 899 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 900             evdw=evdw+evdwij
 901 C
 902 C Calculate the components of the gradient in DC and X
 903 C
 904             fac=-rrij*(e1+evdwij)
 905             gg(1)=xj*fac
 906             gg(2)=yj*fac
 907             gg(3)=zj*fac
 908             do k=1,3
 909               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 910               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 911               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 912               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 913             enddo
 914 cgrad            do k=i,j-1
 915 cgrad              do l=1,3
 916 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 917 cgrad              enddo
 918 cgrad            enddo
 919 C
 920 C 12/1/95, revised on 5/20/97
 921 C
 922 C Calculate the contact function. The ith column of the array JCONT will
 923 C contain the numbers of atoms that make contacts with the atom I (of numbers
 924 C greater than I). The arrays FACONT and GACONT will contain the values of
 925 C the contact function and its derivative.
 926 C
 927 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 928 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 929 C Uncomment next line, if the correlation interactions are contact function only
 930             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 931               rij=dsqrt(rij)
 932               sigij=sigma(itypi,itypj)
 933               r0ij=rs0(itypi,itypj)
 934 C
 935 C Check whether the SC's are not too far to make a contact.
 936 C
 937               rcut=1.5d0*r0ij
 938               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 939 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 940 C
 941               if (fcont.gt.0.0D0) then
 942 C If the SC-SC distance if close to sigma, apply spline.
 943 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 944 cAdam &             fcont1,fprimcont1)
 945 cAdam           fcont1=1.0d0-fcont1
 946 cAdam           if (fcont1.gt.0.0d0) then
 947 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 948 cAdam             fcont=fcont*fcont1
 949 cAdam           endif
 950 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 951 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 952 cga             do k=1,3
 953 cga               gg(k)=gg(k)*eps0ij
 954 cga             enddo
 955 cga             eps0ij=-evdwij*eps0ij
 956 C Uncomment for AL's type of SC correlation interactions.
 957 cadam           eps0ij=-evdwij
 958                 num_conti=num_conti+1
 959                 jcont(num_conti,i)=j
 960                 facont(num_conti,i)=fcont*eps0ij
 961                 fprimcont=eps0ij*fprimcont/rij
 962                 fcont=expon*fcont
 963 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 964 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 965 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 966 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 967                 gacont(1,num_conti,i)=-fprimcont*xj
 968                 gacont(2,num_conti,i)=-fprimcont*yj
 969                 gacont(3,num_conti,i)=-fprimcont*zj
 970 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 971 cd              write (iout,'(2i3,3f10.5)')
 972 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 973               endif
 974             endif
 975           enddo      ! j
 976         enddo        ! iint
 977 C Change 12/1/95
 978         num_cont(i)=num_conti
 979       enddo          ! i
 980       do i=1,nct
 981         do j=1,3
 982           gvdwc(j,i)=expon*gvdwc(j,i)
 983           gvdwx(j,i)=expon*gvdwx(j,i)
 984         enddo
 985       enddo
 986 C******************************************************************************
 987 C
 988 C                              N O T E !!!
 989 C
 990 C To save time, the factor of EXPON has been extracted from ALL components
 991 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 992 C use!
 993 C
 994 C******************************************************************************
 995       return
 996       end
 997 C-----------------------------------------------------------------------------
 998       subroutine eljk(evdw)
 999 C
1000 C This subroutine calculates the interaction energy of nonbonded side chains
1001 C assuming the LJK potential of interaction.
1002 C
1003       implicit real*8 (a-h,o-z)
1004       include 'DIMENSIONS'
1005       include 'COMMON.GEO'
1006       include 'COMMON.VAR'
1007       include 'COMMON.LOCAL'
1008       include 'COMMON.CHAIN'
1009       include 'COMMON.DERIV'
1010       include 'COMMON.INTERACT'
1011       include 'COMMON.IOUNITS'
1012       include 'COMMON.NAMES'
1013       dimension gg(3)
1014       logical scheck
1015 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1016       evdw=0.0D0
1017       do i=iatsc_s,iatsc_e
1018         itypi=itype(i)
1019         itypi1=itype(i+1)
1020         xi=c(1,nres+i)
1021         yi=c(2,nres+i)
1022         zi=c(3,nres+i)
1023 C
1024 C Calculate SC interaction energy.
1025 C
1026         do iint=1,nint_gr(i)
1027           do j=istart(i,iint),iend(i,iint)
1028             itypj=itype(j)
1029             xj=c(1,nres+j)-xi
1030             yj=c(2,nres+j)-yi
1031             zj=c(3,nres+j)-zi
1032             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1033             fac_augm=rrij**expon
1034             e_augm=augm(itypi,itypj)*fac_augm
1035             r_inv_ij=dsqrt(rrij)
1036             rij=1.0D0/r_inv_ij
1037             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1038             fac=r_shift_inv**expon
1039             e1=fac*fac*aa(itypi,itypj)
1040             e2=fac*bb(itypi,itypj)
1041             evdwij=e_augm+e1+e2
1042 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1043 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1044 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1045 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1046 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1047 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1048 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1049             evdw=evdw+evdwij
1050 C
1051 C Calculate the components of the gradient in DC and X
1052 C
1053             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1054             gg(1)=xj*fac
1055             gg(2)=yj*fac
1056             gg(3)=zj*fac
1057             do k=1,3
1058               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1059               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1060               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1061               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1062             enddo
1063 cgrad            do k=i,j-1
1064 cgrad              do l=1,3
1065 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1066 cgrad              enddo
1067 cgrad            enddo
1068           enddo      ! j
1069         enddo        ! iint
1070       enddo          ! i
1071       do i=1,nct
1072         do j=1,3
1073           gvdwc(j,i)=expon*gvdwc(j,i)
1074           gvdwx(j,i)=expon*gvdwx(j,i)
1075         enddo
1076       enddo
1077       return
1078       end
1079 C-----------------------------------------------------------------------------
1080       subroutine ebp(evdw)
1081 C
1082 C This subroutine calculates the interaction energy of nonbonded side chains
1083 C assuming the Berne-Pechukas potential of interaction.
1084 C
1085       implicit real*8 (a-h,o-z)
1086       include 'DIMENSIONS'
1087       include 'COMMON.GEO'
1088       include 'COMMON.VAR'
1089       include 'COMMON.LOCAL'
1090       include 'COMMON.CHAIN'
1091       include 'COMMON.DERIV'
1092       include 'COMMON.NAMES'
1093       include 'COMMON.INTERACT'
1094       include 'COMMON.IOUNITS'
1095       include 'COMMON.CALC'
1096       common /srutu/ icall
1097 c     double precision rrsave(maxdim)
1098       logical lprn
1099       evdw=0.0D0
1100 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1101       evdw=0.0D0
1102 c     if (icall.eq.0) then
1103 c       lprn=.true.
1104 c     else
1105         lprn=.false.
1106 c     endif
1107       ind=0
1108       do i=iatsc_s,iatsc_e
1109         itypi=itype(i)
1110         itypi1=itype(i+1)
1111         xi=c(1,nres+i)
1112         yi=c(2,nres+i)
1113         zi=c(3,nres+i)
1114         dxi=dc_norm(1,nres+i)
1115         dyi=dc_norm(2,nres+i)
1116         dzi=dc_norm(3,nres+i)
1117 c        dsci_inv=dsc_inv(itypi)
1118         dsci_inv=vbld_inv(i+nres)
1119 C
1120 C Calculate SC interaction energy.
1121 C
1122         do iint=1,nint_gr(i)
1123           do j=istart(i,iint),iend(i,iint)
1124             ind=ind+1
1125             itypj=itype(j)
1126 c            dscj_inv=dsc_inv(itypj)
1127             dscj_inv=vbld_inv(j+nres)
1128             chi1=chi(itypi,itypj)
1129             chi2=chi(itypj,itypi)
1130             chi12=chi1*chi2
1131             chip1=chip(itypi)
1132             chip2=chip(itypj)
1133             chip12=chip1*chip2
1134             alf1=alp(itypi)
1135             alf2=alp(itypj)
1136             alf12=0.5D0*(alf1+alf2)
1137 C For diagnostics only!!!
1138 c           chi1=0.0D0
1139 c           chi2=0.0D0
1140 c           chi12=0.0D0
1141 c           chip1=0.0D0
1142 c           chip2=0.0D0
1143 c           chip12=0.0D0
1144 c           alf1=0.0D0
1145 c           alf2=0.0D0
1146 c           alf12=0.0D0
1147             xj=c(1,nres+j)-xi
1148             yj=c(2,nres+j)-yi
1149             zj=c(3,nres+j)-zi
1150             dxj=dc_norm(1,nres+j)
1151             dyj=dc_norm(2,nres+j)
1152             dzj=dc_norm(3,nres+j)
1153             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1154 cd          if (icall.eq.0) then
1155 cd            rrsave(ind)=rrij
1156 cd          else
1157 cd            rrij=rrsave(ind)
1158 cd          endif
1159             rij=dsqrt(rrij)
1160 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1161             call sc_angular
1162 C Calculate whole angle-dependent part of epsilon and contributions
1163 C to its derivatives
1164             fac=(rrij*sigsq)**expon2
1165             e1=fac*fac*aa(itypi,itypj)
1166             e2=fac*bb(itypi,itypj)
1167             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1168             eps2der=evdwij*eps3rt
1169             eps3der=evdwij*eps2rt
1170             evdwij=evdwij*eps2rt*eps3rt
1171             evdw=evdw+evdwij
1172             if (lprn) then
1173             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1174             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1175 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1176 cd     &        restyp(itypi),i,restyp(itypj),j,
1177 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1178 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1179 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1180 cd     &        evdwij
1181             endif
1182 C Calculate gradient components.
1183             e1=e1*eps1*eps2rt**2*eps3rt**2
1184             fac=-expon*(e1+evdwij)
1185             sigder=fac/sigsq
1186             fac=rrij*fac
1187 C Calculate radial part of the gradient
1188             gg(1)=xj*fac
1189             gg(2)=yj*fac
1190             gg(3)=zj*fac
1191 C Calculate the angular part of the gradient and sum add the contributions
1192 C to the appropriate components of the Cartesian gradient.
1193             call sc_grad
1194           enddo      ! j
1195         enddo        ! iint
1196       enddo          ! i
1197 c     stop
1198       return
1199       end
1200 C-----------------------------------------------------------------------------
1201       subroutine egb(evdw)
1202 C
1203 C This subroutine calculates the interaction energy of nonbonded side chains
1204 C assuming the Gay-Berne potential of interaction.
1205 C
1206       implicit real*8 (a-h,o-z)
1207       include 'DIMENSIONS'
1208       include 'COMMON.GEO'
1209       include 'COMMON.VAR'
1210       include 'COMMON.LOCAL'
1211       include 'COMMON.CHAIN'
1212       include 'COMMON.DERIV'
1213       include 'COMMON.NAMES'
1214       include 'COMMON.INTERACT'
1215       include 'COMMON.IOUNITS'
1216       include 'COMMON.CALC'
1217       include 'COMMON.CONTROL'
1218       logical lprn
1219       evdw=0.0D0
1220 ccccc      energy_dec=.false.
1221 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1222       evdw=0.0D0
1223       lprn=.false.
1224 c     if (icall.eq.0) lprn=.false.
1225       ind=0
1226       do i=iatsc_s,iatsc_e
1227         itypi=itype(i)
1228         itypi1=itype(i+1)
1229         xi=c(1,nres+i)
1230         yi=c(2,nres+i)
1231         zi=c(3,nres+i)
1232         dxi=dc_norm(1,nres+i)
1233         dyi=dc_norm(2,nres+i)
1234         dzi=dc_norm(3,nres+i)
1235 c        dsci_inv=dsc_inv(itypi)
1236         dsci_inv=vbld_inv(i+nres)
1237 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1238 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1239 C
1240 C Calculate SC interaction energy.
1241 C
1242         do iint=1,nint_gr(i)
1243           do j=istart(i,iint),iend(i,iint)
1244             ind=ind+1
1245             itypj=itype(j)
1246 c            dscj_inv=dsc_inv(itypj)
1247             dscj_inv=vbld_inv(j+nres)
1248 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1249 c     &       1.0d0/vbld(j+nres)
1250 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1251             sig0ij=sigma(itypi,itypj)
1252             chi1=chi(itypi,itypj)
1253             chi2=chi(itypj,itypi)
1254             chi12=chi1*chi2
1255             chip1=chip(itypi)
1256             chip2=chip(itypj)
1257             chip12=chip1*chip2
1258             alf1=alp(itypi)
1259             alf2=alp(itypj)
1260             alf12=0.5D0*(alf1+alf2)
1261 C For diagnostics only!!!
1262 c           chi1=0.0D0
1263 c           chi2=0.0D0
1264 c           chi12=0.0D0
1265 c           chip1=0.0D0
1266 c           chip2=0.0D0
1267 c           chip12=0.0D0
1268 c           alf1=0.0D0
1269 c           alf2=0.0D0
1270 c           alf12=0.0D0
1271             xj=c(1,nres+j)-xi
1272             yj=c(2,nres+j)-yi
1273             zj=c(3,nres+j)-zi
1274             dxj=dc_norm(1,nres+j)
1275             dyj=dc_norm(2,nres+j)
1276             dzj=dc_norm(3,nres+j)
1277 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1278 c            write (iout,*) "j",j," dc_norm",
1279 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1280             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1281             rij=dsqrt(rrij)
1282 C Calculate angle-dependent terms of energy and contributions to their
1283 C derivatives.
1284             call sc_angular
1285             sigsq=1.0D0/sigsq
1286             sig=sig0ij*dsqrt(sigsq)
1287             rij_shift=1.0D0/rij-sig+sig0ij
1288 c for diagnostics; uncomment
1289 c            rij_shift=1.2*sig0ij
1290 C I hate to put IF's in the loops, but here don't have another choice!!!!
1291             if (rij_shift.le.0.0D0) then
1292               evdw=1.0D20
1293 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1294 cd     &        restyp(itypi),i,restyp(itypj),j,
1295 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1296               return
1297             endif
1298             sigder=-sig*sigsq
1299 c---------------------------------------------------------------
1300             rij_shift=1.0D0/rij_shift
1301             fac=rij_shift**expon
1302             e1=fac*fac*aa(itypi,itypj)
1303             e2=fac*bb(itypi,itypj)
1304             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1305             eps2der=evdwij*eps3rt
1306             eps3der=evdwij*eps2rt
1307 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1308 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1309             evdwij=evdwij*eps2rt*eps3rt
1310             evdw=evdw+evdwij
1311             if (lprn) then
1312             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1313             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1314             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1315      &        restyp(itypi),i,restyp(itypj),j,
1316      &        epsi,sigm,chi1,chi2,chip1,chip2,
1317      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1318      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1319      &        evdwij
1320             endif
1321
1322             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1323      &                        'evdw',i,j,evdwij
1324
1325 C Calculate gradient components.
1326             e1=e1*eps1*eps2rt**2*eps3rt**2
1327             fac=-expon*(e1+evdwij)*rij_shift
1328             sigder=fac*sigder
1329             fac=rij*fac
1330 c            fac=0.0d0
1331 C Calculate the radial part of the gradient
1332             gg(1)=xj*fac
1333             gg(2)=yj*fac
1334             gg(3)=zj*fac
1335 C Calculate angular part of the gradient.
1336             call sc_grad
1337           enddo      ! j
1338         enddo        ! iint
1339       enddo          ! i
1340 c      write (iout,*) "Number of loop steps in EGB:",ind
1341 cccc      energy_dec=.false.
1342       return
1343       end
1344 C-----------------------------------------------------------------------------
1345       subroutine egbv(evdw)
1346 C
1347 C This subroutine calculates the interaction energy of nonbonded side chains
1348 C assuming the Gay-Berne-Vorobjev potential of interaction.
1349 C
1350       implicit real*8 (a-h,o-z)
1351       include 'DIMENSIONS'
1352       include 'COMMON.GEO'
1353       include 'COMMON.VAR'
1354       include 'COMMON.LOCAL'
1355       include 'COMMON.CHAIN'
1356       include 'COMMON.DERIV'
1357       include 'COMMON.NAMES'
1358       include 'COMMON.INTERACT'
1359       include 'COMMON.IOUNITS'
1360       include 'COMMON.CALC'
1361       common /srutu/ icall
1362       logical lprn
1363       evdw=0.0D0
1364 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1365       evdw=0.0D0
1366       lprn=.false.
1367 c     if (icall.eq.0) lprn=.true.
1368       ind=0
1369       do i=iatsc_s,iatsc_e
1370         itypi=itype(i)
1371         itypi1=itype(i+1)
1372         xi=c(1,nres+i)
1373         yi=c(2,nres+i)
1374         zi=c(3,nres+i)
1375         dxi=dc_norm(1,nres+i)
1376         dyi=dc_norm(2,nres+i)
1377         dzi=dc_norm(3,nres+i)
1378 c        dsci_inv=dsc_inv(itypi)
1379         dsci_inv=vbld_inv(i+nres)
1380 C
1381 C Calculate SC interaction energy.
1382 C
1383         do iint=1,nint_gr(i)
1384           do j=istart(i,iint),iend(i,iint)
1385             ind=ind+1
1386             itypj=itype(j)
1387 c            dscj_inv=dsc_inv(itypj)
1388             dscj_inv=vbld_inv(j+nres)
1389             sig0ij=sigma(itypi,itypj)
1390             r0ij=r0(itypi,itypj)
1391             chi1=chi(itypi,itypj)
1392             chi2=chi(itypj,itypi)
1393             chi12=chi1*chi2
1394             chip1=chip(itypi)
1395             chip2=chip(itypj)
1396             chip12=chip1*chip2
1397             alf1=alp(itypi)
1398             alf2=alp(itypj)
1399             alf12=0.5D0*(alf1+alf2)
1400 C For diagnostics only!!!
1401 c           chi1=0.0D0
1402 c           chi2=0.0D0
1403 c           chi12=0.0D0
1404 c           chip1=0.0D0
1405 c           chip2=0.0D0
1406 c           chip12=0.0D0
1407 c           alf1=0.0D0
1408 c           alf2=0.0D0
1409 c           alf12=0.0D0
1410             xj=c(1,nres+j)-xi
1411             yj=c(2,nres+j)-yi
1412             zj=c(3,nres+j)-zi
1413             dxj=dc_norm(1,nres+j)
1414             dyj=dc_norm(2,nres+j)
1415             dzj=dc_norm(3,nres+j)
1416             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1417             rij=dsqrt(rrij)
1418 C Calculate angle-dependent terms of energy and contributions to their
1419 C derivatives.
1420             call sc_angular
1421             sigsq=1.0D0/sigsq
1422             sig=sig0ij*dsqrt(sigsq)
1423             rij_shift=1.0D0/rij-sig+r0ij
1424 C I hate to put IF's in the loops, but here don't have another choice!!!!
1425             if (rij_shift.le.0.0D0) then
1426               evdw=1.0D20
1427               return
1428             endif
1429             sigder=-sig*sigsq
1430 c---------------------------------------------------------------
1431             rij_shift=1.0D0/rij_shift
1432             fac=rij_shift**expon
1433             e1=fac*fac*aa(itypi,itypj)
1434             e2=fac*bb(itypi,itypj)
1435             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1436             eps2der=evdwij*eps3rt
1437             eps3der=evdwij*eps2rt
1438             fac_augm=rrij**expon
1439             e_augm=augm(itypi,itypj)*fac_augm
1440             evdwij=evdwij*eps2rt*eps3rt
1441             evdw=evdw+evdwij+e_augm
1442             if (lprn) then
1443             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1444             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1445             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1446      &        restyp(itypi),i,restyp(itypj),j,
1447      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1448      &        chi1,chi2,chip1,chip2,
1449      &        eps1,eps2rt**2,eps3rt**2,
1450      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1451      &        evdwij+e_augm
1452             endif
1453 C Calculate gradient components.
1454             e1=e1*eps1*eps2rt**2*eps3rt**2
1455             fac=-expon*(e1+evdwij)*rij_shift
1456             sigder=fac*sigder
1457             fac=rij*fac-2*expon*rrij*e_augm
1458 C Calculate the radial part of the gradient
1459             gg(1)=xj*fac
1460             gg(2)=yj*fac
1461             gg(3)=zj*fac
1462 C Calculate angular part of the gradient.
1463             call sc_grad
1464           enddo      ! j
1465         enddo        ! iint
1466       enddo          ! i
1467       end
1468 C-----------------------------------------------------------------------------
1469       subroutine sc_angular
1470 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1471 C om12. Called by ebp, egb, and egbv.
1472       implicit none
1473       include 'COMMON.CALC'
1474       include 'COMMON.IOUNITS'
1475       erij(1)=xj*rij
1476       erij(2)=yj*rij
1477       erij(3)=zj*rij
1478       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1479       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1480       om12=dxi*dxj+dyi*dyj+dzi*dzj
1481       chiom12=chi12*om12
1482 C Calculate eps1(om12) and its derivative in om12
1483       faceps1=1.0D0-om12*chiom12
1484       faceps1_inv=1.0D0/faceps1
1485       eps1=dsqrt(faceps1_inv)
1486 C Following variable is eps1*deps1/dom12
1487       eps1_om12=faceps1_inv*chiom12
1488 c diagnostics only
1489 c      faceps1_inv=om12
1490 c      eps1=om12
1491 c      eps1_om12=1.0d0
1492 c      write (iout,*) "om12",om12," eps1",eps1
1493 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1494 C and om12.
1495       om1om2=om1*om2
1496       chiom1=chi1*om1
1497       chiom2=chi2*om2
1498       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1499       sigsq=1.0D0-facsig*faceps1_inv
1500       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1501       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1502       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1503 c diagnostics only
1504 c      sigsq=1.0d0
1505 c      sigsq_om1=0.0d0
1506 c      sigsq_om2=0.0d0
1507 c      sigsq_om12=0.0d0
1508 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1509 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1510 c     &    " eps1",eps1
1511 C Calculate eps2 and its derivatives in om1, om2, and om12.
1512       chipom1=chip1*om1
1513       chipom2=chip2*om2
1514       chipom12=chip12*om12
1515       facp=1.0D0-om12*chipom12
1516       facp_inv=1.0D0/facp
1517       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1518 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1519 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1520 C Following variable is the square root of eps2
1521       eps2rt=1.0D0-facp1*facp_inv
1522 C Following three variables are the derivatives of the square root of eps
1523 C in om1, om2, and om12.
1524       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1525       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1526       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1527 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1528       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1529 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1530 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1531 c     &  " eps2rt_om12",eps2rt_om12
1532 C Calculate whole angle-dependent part of epsilon and contributions
1533 C to its derivatives
1534       return
1535       end
1536 C----------------------------------------------------------------------------
1537       subroutine sc_grad
1538       implicit real*8 (a-h,o-z)
1539       include 'DIMENSIONS'
1540       include 'COMMON.CHAIN'
1541       include 'COMMON.DERIV'
1542       include 'COMMON.CALC'
1543       include 'COMMON.IOUNITS'
1544       double precision dcosom1(3),dcosom2(3)
1545       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1546       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1547       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1548      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1549 c diagnostics only
1550 c      eom1=0.0d0
1551 c      eom2=0.0d0
1552 c      eom12=evdwij*eps1_om12
1553 c end diagnostics
1554 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1555 c     &  " sigder",sigder
1556 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1557 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1558       do k=1,3
1559         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1560         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1561       enddo
1562       do k=1,3
1563         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1564       enddo
1565 c      write (iout,*) "gg",(gg(k),k=1,3)
1566       do k=1,3
1567         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1568      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1569      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1570         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1571      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1572      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1573 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1574 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1575 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1576 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1577       enddo
1578 C
1579 C Calculate the components of the gradient in DC and X
1580 C
1581 cgrad      do k=i,j-1
1582 cgrad        do l=1,3
1583 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1584 cgrad        enddo
1585 cgrad      enddo
1586       do l=1,3
1587         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1588         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1589       enddo
1590       return
1591       end
1592 C-----------------------------------------------------------------------
1593       subroutine e_softsphere(evdw)
1594 C
1595 C This subroutine calculates the interaction energy of nonbonded side chains
1596 C assuming the LJ potential of interaction.
1597 C
1598       implicit real*8 (a-h,o-z)
1599       include 'DIMENSIONS'
1600       parameter (accur=1.0d-10)
1601       include 'COMMON.GEO'
1602       include 'COMMON.VAR'
1603       include 'COMMON.LOCAL'
1604       include 'COMMON.CHAIN'
1605       include 'COMMON.DERIV'
1606       include 'COMMON.INTERACT'
1607       include 'COMMON.TORSION'
1608       include 'COMMON.SBRIDGE'
1609       include 'COMMON.NAMES'
1610       include 'COMMON.IOUNITS'
1611       include 'COMMON.CONTACTS'
1612       dimension gg(3)
1613 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1614       evdw=0.0D0
1615       do i=iatsc_s,iatsc_e
1616         itypi=itype(i)
1617         itypi1=itype(i+1)
1618         xi=c(1,nres+i)
1619         yi=c(2,nres+i)
1620         zi=c(3,nres+i)
1621 C
1622 C Calculate SC interaction energy.
1623 C
1624         do iint=1,nint_gr(i)
1625 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1626 cd   &                  'iend=',iend(i,iint)
1627           do j=istart(i,iint),iend(i,iint)
1628             itypj=itype(j)
1629             xj=c(1,nres+j)-xi
1630             yj=c(2,nres+j)-yi
1631             zj=c(3,nres+j)-zi
1632             rij=xj*xj+yj*yj+zj*zj
1633 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1634             r0ij=r0(itypi,itypj)
1635             r0ijsq=r0ij*r0ij
1636 c            print *,i,j,r0ij,dsqrt(rij)
1637             if (rij.lt.r0ijsq) then
1638               evdwij=0.25d0*(rij-r0ijsq)**2
1639               fac=rij-r0ijsq
1640             else
1641               evdwij=0.0d0
1642               fac=0.0d0
1643             endif
1644             evdw=evdw+evdwij
1645 C
1646 C Calculate the components of the gradient in DC and X
1647 C
1648             gg(1)=xj*fac
1649             gg(2)=yj*fac
1650             gg(3)=zj*fac
1651             do k=1,3
1652               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1653               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1654               gvdwc(k,i)=gvdwc(l,k)-gg(k)
1655               gvdwc(k,j)=gvdwc(l,k)+gg(k)
1656             enddo
1657 cgrad            do k=i,j-1
1658 cgrad              do l=1,3
1659 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1660 cgrad              enddo
1661 cgrad            enddo
1662           enddo ! j
1663         enddo ! iint
1664       enddo ! i
1665       return
1666       end
1667 C--------------------------------------------------------------------------
1668       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1669      &              eello_turn4)
1670 C
1671 C Soft-sphere potential of p-p interaction
1672 C
1673       implicit real*8 (a-h,o-z)
1674       include 'DIMENSIONS'
1675       include 'COMMON.CONTROL'
1676       include 'COMMON.IOUNITS'
1677       include 'COMMON.GEO'
1678       include 'COMMON.VAR'
1679       include 'COMMON.LOCAL'
1680       include 'COMMON.CHAIN'
1681       include 'COMMON.DERIV'
1682       include 'COMMON.INTERACT'
1683       include 'COMMON.CONTACTS'
1684       include 'COMMON.TORSION'
1685       include 'COMMON.VECTORS'
1686       include 'COMMON.FFIELD'
1687       dimension ggg(3)
1688 cd      write(iout,*) 'In EELEC_soft_sphere'
1689       ees=0.0D0
1690       evdw1=0.0D0
1691       eel_loc=0.0d0
1692       eello_turn3=0.0d0
1693       eello_turn4=0.0d0
1694       ind=0
1695       do i=iatel_s,iatel_e
1696         dxi=dc(1,i)
1697         dyi=dc(2,i)
1698         dzi=dc(3,i)
1699         xmedi=c(1,i)+0.5d0*dxi
1700         ymedi=c(2,i)+0.5d0*dyi
1701         zmedi=c(3,i)+0.5d0*dzi
1702         num_conti=0
1703 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1704         do j=ielstart(i),ielend(i)
1705           ind=ind+1
1706           iteli=itel(i)
1707           itelj=itel(j)
1708           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1709           r0ij=rpp(iteli,itelj)
1710           r0ijsq=r0ij*r0ij
1711           dxj=dc(1,j)
1712           dyj=dc(2,j)
1713           dzj=dc(3,j)
1714           xj=c(1,j)+0.5D0*dxj-xmedi
1715           yj=c(2,j)+0.5D0*dyj-ymedi
1716           zj=c(3,j)+0.5D0*dzj-zmedi
1717           rij=xj*xj+yj*yj+zj*zj
1718           if (rij.lt.r0ijsq) then
1719             evdw1ij=0.25d0*(rij-r0ijsq)**2
1720             fac=rij-r0ijsq
1721           else
1722             evdw1ij=0.0d0
1723             fac=0.0d0
1724           endif
1725           evdw1=evdw1+evdw1ij
1726 C
1727 C Calculate contributions to the Cartesian gradient.
1728 C
1729           ggg(1)=fac*xj
1730           ggg(2)=fac*yj
1731           ggg(3)=fac*zj
1732           do k=1,3
1733             gelc(k,i)=gelc(k,i)-ggg(k)
1734             gelc(k,j)=gelc(k,j)+ggg(k)
1735           enddo
1736 *
1737 * Loop over residues i+1 thru j-1.
1738 *
1739 cgrad          do k=i+1,j-1
1740 cgrad            do l=1,3
1741 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1742 cgrad            enddo
1743 cgrad          enddo
1744         enddo ! j
1745       enddo   ! i
1746       do i=nnt,nct-1
1747         do k=1,3
1748           gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1749         enddo
1750         do j=i+1,nct-1
1751           do k=1,3
1752             gelc(k,i)=gelc(k,i)+gelc(k,j)
1753           enddo
1754         enddo
1755       enddo
1756       return
1757       end
1758 c------------------------------------------------------------------------------
1759       subroutine vec_and_deriv
1760       implicit real*8 (a-h,o-z)
1761       include 'DIMENSIONS'
1762 #ifdef MPI
1763       include 'mpif.h'
1764 #endif
1765       include 'COMMON.IOUNITS'
1766       include 'COMMON.GEO'
1767       include 'COMMON.VAR'
1768       include 'COMMON.LOCAL'
1769       include 'COMMON.CHAIN'
1770       include 'COMMON.VECTORS'
1771       include 'COMMON.SETUP'
1772       include 'COMMON.TIME1'
1773       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1774 C Compute the local reference systems. For reference system (i), the
1775 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1776 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1777 #ifdef PARVEC
1778       do i=ivec_start,ivec_end
1779 #else
1780       do i=1,nres-1
1781 #endif
1782           if (i.eq.nres-1) then
1783 C Case of the last full residue
1784 C Compute the Z-axis
1785             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1786             costh=dcos(pi-theta(nres))
1787             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1788             do k=1,3
1789               uz(k,i)=fac*uz(k,i)
1790             enddo
1791 C Compute the derivatives of uz
1792             uzder(1,1,1)= 0.0d0
1793             uzder(2,1,1)=-dc_norm(3,i-1)
1794             uzder(3,1,1)= dc_norm(2,i-1)
1795             uzder(1,2,1)= dc_norm(3,i-1)
1796             uzder(2,2,1)= 0.0d0
1797             uzder(3,2,1)=-dc_norm(1,i-1)
1798             uzder(1,3,1)=-dc_norm(2,i-1)
1799             uzder(2,3,1)= dc_norm(1,i-1)
1800             uzder(3,3,1)= 0.0d0
1801             uzder(1,1,2)= 0.0d0
1802             uzder(2,1,2)= dc_norm(3,i)
1803             uzder(3,1,2)=-dc_norm(2,i)
1804             uzder(1,2,2)=-dc_norm(3,i)
1805             uzder(2,2,2)= 0.0d0
1806             uzder(3,2,2)= dc_norm(1,i)
1807             uzder(1,3,2)= dc_norm(2,i)
1808             uzder(2,3,2)=-dc_norm(1,i)
1809             uzder(3,3,2)= 0.0d0
1810 C Compute the Y-axis
1811             facy=fac
1812             do k=1,3
1813               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1814             enddo
1815 C Compute the derivatives of uy
1816             do j=1,3
1817               do k=1,3
1818                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1819      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1820                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1821               enddo
1822               uyder(j,j,1)=uyder(j,j,1)-costh
1823               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1824             enddo
1825             do j=1,2
1826               do k=1,3
1827                 do l=1,3
1828                   uygrad(l,k,j,i)=uyder(l,k,j)
1829                   uzgrad(l,k,j,i)=uzder(l,k,j)
1830                 enddo
1831               enddo
1832             enddo
1833             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1834             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1835             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1836             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1837           else
1838 C Other residues
1839 C Compute the Z-axis
1840             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1841             costh=dcos(pi-theta(i+2))
1842             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1843             do k=1,3
1844               uz(k,i)=fac*uz(k,i)
1845             enddo
1846 C Compute the derivatives of uz
1847             uzder(1,1,1)= 0.0d0
1848             uzder(2,1,1)=-dc_norm(3,i+1)
1849             uzder(3,1,1)= dc_norm(2,i+1)
1850             uzder(1,2,1)= dc_norm(3,i+1)
1851             uzder(2,2,1)= 0.0d0
1852             uzder(3,2,1)=-dc_norm(1,i+1)
1853             uzder(1,3,1)=-dc_norm(2,i+1)
1854             uzder(2,3,1)= dc_norm(1,i+1)
1855             uzder(3,3,1)= 0.0d0
1856             uzder(1,1,2)= 0.0d0
1857             uzder(2,1,2)= dc_norm(3,i)
1858             uzder(3,1,2)=-dc_norm(2,i)
1859             uzder(1,2,2)=-dc_norm(3,i)
1860             uzder(2,2,2)= 0.0d0
1861             uzder(3,2,2)= dc_norm(1,i)
1862             uzder(1,3,2)= dc_norm(2,i)
1863             uzder(2,3,2)=-dc_norm(1,i)
1864             uzder(3,3,2)= 0.0d0
1865 C Compute the Y-axis
1866             facy=fac
1867             do k=1,3
1868               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1869             enddo
1870 C Compute the derivatives of uy
1871             do j=1,3
1872               do k=1,3
1873                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1874      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1875                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1876               enddo
1877               uyder(j,j,1)=uyder(j,j,1)-costh
1878               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1879             enddo
1880             do j=1,2
1881               do k=1,3
1882                 do l=1,3
1883                   uygrad(l,k,j,i)=uyder(l,k,j)
1884                   uzgrad(l,k,j,i)=uzder(l,k,j)
1885                 enddo
1886               enddo
1887             enddo
1888             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1889             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1890             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1891             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1892           endif
1893       enddo
1894       do i=1,nres-1
1895         vbld_inv_temp(1)=vbld_inv(i+1)
1896         if (i.lt.nres-1) then
1897           vbld_inv_temp(2)=vbld_inv(i+2)
1898           else
1899           vbld_inv_temp(2)=vbld_inv(i)
1900           endif
1901         do j=1,2
1902           do k=1,3
1903             do l=1,3
1904               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1905               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1906             enddo
1907           enddo
1908         enddo
1909       enddo
1910 #if defined(PARVEC) && defined(MPI)
1911       if (nfgtasks.gt.1) then
1912         time00=MPI_Wtime()
1913 c        print *,"Processor",fg_rank,kolor," ivec_start",ivec_start,
1914 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
1915 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
1916         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank),
1917      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1918      &   FG_COMM,IERR)
1919         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank),
1920      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1921      &   FG_COMM,IERR)
1922         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
1923      &   ivec_count(fg_rank),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
1924      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1925         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
1926      &   ivec_count(fg_rank),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
1927      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1928         time_gather=time_gather+MPI_Wtime()-time00
1929       endif
1930 c      if (fg_rank.eq.0) then
1931 c        write (iout,*) "Arrays UY and UZ"
1932 c        do i=1,nres-1
1933 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1934 c     &     (uz(k,i),k=1,3)
1935 c        enddo
1936 c      endif
1937 #endif
1938       return
1939       end
1940 C-----------------------------------------------------------------------------
1941       subroutine check_vecgrad
1942       implicit real*8 (a-h,o-z)
1943       include 'DIMENSIONS'
1944       include 'COMMON.IOUNITS'
1945       include 'COMMON.GEO'
1946       include 'COMMON.VAR'
1947       include 'COMMON.LOCAL'
1948       include 'COMMON.CHAIN'
1949       include 'COMMON.VECTORS'
1950       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1951       dimension uyt(3,maxres),uzt(3,maxres)
1952       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1953       double precision delta /1.0d-7/
1954       call vec_and_deriv
1955 cd      do i=1,nres
1956 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1957 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1958 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1959 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1960 cd     &     (dc_norm(if90,i),if90=1,3)
1961 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1962 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1963 cd          write(iout,'(a)')
1964 cd      enddo
1965       do i=1,nres
1966         do j=1,2
1967           do k=1,3
1968             do l=1,3
1969               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1970               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1971             enddo
1972           enddo
1973         enddo
1974       enddo
1975       call vec_and_deriv
1976       do i=1,nres
1977         do j=1,3
1978           uyt(j,i)=uy(j,i)
1979           uzt(j,i)=uz(j,i)
1980         enddo
1981       enddo
1982       do i=1,nres
1983 cd        write (iout,*) 'i=',i
1984         do k=1,3
1985           erij(k)=dc_norm(k,i)
1986         enddo
1987         do j=1,3
1988           do k=1,3
1989             dc_norm(k,i)=erij(k)
1990           enddo
1991           dc_norm(j,i)=dc_norm(j,i)+delta
1992 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1993 c          do k=1,3
1994 c            dc_norm(k,i)=dc_norm(k,i)/fac
1995 c          enddo
1996 c          write (iout,*) (dc_norm(k,i),k=1,3)
1997 c          write (iout,*) (erij(k),k=1,3)
1998           call vec_and_deriv
1999           do k=1,3
2000             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2001             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2002             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2003             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2004           enddo
2005 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2006 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2007 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2008         enddo
2009         do k=1,3
2010           dc_norm(k,i)=erij(k)
2011         enddo
2012 cd        do k=1,3
2013 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2014 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2015 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2016 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2017 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2018 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2019 cd          write (iout,'(a)')
2020 cd        enddo
2021       enddo
2022       return
2023       end
2024 C--------------------------------------------------------------------------
2025       subroutine set_matrices
2026       implicit real*8 (a-h,o-z)
2027       include 'DIMENSIONS'
2028 #ifdef MPI
2029       include "mpif.h"
2030       include "COMMON.SETUP"
2031       integer IERR
2032       integer status(MPI_STATUS_SIZE)
2033 #endif
2034       include 'COMMON.IOUNITS'
2035       include 'COMMON.GEO'
2036       include 'COMMON.VAR'
2037       include 'COMMON.LOCAL'
2038       include 'COMMON.CHAIN'
2039       include 'COMMON.DERIV'
2040       include 'COMMON.INTERACT'
2041       include 'COMMON.CONTACTS'
2042       include 'COMMON.TORSION'
2043       include 'COMMON.VECTORS'
2044       include 'COMMON.FFIELD'
2045       double precision auxvec(2),auxmat(2,2)
2046 C
2047 C Compute the virtual-bond-torsional-angle dependent quantities needed
2048 C to calculate the el-loc multibody terms of various order.
2049 C
2050 #ifdef PARMAT
2051       do i=ivec_start+2,ivec_end+2
2052 #else
2053       do i=3,nres+1
2054 #endif
2055         if (i .lt. nres+1) then
2056           sin1=dsin(phi(i))
2057           cos1=dcos(phi(i))
2058           sintab(i-2)=sin1
2059           costab(i-2)=cos1
2060           obrot(1,i-2)=cos1
2061           obrot(2,i-2)=sin1
2062           sin2=dsin(2*phi(i))
2063           cos2=dcos(2*phi(i))
2064           sintab2(i-2)=sin2
2065           costab2(i-2)=cos2
2066           obrot2(1,i-2)=cos2
2067           obrot2(2,i-2)=sin2
2068           Ug(1,1,i-2)=-cos1
2069           Ug(1,2,i-2)=-sin1
2070           Ug(2,1,i-2)=-sin1
2071           Ug(2,2,i-2)= cos1
2072           Ug2(1,1,i-2)=-cos2
2073           Ug2(1,2,i-2)=-sin2
2074           Ug2(2,1,i-2)=-sin2
2075           Ug2(2,2,i-2)= cos2
2076         else
2077           costab(i-2)=1.0d0
2078           sintab(i-2)=0.0d0
2079           obrot(1,i-2)=1.0d0
2080           obrot(2,i-2)=0.0d0
2081           obrot2(1,i-2)=0.0d0
2082           obrot2(2,i-2)=0.0d0
2083           Ug(1,1,i-2)=1.0d0
2084           Ug(1,2,i-2)=0.0d0
2085           Ug(2,1,i-2)=0.0d0
2086           Ug(2,2,i-2)=1.0d0
2087           Ug2(1,1,i-2)=0.0d0
2088           Ug2(1,2,i-2)=0.0d0
2089           Ug2(2,1,i-2)=0.0d0
2090           Ug2(2,2,i-2)=0.0d0
2091         endif
2092         if (i .gt. 3 .and. i .lt. nres+1) then
2093           obrot_der(1,i-2)=-sin1
2094           obrot_der(2,i-2)= cos1
2095           Ugder(1,1,i-2)= sin1
2096           Ugder(1,2,i-2)=-cos1
2097           Ugder(2,1,i-2)=-cos1
2098           Ugder(2,2,i-2)=-sin1
2099           dwacos2=cos2+cos2
2100           dwasin2=sin2+sin2
2101           obrot2_der(1,i-2)=-dwasin2
2102           obrot2_der(2,i-2)= dwacos2
2103           Ug2der(1,1,i-2)= dwasin2
2104           Ug2der(1,2,i-2)=-dwacos2
2105           Ug2der(2,1,i-2)=-dwacos2
2106           Ug2der(2,2,i-2)=-dwasin2
2107         else
2108           obrot_der(1,i-2)=0.0d0
2109           obrot_der(2,i-2)=0.0d0
2110           Ugder(1,1,i-2)=0.0d0
2111           Ugder(1,2,i-2)=0.0d0
2112           Ugder(2,1,i-2)=0.0d0
2113           Ugder(2,2,i-2)=0.0d0
2114           obrot2_der(1,i-2)=0.0d0
2115           obrot2_der(2,i-2)=0.0d0
2116           Ug2der(1,1,i-2)=0.0d0
2117           Ug2der(1,2,i-2)=0.0d0
2118           Ug2der(2,1,i-2)=0.0d0
2119           Ug2der(2,2,i-2)=0.0d0
2120         endif
2121 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2122         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2123           iti = itortyp(itype(i-2))
2124         else
2125           iti=ntortyp+1
2126         endif
2127 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2128         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2129           iti1 = itortyp(itype(i-1))
2130         else
2131           iti1=ntortyp+1
2132         endif
2133 cd        write (iout,*) '*******i',i,' iti1',iti
2134 cd        write (iout,*) 'b1',b1(:,iti)
2135 cd        write (iout,*) 'b2',b2(:,iti)
2136 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2137 c        if (i .gt. iatel_s+2) then
2138         if (i .gt. nnt+2) then
2139           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2140           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2141           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2142      &    then
2143           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2144           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2145           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2146           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2147           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2148           endif
2149         else
2150           do k=1,2
2151             Ub2(k,i-2)=0.0d0
2152             Ctobr(k,i-2)=0.0d0
2153             Dtobr2(k,i-2)=0.0d0
2154             do l=1,2
2155               EUg(l,k,i-2)=0.0d0
2156               CUg(l,k,i-2)=0.0d0
2157               DUg(l,k,i-2)=0.0d0
2158               DtUg2(l,k,i-2)=0.0d0
2159             enddo
2160           enddo
2161         endif
2162         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2163         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2164         do k=1,2
2165           muder(k,i-2)=Ub2der(k,i-2)
2166         enddo
2167 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2168         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2169           iti1 = itortyp(itype(i-1))
2170         else
2171           iti1=ntortyp+1
2172         endif
2173         do k=1,2
2174           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2175         enddo
2176 cd        write (iout,*) 'mu ',mu(:,i-2)
2177 cd        write (iout,*) 'mu1',mu1(:,i-2)
2178 cd        write (iout,*) 'mu2',mu2(:,i-2)
2179         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2180      &  then
2181         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2182         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2183         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2184         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2185         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2186 C Vectors and matrices dependent on a single virtual-bond dihedral.
2187         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2188         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2189         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2190         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2191         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2192         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2193         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2194         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2195         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2196         endif
2197       enddo
2198 C Matrices dependent on two consecutive virtual-bond dihedrals.
2199 C The order of matrices is from left to right.
2200       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2201      &then
2202       do i=ivec_start,ivec_end
2203 c      do i=2,nres-1
2204         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2205         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2206         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2207         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2208         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2209         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2210         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2211         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2212       enddo
2213       endif
2214 #if defined(MPI) && defined(PARMAT)
2215 #ifdef DEBUG
2216 c      if (fg_rank.eq.0) then
2217         write (iout,*) "Arrays UG and UGDER before GATHER"
2218         do i=1,nres-1
2219           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2220      &     ((ug(l,k,i),l=1,2),k=1,2),
2221      &     ((ugder(l,k,i),l=1,2),k=1,2)
2222         enddo
2223         write (iout,*) "Arrays UG2 and UG2DER"
2224         do i=1,nres-1
2225           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2226      &     ((ug2(l,k,i),l=1,2),k=1,2),
2227      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2228         enddo
2229         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2230         do i=1,nres-1
2231           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2232      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2233      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2234         enddo
2235         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2236         do i=1,nres-1
2237           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2238      &     costab(i),sintab(i),costab2(i),sintab2(i)
2239         enddo
2240         write (iout,*) "Array MUDER"
2241         do i=1,nres-1
2242           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2243         enddo
2244 c      endif
2245 #endif
2246       if (nfgtasks.gt.1) then
2247         time00=MPI_Wtime()
2248 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2249 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2250 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2251 #ifdef MATGATHER
2252 c        write (iout,*) "MPI_ROTAT",MPI_ROTAT
2253 c        call MPI_Allgatherv(ug(1,1,ivec_start),ivec_count(fg_rank),
2254 c     &   MPI_MAT1,ug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2255 c     &   FG_COMM,IERR)
2256 c        call MPI_Allgatherv(ugder(1,1,ivec_start),ivec_count(fg_rank),
2257 c     &   MPI_MAT1,ugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2258 c     &   FG_COMM,IERR)
2259 c        call MPI_Allgatherv(ug2(1,1,ivec_start),ivec_count(fg_rank),
2260 c     &   MPI_MAT1,ug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2261 c     &   FG_COMM,IERR)
2262 c        call MPI_Allgatherv(ug2der(1,1,ivec_start),ivec_count(fg_rank),
2263 c     &   MPI_MAT1,ug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2264 c     &   FG_COMM,IERR)
2265 c        call MPI_Allgatherv(obrot(1,ivec_start),ivec_count(fg_rank),
2266 c     &   MPI_MU,obrot(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2267 c     &   FG_COMM,IERR)
2268 c        call MPI_Allgatherv(obrot2(1,ivec_start),ivec_count(fg_rank),
2269 c     &   MPI_MU,obrot2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2270 c     &   FG_COMM,IERR)
2271 c        call MPI_Allgatherv(obrot_der(1,ivec_start),ivec_count(fg_rank),
2272 c     &   MPI_MU,obrot_der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2273 c     &   FG_COMM,IERR)
2274 c        call MPI_Allgatherv(obrot2_der(1,ivec_start),
2275 c     &   ivec_count(fg_rank),
2276 c     &   MPI_MU,obrot2_der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2277 c     &   FG_COMM,IERR)
2278         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank),
2279      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2280      &   FG_COMM,IERR)
2281         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank),
2282      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2283      &   FG_COMM,IERR)
2284         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank),
2285      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2286      &   FG_COMM,IERR)
2287         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank),
2288      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2289      &   FG_COMM,IERR)
2290         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank),
2291      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2292      &   FG_COMM,IERR)
2293         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank),
2294      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2295      &   FG_COMM,IERR)
2296         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank),
2297      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2298      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2299         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank),
2300      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2301      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2302         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank),
2303      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2304      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2305         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank),
2306      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2307      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2308         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2309      &  then
2310         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank),
2311      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2312      &   FG_COMM,IERR)
2313         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank),
2314      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2315      &   FG_COMM,IERR)
2316         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank),
2317      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2318      &   FG_COMM,IERR)
2319         call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank),
2320      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2321      &   FG_COMM,IERR)
2322         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank),
2323      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2324      &   FG_COMM,IERR)
2325         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2326      &   ivec_count(fg_rank),
2327      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2328      &   FG_COMM,IERR)
2329         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank),
2330      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2331      &   FG_COMM,IERR)
2332         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank),
2333      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2334      &   FG_COMM,IERR)
2335         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank),
2336      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2337      &   FG_COMM,IERR)
2338         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank),
2339      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2340      &   FG_COMM,IERR)
2341         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank),
2342      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2343      &   FG_COMM,IERR)
2344         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank),
2345      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2346      &   FG_COMM,IERR)
2347         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank),
2348      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2349      &   FG_COMM,IERR)
2350         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2351      &   ivec_count(fg_rank),
2352      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2353      &   FG_COMM,IERR)
2354         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank),
2355      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2356      &   FG_COMM,IERR)
2357         call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank),
2358      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2359      &   FG_COMM,IERR)
2360         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank),
2361      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2362      &   FG_COMM,IERR)
2363         call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank),
2364      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2365      &   FG_COMM,IERR)
2366         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2367      &   ivec_count(fg_rank),
2368      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2369      &   FG_COMM,IERR)
2370         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2371      &   ivec_count(fg_rank),
2372      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2373      &   FG_COMM,IERR)
2374         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2375      &   ivec_count(fg_rank),
2376      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2377      &   MPI_MAT2,FG_COMM,IERR)
2378         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2379      &   ivec_count(fg_rank),
2380      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2381      &   MPI_MAT2,FG_COMM,IERR)
2382         endif
2383 #else
2384 c Passes matrix info through the ring
2385       isend=fg_rank
2386       irecv=fg_rank-1
2387       if (irecv.lt.0) irecv=nfgtasks-1
2388       iprev=irecv
2389       inext=fg_rank+1
2390       if (inext.ge.nfgtasks) inext=0
2391       do i=1,nfgtasks-1
2392 c        write (iout,*) "isend",isend," irecv",irecv
2393 c        call flush(iout)
2394         lensend=lentyp(isend)
2395         lenrecv=lentyp(irecv)
2396 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2397 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2398 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2399 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2400 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2401 c        write (iout,*) "Gather ROTAT1"
2402 c        call flush(iout)
2403 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2404 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2405 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2406 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2407 c        write (iout,*) "Gather ROTAT2"
2408 c        call flush(iout)
2409         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2410      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2411      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2412      &   iprev,4400+irecv,FG_COMM,status,IERR)
2413 c        write (iout,*) "Gather ROTAT_OLD"
2414 c        call flush(iout)
2415         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2416      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2417      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2418      &   iprev,5500+irecv,FG_COMM,status,IERR)
2419 c        write (iout,*) "Gather PRECOMP11"
2420 c        call flush(iout)
2421         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2422      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2423      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2424      &   iprev,6600+irecv,FG_COMM,status,IERR)
2425 c        write (iout,*) "Gather PRECOMP12"
2426 c        call flush(iout)
2427         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2428      &  then
2429         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2430      &   MPI_ROTAT2(lensend),inext,7700+isend,
2431      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2432      &   iprev,7700+irecv,FG_COMM,status,IERR)
2433 c        write (iout,*) "Gather PRECOMP21"
2434 c        call flush(iout)
2435         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2436      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2437      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2438      &   iprev,8800+irecv,FG_COMM,status,IERR)
2439 c        write (iout,*) "Gather PRECOMP22"
2440 c        call flush(iout)
2441         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2442      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2443      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2444      &   MPI_PRECOMP23(lenrecv),
2445      &   iprev,9900+irecv,FG_COMM,status,IERR)
2446 c        write (iout,*) "Gather PRECOMP23"
2447 c        call flush(iout)
2448         endif
2449         isend=irecv
2450         irecv=irecv-1
2451         if (irecv.lt.0) irecv=nfgtasks-1
2452       enddo
2453 #endif
2454         time_gather=time_gather+MPI_Wtime()-time00
2455       endif
2456 #ifdef DEBUG
2457 c      if (fg_rank.eq.0) then
2458         write (iout,*) "Arrays UG and UGDER"
2459         do i=1,nres-1
2460           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2461      &     ((ug(l,k,i),l=1,2),k=1,2),
2462      &     ((ugder(l,k,i),l=1,2),k=1,2)
2463         enddo
2464         write (iout,*) "Arrays UG2 and UG2DER"
2465         do i=1,nres-1
2466           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2467      &     ((ug2(l,k,i),l=1,2),k=1,2),
2468      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2469         enddo
2470         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2471         do i=1,nres-1
2472           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2473      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2474      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2475         enddo
2476         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2477         do i=1,nres-1
2478           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2479      &     costab(i),sintab(i),costab2(i),sintab2(i)
2480         enddo
2481         write (iout,*) "Array MUDER"
2482         do i=1,nres-1
2483           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2484         enddo
2485 c      endif
2486 #endif
2487 #endif
2488 cd      do i=1,nres
2489 cd        iti = itortyp(itype(i))
2490 cd        write (iout,*) i
2491 cd        do j=1,2
2492 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2493 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2494 cd        enddo
2495 cd      enddo
2496       return
2497       end
2498 C--------------------------------------------------------------------------
2499       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2500 C
2501 C This subroutine calculates the average interaction energy and its gradient
2502 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2503 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2504 C The potential depends both on the distance of peptide-group centers and on
2505 C the orientation of the CA-CA virtual bonds.
2506 C
2507       implicit real*8 (a-h,o-z)
2508       include 'DIMENSIONS'
2509       include 'COMMON.CONTROL'
2510       include 'COMMON.SETUP'
2511       include 'COMMON.IOUNITS'
2512       include 'COMMON.GEO'
2513       include 'COMMON.VAR'
2514       include 'COMMON.LOCAL'
2515       include 'COMMON.CHAIN'
2516       include 'COMMON.DERIV'
2517       include 'COMMON.INTERACT'
2518       include 'COMMON.CONTACTS'
2519       include 'COMMON.TORSION'
2520       include 'COMMON.VECTORS'
2521       include 'COMMON.FFIELD'
2522       include 'COMMON.TIME1'
2523       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2524      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2525       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2526      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2527       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2528      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2529      &    num_conti,j1,j2
2530 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2531 #ifdef MOMENT
2532       double precision scal_el /1.0d0/
2533 #else
2534       double precision scal_el /0.5d0/
2535 #endif
2536 C 12/13/98
2537 C 13-go grudnia roku pamietnego...
2538       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2539      &                   0.0d0,1.0d0,0.0d0,
2540      &                   0.0d0,0.0d0,1.0d0/
2541 cd      write(iout,*) 'In EELEC'
2542 cd      do i=1,nloctyp
2543 cd        write(iout,*) 'Type',i
2544 cd        write(iout,*) 'B1',B1(:,i)
2545 cd        write(iout,*) 'B2',B2(:,i)
2546 cd        write(iout,*) 'CC',CC(:,:,i)
2547 cd        write(iout,*) 'DD',DD(:,:,i)
2548 cd        write(iout,*) 'EE',EE(:,:,i)
2549 cd      enddo
2550 cd      call check_vecgrad
2551 cd      stop
2552       if (icheckgrad.eq.1) then
2553         do i=1,nres-1
2554           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2555           do k=1,3
2556             dc_norm(k,i)=dc(k,i)*fac
2557           enddo
2558 c          write (iout,*) 'i',i,' fac',fac
2559         enddo
2560       endif
2561       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2562      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2563      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2564 c        call vec_and_deriv
2565         call set_matrices
2566       endif
2567 cd      do i=1,nres-1
2568 cd        write (iout,*) 'i=',i
2569 cd        do k=1,3
2570 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2571 cd        enddo
2572 cd        do k=1,3
2573 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2574 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2575 cd        enddo
2576 cd      enddo
2577       t_eelecij=0.0d0
2578       ees=0.0D0
2579       evdw1=0.0D0
2580       eel_loc=0.0d0
2581       eello_turn3=0.0d0
2582       eello_turn4=0.0d0
2583       ind=0
2584       do i=1,nres
2585         num_cont_hb(i)=0
2586       enddo
2587 cd      print '(a)','Enter EELEC'
2588 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2589       do i=1,nres
2590         gel_loc_loc(i)=0.0d0
2591         gcorr_loc(i)=0.0d0
2592       enddo
2593 c
2594 c
2595 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2596 C
2597 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2598 C
2599 #define CHUJ
2600 #ifdef DUPA
2601       do i=iturn3_start,iturn3_end
2602         dxi=dc(1,i)
2603         dyi=dc(2,i)
2604         dzi=dc(3,i)
2605         dx_normi=dc_norm(1,i)
2606         dy_normi=dc_norm(2,i)
2607         dz_normi=dc_norm(3,i)
2608         xmedi=c(1,i)+0.5d0*dxi
2609         ymedi=c(2,i)+0.5d0*dyi
2610         zmedi=c(3,i)+0.5d0*dzi
2611         num_conti=0
2612         call eelecij(i,i+2,ees,evdw1,eel_loc)
2613         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2614         num_cont_hb(i)=num_conti
2615       enddo
2616 #endif
2617 #ifdef CHUJ
2618       do i=iturn4_start,iturn4_end
2619         dxi=dc(1,i)
2620         dyi=dc(2,i)
2621         dzi=dc(3,i)
2622         dx_normi=dc_norm(1,i)
2623         dy_normi=dc_norm(2,i)
2624         dz_normi=dc_norm(3,i)
2625         xmedi=c(1,i)+0.5d0*dxi
2626         ymedi=c(2,i)+0.5d0*dyi
2627         zmedi=c(3,i)+0.5d0*dzi
2628         num_conti=0
2629         call eelecij(i,i+3,ees,evdw1,eel_loc)
2630         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
2631         num_cont_hb(i)=num_cont_hb(i)+num_conti
2632       enddo   ! i
2633 #endif
2634 c
2635 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2636 c
2637       do i=iatel_s,iatel_e
2638         dxi=dc(1,i)
2639         dyi=dc(2,i)
2640         dzi=dc(3,i)
2641         dx_normi=dc_norm(1,i)
2642         dy_normi=dc_norm(2,i)
2643         dz_normi=dc_norm(3,i)
2644         xmedi=c(1,i)+0.5d0*dxi
2645         ymedi=c(2,i)+0.5d0*dyi
2646         zmedi=c(3,i)+0.5d0*dzi
2647         num_conti=0
2648 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2649         do j=ielstart(i),ielend(i)
2650           call eelecij(i,j,ees,evdw1,eel_loc)
2651         enddo ! j
2652         num_cont_hb(i)=num_cont_hb(i)+num_conti
2653       enddo   ! i
2654 c      write (iout,*) "Number of loop steps in EELEC:",ind
2655 cd      do i=1,nres
2656 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2657 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2658 cd      enddo
2659 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2660 ccc      eel_loc=eel_loc+eello_turn3
2661 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2662       return
2663       end
2664 C-------------------------------------------------------------------------------
2665       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2666       implicit real*8 (a-h,o-z)
2667       include 'DIMENSIONS'
2668 #ifdef MPI
2669       include "mpif.h"
2670 #endif
2671       include 'COMMON.CONTROL'
2672       include 'COMMON.IOUNITS'
2673       include 'COMMON.GEO'
2674       include 'COMMON.VAR'
2675       include 'COMMON.LOCAL'
2676       include 'COMMON.CHAIN'
2677       include 'COMMON.DERIV'
2678       include 'COMMON.INTERACT'
2679       include 'COMMON.CONTACTS'
2680       include 'COMMON.TORSION'
2681       include 'COMMON.VECTORS'
2682       include 'COMMON.FFIELD'
2683       include 'COMMON.TIME1'
2684       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2685      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2686       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2687      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2688       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2689      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2690      &    num_conti,j1,j2
2691 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2692 #ifdef MOMENT
2693       double precision scal_el /1.0d0/
2694 #else
2695       double precision scal_el /0.5d0/
2696 #endif
2697 C 12/13/98
2698 C 13-go grudnia roku pamietnego...
2699       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2700      &                   0.0d0,1.0d0,0.0d0,
2701      &                   0.0d0,0.0d0,1.0d0/
2702 c          time00=MPI_Wtime()
2703 cd      write (iout,*) "eelecij",i,j
2704           ind=ind+1
2705           iteli=itel(i)
2706           itelj=itel(j)
2707           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2708           aaa=app(iteli,itelj)
2709           bbb=bpp(iteli,itelj)
2710           ael6i=ael6(iteli,itelj)
2711           ael3i=ael3(iteli,itelj)
2712           dxj=dc(1,j)
2713           dyj=dc(2,j)
2714           dzj=dc(3,j)
2715           dx_normj=dc_norm(1,j)
2716           dy_normj=dc_norm(2,j)
2717           dz_normj=dc_norm(3,j)
2718           xj=c(1,j)+0.5D0*dxj-xmedi
2719           yj=c(2,j)+0.5D0*dyj-ymedi
2720           zj=c(3,j)+0.5D0*dzj-zmedi
2721           rij=xj*xj+yj*yj+zj*zj
2722           rrmij=1.0D0/rij
2723           rij=dsqrt(rij)
2724           rmij=1.0D0/rij
2725           r3ij=rrmij*rmij
2726           r6ij=r3ij*r3ij
2727           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2728           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2729           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2730           fac=cosa-3.0D0*cosb*cosg
2731           ev1=aaa*r6ij*r6ij
2732 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2733           if (j.eq.i+2) ev1=scal_el*ev1
2734           ev2=bbb*r6ij
2735           fac3=ael6i*r6ij
2736           fac4=ael3i*r3ij
2737           evdwij=ev1+ev2
2738           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2739           el2=fac4*fac
2740           eesij=el1+el2
2741 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2742           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2743           ees=ees+eesij
2744           evdw1=evdw1+evdwij
2745 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2746 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2747 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2748 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2749
2750           if (energy_dec) then
2751               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2752               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2753           endif
2754
2755 C
2756 C Calculate contributions to the Cartesian gradient.
2757 C
2758 #ifdef SPLITELE
2759           facvdw=-6*rrmij*(ev1+evdwij)
2760           facel=-3*rrmij*(el1+eesij)
2761           fac1=fac
2762           erij(1)=xj*rmij
2763           erij(2)=yj*rmij
2764           erij(3)=zj*rmij
2765 *
2766 * Radial derivatives. First process both termini of the fragment (i,j)
2767 *
2768           ggg(1)=facel*xj
2769           ggg(2)=facel*yj
2770           ggg(3)=facel*zj
2771 c          do k=1,3
2772 c            ghalf=0.5D0*ggg(k)
2773 c            gelc(k,i)=gelc(k,i)+ghalf
2774 c            gelc(k,j)=gelc(k,j)+ghalf
2775 c          enddo
2776 c 9/28/08 AL Gradient compotents will be summed only at the end
2777           do k=1,3
2778             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2779             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2780           enddo
2781 *
2782 * Loop over residues i+1 thru j-1.
2783 *
2784 cgrad          do k=i+1,j-1
2785 cgrad            do l=1,3
2786 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2787 cgrad            enddo
2788 cgrad          enddo
2789           ggg(1)=facvdw*xj
2790           ggg(2)=facvdw*yj
2791           ggg(3)=facvdw*zj
2792 c          do k=1,3
2793 c            ghalf=0.5D0*ggg(k)
2794 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2795 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2796 c          enddo
2797 c 9/28/08 AL Gradient compotents will be summed only at the end
2798           do k=1,3
2799             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2800             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2801           enddo
2802 *
2803 * Loop over residues i+1 thru j-1.
2804 *
2805 cgrad          do k=i+1,j-1
2806 cgrad            do l=1,3
2807 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2808 cgrad            enddo
2809 cgrad          enddo
2810 #else
2811           facvdw=ev1+evdwij
2812           facel=el1+eesij
2813           fac1=fac
2814           fac=-3*rrmij*(facvdw+facvdw+facel)
2815           erij(1)=xj*rmij
2816           erij(2)=yj*rmij
2817           erij(3)=zj*rmij
2818 *
2819 * Radial derivatives. First process both termini of the fragment (i,j)
2820 *
2821           ggg(1)=fac*xj
2822           ggg(2)=fac*yj
2823           ggg(3)=fac*zj
2824 c          do k=1,3
2825 c            ghalf=0.5D0*ggg(k)
2826 c            gelc(k,i)=gelc(k,i)+ghalf
2827 c            gelc(k,j)=gelc(k,j)+ghalf
2828 c          enddo
2829 c 9/28/08 AL Gradient compotents will be summed only at the end
2830           do k=1,3
2831             gelc_long(k,j)=gelc(k,j)+ggg(k)
2832             gelc_long(k,i)=gelc(k,i)-ggg(k)
2833           enddo
2834 *
2835 * Loop over residues i+1 thru j-1.
2836 *
2837 cgrad          do k=i+1,j-1
2838 cgrad            do l=1,3
2839 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2840 cgrad            enddo
2841 cgrad          enddo
2842 c 9/28/08 AL Gradient compotents will be summed only at the end
2843           ggg(1)=facvdw*xj
2844           ggg(2)=facvdw*yj
2845           ggg(3)=facvdw*zj
2846           do k=1,3
2847             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2848             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2849           enddo
2850 #endif
2851 *
2852 * Angular part
2853 *
2854           ecosa=2.0D0*fac3*fac1+fac4
2855           fac4=-3.0D0*fac4
2856           fac3=-6.0D0*fac3
2857           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2858           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2859           do k=1,3
2860             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2861             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2862           enddo
2863 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2864 cd   &          (dcosg(k),k=1,3)
2865           do k=1,3
2866             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2867           enddo
2868 c          do k=1,3
2869 c            ghalf=0.5D0*ggg(k)
2870 c            gelc(k,i)=gelc(k,i)+ghalf
2871 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2872 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2873 c            gelc(k,j)=gelc(k,j)+ghalf
2874 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2875 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2876 c          enddo
2877 cgrad          do k=i+1,j-1
2878 cgrad            do l=1,3
2879 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2880 cgrad            enddo
2881 cgrad          enddo
2882           do k=1,3
2883             gelc(k,i)=gelc(k,i)
2884      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2885      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2886             gelc(k,j)=gelc(k,j)
2887      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2888      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2889             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2890             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2891           enddo
2892           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2893      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2894      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2895 C
2896 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2897 C   energy of a peptide unit is assumed in the form of a second-order
2898 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2899 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2900 C   are computed for EVERY pair of non-contiguous peptide groups.
2901 C
2902           if (j.lt.nres-1) then
2903             j1=j+1
2904             j2=j-1
2905           else
2906             j1=j-1
2907             j2=j-2
2908           endif
2909           kkk=0
2910           do k=1,2
2911             do l=1,2
2912               kkk=kkk+1
2913               muij(kkk)=mu(k,i)*mu(l,j)
2914             enddo
2915           enddo
2916 cd         write (iout,*) 'EELEC: i',i,' j',j
2917 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2918 cd          write(iout,*) 'muij',muij
2919           ury=scalar(uy(1,i),erij)
2920           urz=scalar(uz(1,i),erij)
2921           vry=scalar(uy(1,j),erij)
2922           vrz=scalar(uz(1,j),erij)
2923           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2924           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2925           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2926           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2927           fac=dsqrt(-ael6i)*r3ij
2928           a22=a22*fac
2929           a23=a23*fac
2930           a32=a32*fac
2931           a33=a33*fac
2932 cd          write (iout,'(4i5,4f10.5)')
2933 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2934 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2935 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2936 cd     &      uy(:,j),uz(:,j)
2937 cd          write (iout,'(4f10.5)')
2938 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2939 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2940 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2941 cd           write (iout,'(9f10.5/)')
2942 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2943 C Derivatives of the elements of A in virtual-bond vectors
2944           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2945           do k=1,3
2946             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2947             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2948             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2949             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2950             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2951             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2952             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2953             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2954             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2955             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2956             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2957             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2958           enddo
2959 C Compute radial contributions to the gradient
2960           facr=-3.0d0*rrmij
2961           a22der=a22*facr
2962           a23der=a23*facr
2963           a32der=a32*facr
2964           a33der=a33*facr
2965           agg(1,1)=a22der*xj
2966           agg(2,1)=a22der*yj
2967           agg(3,1)=a22der*zj
2968           agg(1,2)=a23der*xj
2969           agg(2,2)=a23der*yj
2970           agg(3,2)=a23der*zj
2971           agg(1,3)=a32der*xj
2972           agg(2,3)=a32der*yj
2973           agg(3,3)=a32der*zj
2974           agg(1,4)=a33der*xj
2975           agg(2,4)=a33der*yj
2976           agg(3,4)=a33der*zj
2977 C Add the contributions coming from er
2978           fac3=-3.0d0*fac
2979           do k=1,3
2980             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2981             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2982             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2983             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2984           enddo
2985           do k=1,3
2986 C Derivatives in DC(i)
2987             ghalf1=0.5d0*agg(k,1)
2988             ghalf2=0.5d0*agg(k,2)
2989             ghalf3=0.5d0*agg(k,3)
2990             ghalf4=0.5d0*agg(k,4)
2991             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2992      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2993             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2994      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2995             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2996      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2997             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2998      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2999 C Derivatives in DC(i+1)
3000             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3001      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3002             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3003      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3004             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3005      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3006             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3007      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3008 C Derivatives in DC(j)
3009             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3010      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3011             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3012      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3013             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3014      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3015             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3016      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3017 C Derivatives in DC(j+1) or DC(nres-1)
3018             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3019      &      -3.0d0*vryg(k,3)*ury)
3020             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3021      &      -3.0d0*vrzg(k,3)*ury)
3022             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3023      &      -3.0d0*vryg(k,3)*urz)
3024             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3025      &      -3.0d0*vrzg(k,3)*urz)
3026 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3027 cgrad              do l=1,4
3028 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3029 cgrad              enddo
3030 cgrad            endif
3031           enddo
3032           acipa(1,1)=a22
3033           acipa(1,2)=a23
3034           acipa(2,1)=a32
3035           acipa(2,2)=a33
3036           a22=-a22
3037           a23=-a23
3038           do l=1,2
3039             do k=1,3
3040               agg(k,l)=-agg(k,l)
3041               aggi(k,l)=-aggi(k,l)
3042               aggi1(k,l)=-aggi1(k,l)
3043               aggj(k,l)=-aggj(k,l)
3044               aggj1(k,l)=-aggj1(k,l)
3045             enddo
3046           enddo
3047           if (j.lt.nres-1) then
3048             a22=-a22
3049             a32=-a32
3050             do l=1,3,2
3051               do k=1,3
3052                 agg(k,l)=-agg(k,l)
3053                 aggi(k,l)=-aggi(k,l)
3054                 aggi1(k,l)=-aggi1(k,l)
3055                 aggj(k,l)=-aggj(k,l)
3056                 aggj1(k,l)=-aggj1(k,l)
3057               enddo
3058             enddo
3059           else
3060             a22=-a22
3061             a23=-a23
3062             a32=-a32
3063             a33=-a33
3064             do l=1,4
3065               do k=1,3
3066                 agg(k,l)=-agg(k,l)
3067                 aggi(k,l)=-aggi(k,l)
3068                 aggi1(k,l)=-aggi1(k,l)
3069                 aggj(k,l)=-aggj(k,l)
3070                 aggj1(k,l)=-aggj1(k,l)
3071               enddo
3072             enddo
3073           endif
3074           ENDIF ! WCORR
3075           IF (wel_loc.gt.0.0d0) THEN
3076 C Contribution to the local-electrostatic energy coming from the i-j pair
3077           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3078      &     +a33*muij(4)
3079 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3080
3081           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3082      &            'eelloc',i,j,eel_loc_ij
3083
3084           eel_loc=eel_loc+eel_loc_ij
3085 C Partial derivatives in virtual-bond dihedral angles gamma
3086           if (i.gt.1)
3087      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3088      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3089      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3090           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3091      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3092      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3093 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3094           do l=1,3
3095             ggg(l)=agg(l,1)*muij(1)+
3096      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3097             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3098             if (j.lt.nres-1 .or. j.eq.nres-1.and.j-i.eq.2)
3099      &        gel_loc_long_j2(l,j)=gel_loc_long_j2(l,j)+ggg(l)
3100             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3101 cgrad            ghalf=0.5d0*ggg(l)
3102 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3103 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3104           enddo
3105 cgrad          do k=i+1,j2
3106 cgrad            do l=1,3
3107 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3108 cgrad            enddo
3109 cgrad          enddo
3110 C Remaining derivatives of eello
3111           do l=1,3
3112             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3113      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3114             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3115      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3116             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3117      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3118             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3119      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3120           enddo
3121           ENDIF
3122           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3123             do k=1,4
3124               do l=1,3
3125                 ghalf=0.5d0*agg(l,k)
3126                 aggi(l,k)=aggi(l,k)+ghalf
3127                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3128                 aggj(l,k)=aggj(l,k)+ghalf
3129               enddo
3130             enddo
3131             if (j.eq.nres-1 .and. i.lt.j-2) then
3132               do k=1,4
3133                 do l=1,3
3134                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3135                 enddo
3136               enddo
3137             endif
3138           endif
3139 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3140 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3141           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3142      &       .and. num_conti.le.maxconts) then
3143 c            write (iout,*) i,j," entered corr"
3144 C
3145 C Calculate the contact function. The ith column of the array JCONT will
3146 C contain the numbers of atoms that make contacts with the atom I (of numbers
3147 C greater than I). The arrays FACONT and GACONT will contain the values of
3148 C the contact function and its derivative.
3149 c           r0ij=1.02D0*rpp(iteli,itelj)
3150 c           r0ij=1.11D0*rpp(iteli,itelj)
3151             r0ij=2.20D0*rpp(iteli,itelj)
3152 c           r0ij=1.55D0*rpp(iteli,itelj)
3153             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3154             if (fcont.gt.0.0D0) then
3155               num_conti=num_conti+1
3156               if (num_conti.gt.maxconts) then
3157                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3158      &                         ' will skip next contacts for this conf.'
3159               else
3160                 jcont_hb(num_conti,i)=j
3161                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3162      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3163 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3164 C  terms.
3165                 d_cont(num_conti,i)=rij
3166 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3167 C     --- Electrostatic-interaction matrix ---
3168                 a_chuj(1,1,num_conti,i)=a22
3169                 a_chuj(1,2,num_conti,i)=a23
3170                 a_chuj(2,1,num_conti,i)=a32
3171                 a_chuj(2,2,num_conti,i)=a33
3172 C     --- Gradient of rij
3173                 do kkk=1,3
3174                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3175                 enddo
3176                 kkll=0
3177                 do k=1,2
3178                   do l=1,2
3179                     kkll=kkll+1
3180                     do m=1,3
3181                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3182                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3183                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3184                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3185                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3186                     enddo
3187                   enddo
3188                 enddo
3189                 ENDIF
3190                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3191 C Calculate contact energies
3192                 cosa4=4.0D0*cosa
3193                 wij=cosa-3.0D0*cosb*cosg
3194                 cosbg1=cosb+cosg
3195                 cosbg2=cosb-cosg
3196 c               fac3=dsqrt(-ael6i)/r0ij**3
3197                 fac3=dsqrt(-ael6i)*r3ij
3198 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3199                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3200                 if (ees0tmp.gt.0) then
3201                   ees0pij=dsqrt(ees0tmp)
3202                 else
3203                   ees0pij=0
3204                 endif
3205 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3206                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3207                 if (ees0tmp.gt.0) then
3208                   ees0mij=dsqrt(ees0tmp)
3209                 else
3210                   ees0mij=0
3211                 endif
3212 c               ees0mij=0.0D0
3213                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3214                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3215 C Diagnostics. Comment out or remove after debugging!
3216 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3217 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3218 c               ees0m(num_conti,i)=0.0D0
3219 C End diagnostics.
3220 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3221 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3222 C Angular derivatives of the contact function
3223                 ees0pij1=fac3/ees0pij
3224                 ees0mij1=fac3/ees0mij
3225                 fac3p=-3.0D0*fac3*rrmij
3226                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3227                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3228 c               ees0mij1=0.0D0
3229                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3230                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3231                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3232                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3233                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3234                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3235                 ecosap=ecosa1+ecosa2
3236                 ecosbp=ecosb1+ecosb2
3237                 ecosgp=ecosg1+ecosg2
3238                 ecosam=ecosa1-ecosa2
3239                 ecosbm=ecosb1-ecosb2
3240                 ecosgm=ecosg1-ecosg2
3241 C Diagnostics
3242 c               ecosap=ecosa1
3243 c               ecosbp=ecosb1
3244 c               ecosgp=ecosg1
3245 c               ecosam=0.0D0
3246 c               ecosbm=0.0D0
3247 c               ecosgm=0.0D0
3248 C End diagnostics
3249                 facont_hb(num_conti,i)=fcont
3250                 fprimcont=fprimcont/rij
3251 cd              facont_hb(num_conti,i)=1.0D0
3252 C Following line is for diagnostics.
3253 cd              fprimcont=0.0D0
3254                 do k=1,3
3255                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3256                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3257                 enddo
3258                 do k=1,3
3259                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3260                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3261                 enddo
3262                 gggp(1)=gggp(1)+ees0pijp*xj
3263                 gggp(2)=gggp(2)+ees0pijp*yj
3264                 gggp(3)=gggp(3)+ees0pijp*zj
3265                 gggm(1)=gggm(1)+ees0mijp*xj
3266                 gggm(2)=gggm(2)+ees0mijp*yj
3267                 gggm(3)=gggm(3)+ees0mijp*zj
3268 C Derivatives due to the contact function
3269                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3270                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3271                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3272                 do k=1,3
3273                   ghalfp=0.5D0*gggp(k)
3274                   ghalfm=0.5D0*gggm(k)
3275                   gacontp_hb1(k,num_conti,i)=ghalfp
3276      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3277      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3278                   gacontp_hb2(k,num_conti,i)=ghalfp
3279      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3280      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3281                   gacontp_hb3(k,num_conti,i)=gggp(k)
3282                   gacontm_hb1(k,num_conti,i)=ghalfm
3283      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3284      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3285                   gacontm_hb2(k,num_conti,i)=ghalfm
3286      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3287      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3288                   gacontm_hb3(k,num_conti,i)=gggm(k)
3289                 enddo
3290 C Diagnostics. Comment out or remove after debugging!
3291 cdiag           do k=1,3
3292 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3293 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3294 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3295 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3296 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3297 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3298 cdiag           enddo
3299               ENDIF ! wcorr
3300               endif  ! num_conti.le.maxconts
3301             endif  ! fcont.gt.0
3302           endif    ! j.gt.i+1
3303 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3304       return
3305       end
3306 C-----------------------------------------------------------------------------
3307       subroutine eturn3(i,eello_turn3)
3308 C Third- and fourth-order contributions from turns
3309       implicit real*8 (a-h,o-z)
3310       include 'DIMENSIONS'
3311       include 'COMMON.IOUNITS'
3312       include 'COMMON.GEO'
3313       include 'COMMON.VAR'
3314       include 'COMMON.LOCAL'
3315       include 'COMMON.CHAIN'
3316       include 'COMMON.DERIV'
3317       include 'COMMON.INTERACT'
3318       include 'COMMON.CONTACTS'
3319       include 'COMMON.TORSION'
3320       include 'COMMON.VECTORS'
3321       include 'COMMON.FFIELD'
3322       include 'COMMON.CONTROL'
3323       dimension ggg(3)
3324       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3325      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3326      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3327       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3328      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3329       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3330      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3331      &    num_conti,j1,j2
3332       j=i+2
3333 c      write (iout,*) "eturn3",i,j,j1,j2
3334       a_temp(1,1)=a22
3335       a_temp(1,2)=a23
3336       a_temp(2,1)=a32
3337       a_temp(2,2)=a33
3338 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3339 C
3340 C               Third-order contributions
3341 C
3342 C                 (i+2)o----(i+3)
3343 C                      | |
3344 C                      | |
3345 C                 (i+1)o----i
3346 C
3347 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3348 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3349         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3350         call transpose2(auxmat(1,1),auxmat1(1,1))
3351         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3352         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3353         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3354      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3355 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3356 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3357 cd     &    ' eello_turn3_num',4*eello_turn3_num
3358 C Derivatives in gamma(i)
3359         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3360         call transpose2(auxmat2(1,1),auxmat3(1,1))
3361         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3362         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3363 C Derivatives in gamma(i+1)
3364         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3365         call transpose2(auxmat2(1,1),auxmat3(1,1))
3366         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3367         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3368      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3369 C Cartesian derivatives
3370         do l=1,3
3371 c            ghalf1=0.5d0*agg(l,1)
3372 c            ghalf2=0.5d0*agg(l,2)
3373 c            ghalf3=0.5d0*agg(l,3)
3374 c            ghalf4=0.5d0*agg(l,4)
3375           a_temp(1,1)=aggi(l,1)!+ghalf1
3376           a_temp(1,2)=aggi(l,2)!+ghalf2
3377           a_temp(2,1)=aggi(l,3)!+ghalf3
3378           a_temp(2,2)=aggi(l,4)!+ghalf4
3379           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3380           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3381      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3382           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3383           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3384           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3385           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3386           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3387           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3388      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3389           a_temp(1,1)=aggj(l,1)!+ghalf1
3390           a_temp(1,2)=aggj(l,2)!+ghalf2
3391           a_temp(2,1)=aggj(l,3)!+ghalf3
3392           a_temp(2,2)=aggj(l,4)!+ghalf4
3393           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3394           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3395      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3396           a_temp(1,1)=aggj1(l,1)
3397           a_temp(1,2)=aggj1(l,2)
3398           a_temp(2,1)=aggj1(l,3)
3399           a_temp(2,2)=aggj1(l,4)
3400           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3401           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3402      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3403         enddo
3404       return
3405       end
3406 C-------------------------------------------------------------------------------
3407       subroutine eturn4(i,eello_turn4)
3408 C Third- and fourth-order contributions from turns
3409       implicit real*8 (a-h,o-z)
3410       include 'DIMENSIONS'
3411       include 'COMMON.IOUNITS'
3412       include 'COMMON.GEO'
3413       include 'COMMON.VAR'
3414       include 'COMMON.LOCAL'
3415       include 'COMMON.CHAIN'
3416       include 'COMMON.DERIV'
3417       include 'COMMON.INTERACT'
3418       include 'COMMON.CONTACTS'
3419       include 'COMMON.TORSION'
3420       include 'COMMON.VECTORS'
3421       include 'COMMON.FFIELD'
3422       include 'COMMON.CONTROL'
3423       dimension ggg(3)
3424       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3425      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3426      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3427       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3428      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3429       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3430      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3431      &    num_conti,j1,j2
3432       j=i+3
3433 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3434 C
3435 C               Fourth-order contributions
3436 C
3437 C                 (i+3)o----(i+4)
3438 C                     /  |
3439 C               (i+2)o   |
3440 C                     \  |
3441 C                 (i+1)o----i
3442 C
3443 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3444 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3445         write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3446         a_temp(1,1)=a22
3447         a_temp(1,2)=a23
3448         a_temp(2,1)=a32
3449         a_temp(2,2)=a33
3450         iti1=itortyp(itype(i+1))
3451         iti2=itortyp(itype(i+2))
3452         iti3=itortyp(itype(i+3))
3453         write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3454         call transpose2(EUg(1,1,i+1),e1t(1,1))
3455         call transpose2(Eug(1,1,i+2),e2t(1,1))
3456         call transpose2(Eug(1,1,i+3),e3t(1,1))
3457         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3458         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3459         s1=scalar2(b1(1,iti2),auxvec(1))
3460         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3461         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3462         s2=scalar2(b1(1,iti1),auxvec(1))
3463         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3464         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3465         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3466         eello_turn4=eello_turn4-(s1+s2+s3)
3467         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3468      &      'eturn4',i,j,-(s1+s2+s3)
3469 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3470 cd     &    ' eello_turn4_num',8*eello_turn4_num
3471 C Derivatives in gamma(i)
3472         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3473         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3474         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3475         s1=scalar2(b1(1,iti2),auxvec(1))
3476         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3477         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3478         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3479 C Derivatives in gamma(i+1)
3480         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3481         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3482         s2=scalar2(b1(1,iti1),auxvec(1))
3483         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3484         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3485         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3486         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3487 C Derivatives in gamma(i+2)
3488         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3489         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3490         s1=scalar2(b1(1,iti2),auxvec(1))
3491         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3492         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3493         s2=scalar2(b1(1,iti1),auxvec(1))
3494         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3495         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3496         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3497         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3498 C Cartesian derivatives
3499 C Derivatives of this turn contributions in DC(i+2)
3500         if (j.lt.nres-1) then
3501           do l=1,3
3502             a_temp(1,1)=agg(l,1)
3503             a_temp(1,2)=agg(l,2)
3504             a_temp(2,1)=agg(l,3)
3505             a_temp(2,2)=agg(l,4)
3506             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3507             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3508             s1=scalar2(b1(1,iti2),auxvec(1))
3509             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3510             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3511             s2=scalar2(b1(1,iti1),auxvec(1))
3512             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3513             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3514             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3515             ggg(l)=-(s1+s2+s3)
3516             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3517           enddo
3518         endif
3519 C Remaining derivatives of this turn contribution
3520         do l=1,3
3521           a_temp(1,1)=aggi(l,1)
3522           a_temp(1,2)=aggi(l,2)
3523           a_temp(2,1)=aggi(l,3)
3524           a_temp(2,2)=aggi(l,4)
3525           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3526           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3527           s1=scalar2(b1(1,iti2),auxvec(1))
3528           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3529           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3530           s2=scalar2(b1(1,iti1),auxvec(1))
3531           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3532           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3533           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3534           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3535           a_temp(1,1)=aggi1(l,1)
3536           a_temp(1,2)=aggi1(l,2)
3537           a_temp(2,1)=aggi1(l,3)
3538           a_temp(2,2)=aggi1(l,4)
3539           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3540           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3541           s1=scalar2(b1(1,iti2),auxvec(1))
3542           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3543           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3544           s2=scalar2(b1(1,iti1),auxvec(1))
3545           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3546           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3547           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3548           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3549           a_temp(1,1)=aggj(l,1)
3550           a_temp(1,2)=aggj(l,2)
3551           a_temp(2,1)=aggj(l,3)
3552           a_temp(2,2)=aggj(l,4)
3553           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3554           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3555           s1=scalar2(b1(1,iti2),auxvec(1))
3556           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3557           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3558           s2=scalar2(b1(1,iti1),auxvec(1))
3559           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3560           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3561           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3562           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3563           a_temp(1,1)=aggj1(l,1)
3564           a_temp(1,2)=aggj1(l,2)
3565           a_temp(2,1)=aggj1(l,3)
3566           a_temp(2,2)=aggj1(l,4)
3567           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3568           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3569           s1=scalar2(b1(1,iti2),auxvec(1))
3570           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3571           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3572           s2=scalar2(b1(1,iti1),auxvec(1))
3573           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3574           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3575           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3576           write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3577           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3578         enddo
3579       return
3580       end
3581 C-----------------------------------------------------------------------------
3582       subroutine vecpr(u,v,w)
3583       implicit real*8(a-h,o-z)
3584       dimension u(3),v(3),w(3)
3585       w(1)=u(2)*v(3)-u(3)*v(2)
3586       w(2)=-u(1)*v(3)+u(3)*v(1)
3587       w(3)=u(1)*v(2)-u(2)*v(1)
3588       return
3589       end
3590 C-----------------------------------------------------------------------------
3591       subroutine unormderiv(u,ugrad,unorm,ungrad)
3592 C This subroutine computes the derivatives of a normalized vector u, given
3593 C the derivatives computed without normalization conditions, ugrad. Returns
3594 C ungrad.
3595       implicit none
3596       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3597       double precision vec(3)
3598       double precision scalar
3599       integer i,j
3600 c      write (2,*) 'ugrad',ugrad
3601 c      write (2,*) 'u',u
3602       do i=1,3
3603         vec(i)=scalar(ugrad(1,i),u(1))
3604       enddo
3605 c      write (2,*) 'vec',vec
3606       do i=1,3
3607         do j=1,3
3608           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3609         enddo
3610       enddo
3611 c      write (2,*) 'ungrad',ungrad
3612       return
3613       end
3614 C-----------------------------------------------------------------------------
3615       subroutine escp_soft_sphere(evdw2,evdw2_14)
3616 C
3617 C This subroutine calculates the excluded-volume interaction energy between
3618 C peptide-group centers and side chains and its gradient in virtual-bond and
3619 C side-chain vectors.
3620 C
3621       implicit real*8 (a-h,o-z)
3622       include 'DIMENSIONS'
3623       include 'COMMON.GEO'
3624       include 'COMMON.VAR'
3625       include 'COMMON.LOCAL'
3626       include 'COMMON.CHAIN'
3627       include 'COMMON.DERIV'
3628       include 'COMMON.INTERACT'
3629       include 'COMMON.FFIELD'
3630       include 'COMMON.IOUNITS'
3631       include 'COMMON.CONTROL'
3632       dimension ggg(3)
3633       evdw2=0.0D0
3634       evdw2_14=0.0d0
3635       r0_scp=4.5d0
3636 cd    print '(a)','Enter ESCP'
3637 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3638       do i=iatscp_s,iatscp_e
3639         iteli=itel(i)
3640         xi=0.5D0*(c(1,i)+c(1,i+1))
3641         yi=0.5D0*(c(2,i)+c(2,i+1))
3642         zi=0.5D0*(c(3,i)+c(3,i+1))
3643
3644         do iint=1,nscp_gr(i)
3645
3646         do j=iscpstart(i,iint),iscpend(i,iint)
3647           itypj=itype(j)
3648 C Uncomment following three lines for SC-p interactions
3649 c         xj=c(1,nres+j)-xi
3650 c         yj=c(2,nres+j)-yi
3651 c         zj=c(3,nres+j)-zi
3652 C Uncomment following three lines for Ca-p interactions
3653           xj=c(1,j)-xi
3654           yj=c(2,j)-yi
3655           zj=c(3,j)-zi
3656           rij=xj*xj+yj*yj+zj*zj
3657           r0ij=r0_scp
3658           r0ijsq=r0ij*r0ij
3659           if (rij.lt.r0ijsq) then
3660             evdwij=0.25d0*(rij-r0ijsq)**2
3661             fac=rij-r0ijsq
3662           else
3663             evdwij=0.0d0
3664             fac=0.0d0
3665           endif
3666           evdw2=evdw2+evdwij
3667 C
3668 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3669 C
3670           ggg(1)=xj*fac
3671           ggg(2)=yj*fac
3672           ggg(3)=zj*fac
3673           if (j.lt.i) then
3674 cd          write (iout,*) 'j<i'
3675 C Uncomment following three lines for SC-p interactions
3676 c           do k=1,3
3677 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3678 c           enddo
3679           else
3680 cd          write (iout,*) 'j>i'
3681             do k=1,3
3682               ggg(k)=-ggg(k)
3683 C Uncomment following line for SC-p interactions
3684 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3685             enddo
3686           endif
3687           do k=1,3
3688             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3689           enddo
3690           kstart=min0(i+1,j)
3691           kend=max0(i-1,j-1)
3692 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3693 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3694           do k=kstart,kend
3695             do l=1,3
3696               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3697             enddo
3698           enddo
3699         enddo
3700
3701         enddo ! iint
3702       enddo ! i
3703       return
3704       end
3705 C-----------------------------------------------------------------------------
3706       subroutine escp(evdw2,evdw2_14)
3707 C
3708 C This subroutine calculates the excluded-volume interaction energy between
3709 C peptide-group centers and side chains and its gradient in virtual-bond and
3710 C side-chain vectors.
3711 C
3712       implicit real*8 (a-h,o-z)
3713       include 'DIMENSIONS'
3714       include 'COMMON.GEO'
3715       include 'COMMON.VAR'
3716       include 'COMMON.LOCAL'
3717       include 'COMMON.CHAIN'
3718       include 'COMMON.DERIV'
3719       include 'COMMON.INTERACT'
3720       include 'COMMON.FFIELD'
3721       include 'COMMON.IOUNITS'
3722       include 'COMMON.CONTROL'
3723       dimension ggg(3)
3724       evdw2=0.0D0
3725       evdw2_14=0.0d0
3726 cd    print '(a)','Enter ESCP'
3727 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3728       do i=iatscp_s,iatscp_e
3729         iteli=itel(i)
3730         xi=0.5D0*(c(1,i)+c(1,i+1))
3731         yi=0.5D0*(c(2,i)+c(2,i+1))
3732         zi=0.5D0*(c(3,i)+c(3,i+1))
3733
3734         do iint=1,nscp_gr(i)
3735
3736         do j=iscpstart(i,iint),iscpend(i,iint)
3737           itypj=itype(j)
3738 C Uncomment following three lines for SC-p interactions
3739 c         xj=c(1,nres+j)-xi
3740 c         yj=c(2,nres+j)-yi
3741 c         zj=c(3,nres+j)-zi
3742 C Uncomment following three lines for Ca-p interactions
3743           xj=c(1,j)-xi
3744           yj=c(2,j)-yi
3745           zj=c(3,j)-zi
3746           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3747           fac=rrij**expon2
3748           e1=fac*fac*aad(itypj,iteli)
3749           e2=fac*bad(itypj,iteli)
3750           if (iabs(j-i) .le. 2) then
3751             e1=scal14*e1
3752             e2=scal14*e2
3753             evdw2_14=evdw2_14+e1+e2
3754           endif
3755           evdwij=e1+e2
3756           evdw2=evdw2+evdwij
3757           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3758      &        'evdw2',i,j,evdwij
3759 C
3760 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3761 C
3762           fac=-(evdwij+e1)*rrij
3763           ggg(1)=xj*fac
3764           ggg(2)=yj*fac
3765           ggg(3)=zj*fac
3766 cgrad          if (j.lt.i) then
3767 cd          write (iout,*) 'j<i'
3768 C Uncomment following three lines for SC-p interactions
3769 c           do k=1,3
3770 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3771 c           enddo
3772 cgrad          else
3773 cd          write (iout,*) 'j>i'
3774 cgrad            do k=1,3
3775 cgrad              ggg(k)=-ggg(k)
3776 C Uncomment following line for SC-p interactions
3777 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3778 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3779 cgrad            enddo
3780 cgrad          endif
3781 cgrad          do k=1,3
3782 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3783 cgrad          enddo
3784 cgrad          kstart=min0(i+1,j)
3785 cgrad          kend=max0(i-1,j-1)
3786 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3787 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3788 cgrad          do k=kstart,kend
3789 cgrad            do l=1,3
3790 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3791 cgrad            enddo
3792 cgrad          enddo
3793           do k=1,3
3794             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3795             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3796           enddo
3797         enddo
3798
3799         enddo ! iint
3800       enddo ! i
3801       do i=1,nct
3802         do j=1,3
3803           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3804           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3805           gradx_scp(j,i)=expon*gradx_scp(j,i)
3806         enddo
3807       enddo
3808 C******************************************************************************
3809 C
3810 C                              N O T E !!!
3811 C
3812 C To save time the factor EXPON has been extracted from ALL components
3813 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3814 C use!
3815 C
3816 C******************************************************************************
3817       return
3818       end
3819 C--------------------------------------------------------------------------
3820       subroutine edis(ehpb)
3821 C
3822 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3823 C
3824       implicit real*8 (a-h,o-z)
3825       include 'DIMENSIONS'
3826       include 'COMMON.SBRIDGE'
3827       include 'COMMON.CHAIN'
3828       include 'COMMON.DERIV'
3829       include 'COMMON.VAR'
3830       include 'COMMON.INTERACT'
3831       dimension ggg(3)
3832       ehpb=0.0D0
3833 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3834 cd    print *,'link_start=',link_start,' link_end=',link_end
3835       if (link_end.eq.0) return
3836       do i=link_start,link_end
3837 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3838 C CA-CA distance used in regularization of structure.
3839         ii=ihpb(i)
3840         jj=jhpb(i)
3841 C iii and jjj point to the residues for which the distance is assigned.
3842         if (ii.gt.nres) then
3843           iii=ii-nres
3844           jjj=jj-nres
3845         else
3846           iii=ii
3847           jjj=jj
3848         endif
3849 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3850 C    distance and angle dependent SS bond potential.
3851         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3852           call ssbond_ene(iii,jjj,eij)
3853           ehpb=ehpb+2*eij
3854         else
3855 C Calculate the distance between the two points and its difference from the
3856 C target distance.
3857         dd=dist(ii,jj)
3858         rdis=dd-dhpb(i)
3859 C Get the force constant corresponding to this distance.
3860         waga=forcon(i)
3861 C Calculate the contribution to energy.
3862         ehpb=ehpb+waga*rdis*rdis
3863 C
3864 C Evaluate gradient.
3865 C
3866         fac=waga*rdis/dd
3867 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3868 cd   &   ' waga=',waga,' fac=',fac
3869         do j=1,3
3870           ggg(j)=fac*(c(j,jj)-c(j,ii))
3871         enddo
3872 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3873 C If this is a SC-SC distance, we need to calculate the contributions to the
3874 C Cartesian gradient in the SC vectors (ghpbx).
3875         if (iii.lt.ii) then
3876           do j=1,3
3877             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3878             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3879           enddo
3880         endif
3881         do j=iii,jjj-1
3882           do k=1,3
3883             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3884           enddo
3885         enddo
3886         endif
3887       enddo
3888       ehpb=0.5D0*ehpb
3889       return
3890       end
3891 C--------------------------------------------------------------------------
3892       subroutine ssbond_ene(i,j,eij)
3893 C
3894 C Calculate the distance and angle dependent SS-bond potential energy
3895 C using a free-energy function derived based on RHF/6-31G** ab initio
3896 C calculations of diethyl disulfide.
3897 C
3898 C A. Liwo and U. Kozlowska, 11/24/03
3899 C
3900       implicit real*8 (a-h,o-z)
3901       include 'DIMENSIONS'
3902       include 'COMMON.SBRIDGE'
3903       include 'COMMON.CHAIN'
3904       include 'COMMON.DERIV'
3905       include 'COMMON.LOCAL'
3906       include 'COMMON.INTERACT'
3907       include 'COMMON.VAR'
3908       include 'COMMON.IOUNITS'
3909       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3910       itypi=itype(i)
3911       xi=c(1,nres+i)
3912       yi=c(2,nres+i)
3913       zi=c(3,nres+i)
3914       dxi=dc_norm(1,nres+i)
3915       dyi=dc_norm(2,nres+i)
3916       dzi=dc_norm(3,nres+i)
3917       dsci_inv=dsc_inv(itypi)
3918       itypj=itype(j)
3919       dscj_inv=dsc_inv(itypj)
3920       xj=c(1,nres+j)-xi
3921       yj=c(2,nres+j)-yi
3922       zj=c(3,nres+j)-zi
3923       dxj=dc_norm(1,nres+j)
3924       dyj=dc_norm(2,nres+j)
3925       dzj=dc_norm(3,nres+j)
3926       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3927       rij=dsqrt(rrij)
3928       erij(1)=xj*rij
3929       erij(2)=yj*rij
3930       erij(3)=zj*rij
3931       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3932       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3933       om12=dxi*dxj+dyi*dyj+dzi*dzj
3934       do k=1,3
3935         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3936         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3937       enddo
3938       rij=1.0d0/rij
3939       deltad=rij-d0cm
3940       deltat1=1.0d0-om1
3941       deltat2=1.0d0+om2
3942       deltat12=om2-om1+2.0d0
3943       cosphi=om12-om1*om2
3944       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3945      &  +akct*deltad*deltat12
3946      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3947 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3948 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3949 c     &  " deltat12",deltat12," eij",eij
3950       ed=2*akcm*deltad+akct*deltat12
3951       pom1=akct*deltad
3952       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3953       eom1=-2*akth*deltat1-pom1-om2*pom2
3954       eom2= 2*akth*deltat2+pom1-om1*pom2
3955       eom12=pom2
3956       do k=1,3
3957         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3958       enddo
3959       do k=1,3
3960         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3961      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3962         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3963      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3964       enddo
3965 C
3966 C Calculate the components of the gradient in DC and X
3967 C
3968       do k=i,j-1
3969         do l=1,3
3970           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3971         enddo
3972       enddo
3973       return
3974       end
3975 C--------------------------------------------------------------------------
3976       subroutine ebond(estr)
3977 c
3978 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3979 c
3980       implicit real*8 (a-h,o-z)
3981       include 'DIMENSIONS'
3982       include 'COMMON.LOCAL'
3983       include 'COMMON.GEO'
3984       include 'COMMON.INTERACT'
3985       include 'COMMON.DERIV'
3986       include 'COMMON.VAR'
3987       include 'COMMON.CHAIN'
3988       include 'COMMON.IOUNITS'
3989       include 'COMMON.NAMES'
3990       include 'COMMON.FFIELD'
3991       include 'COMMON.CONTROL'
3992       include 'COMMON.SETUP'
3993       double precision u(3),ud(3)
3994       estr=0.0d0
3995       do i=ibondp_start,ibondp_end
3996         diff = vbld(i)-vbldp0
3997 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3998         estr=estr+diff*diff
3999         do j=1,3
4000           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4001         enddo
4002 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4003       enddo
4004       estr=0.5d0*AKP*estr
4005 c
4006 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4007 c
4008       do i=ibond_start,ibond_end
4009         iti=itype(i)
4010         if (iti.ne.10) then
4011           nbi=nbondterm(iti)
4012           if (nbi.eq.1) then
4013             diff=vbld(i+nres)-vbldsc0(1,iti)
4014 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4015 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4016             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4017             do j=1,3
4018               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4019             enddo
4020           else
4021             do j=1,nbi
4022               diff=vbld(i+nres)-vbldsc0(j,iti)
4023               ud(j)=aksc(j,iti)*diff
4024               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4025             enddo
4026             uprod=u(1)
4027             do j=2,nbi
4028               uprod=uprod*u(j)
4029             enddo
4030             usum=0.0d0
4031             usumsqder=0.0d0
4032             do j=1,nbi
4033               uprod1=1.0d0
4034               uprod2=1.0d0
4035               do k=1,nbi
4036                 if (k.ne.j) then
4037                   uprod1=uprod1*u(k)
4038                   uprod2=uprod2*u(k)*u(k)
4039                 endif
4040               enddo
4041               usum=usum+uprod1
4042               usumsqder=usumsqder+ud(j)*uprod2
4043             enddo
4044             estr=estr+uprod/usum
4045             do j=1,3
4046              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4047             enddo
4048           endif
4049         endif
4050       enddo
4051       return
4052       end
4053 #ifdef CRYST_THETA
4054 C--------------------------------------------------------------------------
4055       subroutine ebend(etheta)
4056 C
4057 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4058 C angles gamma and its derivatives in consecutive thetas and gammas.
4059 C
4060       implicit real*8 (a-h,o-z)
4061       include 'DIMENSIONS'
4062       include 'COMMON.LOCAL'
4063       include 'COMMON.GEO'
4064       include 'COMMON.INTERACT'
4065       include 'COMMON.DERIV'
4066       include 'COMMON.VAR'
4067       include 'COMMON.CHAIN'
4068       include 'COMMON.IOUNITS'
4069       include 'COMMON.NAMES'
4070       include 'COMMON.FFIELD'
4071       include 'COMMON.CONTROL'
4072       common /calcthet/ term1,term2,termm,diffak,ratak,
4073      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4074      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4075       double precision y(2),z(2)
4076       delta=0.02d0*pi
4077 c      time11=dexp(-2*time)
4078 c      time12=1.0d0
4079       etheta=0.0D0
4080 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4081       do i=ithet_start,ithet_end
4082 C Zero the energy function and its derivative at 0 or pi.
4083         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4084         it=itype(i-1)
4085         if (i.gt.3) then
4086 #ifdef OSF
4087           phii=phi(i)
4088           if (phii.ne.phii) phii=150.0
4089 #else
4090           phii=phi(i)
4091 #endif
4092           y(1)=dcos(phii)
4093           y(2)=dsin(phii)
4094         else
4095           y(1)=0.0D0
4096           y(2)=0.0D0
4097         endif
4098         if (i.lt.nres) then
4099 #ifdef OSF
4100           phii1=phi(i+1)
4101           if (phii1.ne.phii1) phii1=150.0
4102           phii1=pinorm(phii1)
4103           z(1)=cos(phii1)
4104 #else
4105           phii1=phi(i+1)
4106           z(1)=dcos(phii1)
4107 #endif
4108           z(2)=dsin(phii1)
4109         else
4110           z(1)=0.0D0
4111           z(2)=0.0D0
4112         endif
4113 C Calculate the "mean" value of theta from the part of the distribution
4114 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4115 C In following comments this theta will be referred to as t_c.
4116         thet_pred_mean=0.0d0
4117         do k=1,2
4118           athetk=athet(k,it)
4119           bthetk=bthet(k,it)
4120           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4121         enddo
4122         dthett=thet_pred_mean*ssd
4123         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4124 C Derivatives of the "mean" values in gamma1 and gamma2.
4125         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4126         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4127         if (theta(i).gt.pi-delta) then
4128           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4129      &         E_tc0)
4130           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4131           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4132           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4133      &        E_theta)
4134           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4135      &        E_tc)
4136         else if (theta(i).lt.delta) then
4137           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4138           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4139           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4140      &        E_theta)
4141           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4142           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4143      &        E_tc)
4144         else
4145           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4146      &        E_theta,E_tc)
4147         endif
4148         etheta=etheta+ethetai
4149         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4150      &      'ebend',i,ethetai
4151         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4152         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4153         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4154       enddo
4155 C Ufff.... We've done all this!!!
4156       return
4157       end
4158 C---------------------------------------------------------------------------
4159       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4160      &     E_tc)
4161       implicit real*8 (a-h,o-z)
4162       include 'DIMENSIONS'
4163       include 'COMMON.LOCAL'
4164       include 'COMMON.IOUNITS'
4165       common /calcthet/ term1,term2,termm,diffak,ratak,
4166      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4167      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4168 C Calculate the contributions to both Gaussian lobes.
4169 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4170 C The "polynomial part" of the "standard deviation" of this part of
4171 C the distribution.
4172         sig=polthet(3,it)
4173         do j=2,0,-1
4174           sig=sig*thet_pred_mean+polthet(j,it)
4175         enddo
4176 C Derivative of the "interior part" of the "standard deviation of the"
4177 C gamma-dependent Gaussian lobe in t_c.
4178         sigtc=3*polthet(3,it)
4179         do j=2,1,-1
4180           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4181         enddo
4182         sigtc=sig*sigtc
4183 C Set the parameters of both Gaussian lobes of the distribution.
4184 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4185         fac=sig*sig+sigc0(it)
4186         sigcsq=fac+fac
4187         sigc=1.0D0/sigcsq
4188 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4189         sigsqtc=-4.0D0*sigcsq*sigtc
4190 c       print *,i,sig,sigtc,sigsqtc
4191 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4192         sigtc=-sigtc/(fac*fac)
4193 C Following variable is sigma(t_c)**(-2)
4194         sigcsq=sigcsq*sigcsq
4195         sig0i=sig0(it)
4196         sig0inv=1.0D0/sig0i**2
4197         delthec=thetai-thet_pred_mean
4198         delthe0=thetai-theta0i
4199         term1=-0.5D0*sigcsq*delthec*delthec
4200         term2=-0.5D0*sig0inv*delthe0*delthe0
4201 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4202 C NaNs in taking the logarithm. We extract the largest exponent which is added
4203 C to the energy (this being the log of the distribution) at the end of energy
4204 C term evaluation for this virtual-bond angle.
4205         if (term1.gt.term2) then
4206           termm=term1
4207           term2=dexp(term2-termm)
4208           term1=1.0d0
4209         else
4210           termm=term2
4211           term1=dexp(term1-termm)
4212           term2=1.0d0
4213         endif
4214 C The ratio between the gamma-independent and gamma-dependent lobes of
4215 C the distribution is a Gaussian function of thet_pred_mean too.
4216         diffak=gthet(2,it)-thet_pred_mean
4217         ratak=diffak/gthet(3,it)**2
4218         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4219 C Let's differentiate it in thet_pred_mean NOW.
4220         aktc=ak*ratak
4221 C Now put together the distribution terms to make complete distribution.
4222         termexp=term1+ak*term2
4223         termpre=sigc+ak*sig0i
4224 C Contribution of the bending energy from this theta is just the -log of
4225 C the sum of the contributions from the two lobes and the pre-exponential
4226 C factor. Simple enough, isn't it?
4227         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4228 C NOW the derivatives!!!
4229 C 6/6/97 Take into account the deformation.
4230         E_theta=(delthec*sigcsq*term1
4231      &       +ak*delthe0*sig0inv*term2)/termexp
4232         E_tc=((sigtc+aktc*sig0i)/termpre
4233      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4234      &       aktc*term2)/termexp)
4235       return
4236       end
4237 c-----------------------------------------------------------------------------
4238       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4239       implicit real*8 (a-h,o-z)
4240       include 'DIMENSIONS'
4241       include 'COMMON.LOCAL'
4242       include 'COMMON.IOUNITS'
4243       common /calcthet/ term1,term2,termm,diffak,ratak,
4244      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4245      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4246       delthec=thetai-thet_pred_mean
4247       delthe0=thetai-theta0i
4248 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4249       t3 = thetai-thet_pred_mean
4250       t6 = t3**2
4251       t9 = term1
4252       t12 = t3*sigcsq
4253       t14 = t12+t6*sigsqtc
4254       t16 = 1.0d0
4255       t21 = thetai-theta0i
4256       t23 = t21**2
4257       t26 = term2
4258       t27 = t21*t26
4259       t32 = termexp
4260       t40 = t32**2
4261       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4262      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4263      & *(-t12*t9-ak*sig0inv*t27)
4264       return
4265       end
4266 #else
4267 C--------------------------------------------------------------------------
4268       subroutine ebend(etheta)
4269 C
4270 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4271 C angles gamma and its derivatives in consecutive thetas and gammas.
4272 C ab initio-derived potentials from
4273 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4274 C
4275       implicit real*8 (a-h,o-z)
4276       include 'DIMENSIONS'
4277       include 'COMMON.LOCAL'
4278       include 'COMMON.GEO'
4279       include 'COMMON.INTERACT'
4280       include 'COMMON.DERIV'
4281       include 'COMMON.VAR'
4282       include 'COMMON.CHAIN'
4283       include 'COMMON.IOUNITS'
4284       include 'COMMON.NAMES'
4285       include 'COMMON.FFIELD'
4286       include 'COMMON.CONTROL'
4287       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4288      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4289      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4290      & sinph1ph2(maxdouble,maxdouble)
4291       logical lprn /.false./, lprn1 /.false./
4292       etheta=0.0D0
4293       do i=ithet_start,ithet_end
4294         dethetai=0.0d0
4295         dephii=0.0d0
4296         dephii1=0.0d0
4297         theti2=0.5d0*theta(i)
4298         ityp2=ithetyp(itype(i-1))
4299         do k=1,nntheterm
4300           coskt(k)=dcos(k*theti2)
4301           sinkt(k)=dsin(k*theti2)
4302         enddo
4303         if (i.gt.3) then
4304 #ifdef OSF
4305           phii=phi(i)
4306           if (phii.ne.phii) phii=150.0
4307 #else
4308           phii=phi(i)
4309 #endif
4310           ityp1=ithetyp(itype(i-2))
4311           do k=1,nsingle
4312             cosph1(k)=dcos(k*phii)
4313             sinph1(k)=dsin(k*phii)
4314           enddo
4315         else
4316           phii=0.0d0
4317           ityp1=nthetyp+1
4318           do k=1,nsingle
4319             cosph1(k)=0.0d0
4320             sinph1(k)=0.0d0
4321           enddo
4322         endif
4323         if (i.lt.nres) then
4324 #ifdef OSF
4325           phii1=phi(i+1)
4326           if (phii1.ne.phii1) phii1=150.0
4327           phii1=pinorm(phii1)
4328 #else
4329           phii1=phi(i+1)
4330 #endif
4331           ityp3=ithetyp(itype(i))
4332           do k=1,nsingle
4333             cosph2(k)=dcos(k*phii1)
4334             sinph2(k)=dsin(k*phii1)
4335           enddo
4336         else
4337           phii1=0.0d0
4338           ityp3=nthetyp+1
4339           do k=1,nsingle
4340             cosph2(k)=0.0d0
4341             sinph2(k)=0.0d0
4342           enddo
4343         endif
4344         ethetai=aa0thet(ityp1,ityp2,ityp3)
4345         do k=1,ndouble
4346           do l=1,k-1
4347             ccl=cosph1(l)*cosph2(k-l)
4348             ssl=sinph1(l)*sinph2(k-l)
4349             scl=sinph1(l)*cosph2(k-l)
4350             csl=cosph1(l)*sinph2(k-l)
4351             cosph1ph2(l,k)=ccl-ssl
4352             cosph1ph2(k,l)=ccl+ssl
4353             sinph1ph2(l,k)=scl+csl
4354             sinph1ph2(k,l)=scl-csl
4355           enddo
4356         enddo
4357         if (lprn) then
4358         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4359      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4360         write (iout,*) "coskt and sinkt"
4361         do k=1,nntheterm
4362           write (iout,*) k,coskt(k),sinkt(k)
4363         enddo
4364         endif
4365         do k=1,ntheterm
4366           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4367           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4368      &      *coskt(k)
4369           if (lprn)
4370      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4371      &     " ethetai",ethetai
4372         enddo
4373         if (lprn) then
4374         write (iout,*) "cosph and sinph"
4375         do k=1,nsingle
4376           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4377         enddo
4378         write (iout,*) "cosph1ph2 and sinph2ph2"
4379         do k=2,ndouble
4380           do l=1,k-1
4381             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4382      &         sinph1ph2(l,k),sinph1ph2(k,l)
4383           enddo
4384         enddo
4385         write(iout,*) "ethetai",ethetai
4386         endif
4387         do m=1,ntheterm2
4388           do k=1,nsingle
4389             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4390      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4391      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4392      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4393             ethetai=ethetai+sinkt(m)*aux
4394             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4395             dephii=dephii+k*sinkt(m)*(
4396      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4397      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4398             dephii1=dephii1+k*sinkt(m)*(
4399      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4400      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4401             if (lprn)
4402      &      write (iout,*) "m",m," k",k," bbthet",
4403      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4404      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4405      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4406      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4407           enddo
4408         enddo
4409         if (lprn)
4410      &  write(iout,*) "ethetai",ethetai
4411         do m=1,ntheterm3
4412           do k=2,ndouble
4413             do l=1,k-1
4414               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4415      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4416      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4417      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4418               ethetai=ethetai+sinkt(m)*aux
4419               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4420               dephii=dephii+l*sinkt(m)*(
4421      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4422      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4423      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4424      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4425               dephii1=dephii1+(k-l)*sinkt(m)*(
4426      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4427      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4428      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4429      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4430               if (lprn) then
4431               write (iout,*) "m",m," k",k," l",l," ffthet",
4432      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4433      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4434      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4435      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4436               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4437      &            cosph1ph2(k,l)*sinkt(m),
4438      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4439               endif
4440             enddo
4441           enddo
4442         enddo
4443 10      continue
4444         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4445      &   i,theta(i)*rad2deg,phii*rad2deg,
4446      &   phii1*rad2deg,ethetai
4447         etheta=etheta+ethetai
4448         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4449         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4450         gloc(nphi+i-2,icg)=wang*dethetai
4451       enddo
4452       return
4453       end
4454 #endif
4455 #ifdef CRYST_SC
4456 c-----------------------------------------------------------------------------
4457       subroutine esc(escloc)
4458 C Calculate the local energy of a side chain and its derivatives in the
4459 C corresponding virtual-bond valence angles THETA and the spherical angles
4460 C ALPHA and OMEGA.
4461       implicit real*8 (a-h,o-z)
4462       include 'DIMENSIONS'
4463       include 'COMMON.GEO'
4464       include 'COMMON.LOCAL'
4465       include 'COMMON.VAR'
4466       include 'COMMON.INTERACT'
4467       include 'COMMON.DERIV'
4468       include 'COMMON.CHAIN'
4469       include 'COMMON.IOUNITS'
4470       include 'COMMON.NAMES'
4471       include 'COMMON.FFIELD'
4472       include 'COMMON.CONTROL'
4473       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4474      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4475       common /sccalc/ time11,time12,time112,theti,it,nlobit
4476       delta=0.02d0*pi
4477       escloc=0.0D0
4478 c     write (iout,'(a)') 'ESC'
4479       do i=loc_start,loc_end
4480         it=itype(i)
4481         if (it.eq.10) goto 1
4482         nlobit=nlob(it)
4483 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4484 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4485         theti=theta(i+1)-pipol
4486         x(1)=dtan(theti)
4487         x(2)=alph(i)
4488         x(3)=omeg(i)
4489
4490         if (x(2).gt.pi-delta) then
4491           xtemp(1)=x(1)
4492           xtemp(2)=pi-delta
4493           xtemp(3)=x(3)
4494           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4495           xtemp(2)=pi
4496           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4497           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4498      &        escloci,dersc(2))
4499           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4500      &        ddersc0(1),dersc(1))
4501           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4502      &        ddersc0(3),dersc(3))
4503           xtemp(2)=pi-delta
4504           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4505           xtemp(2)=pi
4506           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4507           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4508      &            dersc0(2),esclocbi,dersc02)
4509           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4510      &            dersc12,dersc01)
4511           call splinthet(x(2),0.5d0*delta,ss,ssd)
4512           dersc0(1)=dersc01
4513           dersc0(2)=dersc02
4514           dersc0(3)=0.0d0
4515           do k=1,3
4516             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4517           enddo
4518           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4519 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4520 c    &             esclocbi,ss,ssd
4521           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4522 c         escloci=esclocbi
4523 c         write (iout,*) escloci
4524         else if (x(2).lt.delta) then
4525           xtemp(1)=x(1)
4526           xtemp(2)=delta
4527           xtemp(3)=x(3)
4528           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4529           xtemp(2)=0.0d0
4530           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4531           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4532      &        escloci,dersc(2))
4533           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4534      &        ddersc0(1),dersc(1))
4535           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4536      &        ddersc0(3),dersc(3))
4537           xtemp(2)=delta
4538           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4539           xtemp(2)=0.0d0
4540           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4541           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4542      &            dersc0(2),esclocbi,dersc02)
4543           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4544      &            dersc12,dersc01)
4545           dersc0(1)=dersc01
4546           dersc0(2)=dersc02
4547           dersc0(3)=0.0d0
4548           call splinthet(x(2),0.5d0*delta,ss,ssd)
4549           do k=1,3
4550             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4551           enddo
4552           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4553 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4554 c    &             esclocbi,ss,ssd
4555           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4556 c         write (iout,*) escloci
4557         else
4558           call enesc(x,escloci,dersc,ddummy,.false.)
4559         endif
4560
4561         escloc=escloc+escloci
4562         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4563      &     'escloc',i,escloci
4564 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4565
4566         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4567      &   wscloc*dersc(1)
4568         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4569         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4570     1   continue
4571       enddo
4572       return
4573       end
4574 C---------------------------------------------------------------------------
4575       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4576       implicit real*8 (a-h,o-z)
4577       include 'DIMENSIONS'
4578       include 'COMMON.GEO'
4579       include 'COMMON.LOCAL'
4580       include 'COMMON.IOUNITS'
4581       common /sccalc/ time11,time12,time112,theti,it,nlobit
4582       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4583       double precision contr(maxlob,-1:1)
4584       logical mixed
4585 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4586         escloc_i=0.0D0
4587         do j=1,3
4588           dersc(j)=0.0D0
4589           if (mixed) ddersc(j)=0.0d0
4590         enddo
4591         x3=x(3)
4592
4593 C Because of periodicity of the dependence of the SC energy in omega we have
4594 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4595 C To avoid underflows, first compute & store the exponents.
4596
4597         do iii=-1,1
4598
4599           x(3)=x3+iii*dwapi
4600
4601           do j=1,nlobit
4602             do k=1,3
4603               z(k)=x(k)-censc(k,j,it)
4604             enddo
4605             do k=1,3
4606               Axk=0.0D0
4607               do l=1,3
4608                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4609               enddo
4610               Ax(k,j,iii)=Axk
4611             enddo
4612             expfac=0.0D0
4613             do k=1,3
4614               expfac=expfac+Ax(k,j,iii)*z(k)
4615             enddo
4616             contr(j,iii)=expfac
4617           enddo ! j
4618
4619         enddo ! iii
4620
4621         x(3)=x3
4622 C As in the case of ebend, we want to avoid underflows in exponentiation and
4623 C subsequent NaNs and INFs in energy calculation.
4624 C Find the largest exponent
4625         emin=contr(1,-1)
4626         do iii=-1,1
4627           do j=1,nlobit
4628             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4629           enddo
4630         enddo
4631         emin=0.5D0*emin
4632 cd      print *,'it=',it,' emin=',emin
4633
4634 C Compute the contribution to SC energy and derivatives
4635         do iii=-1,1
4636
4637           do j=1,nlobit
4638 #ifdef OSF
4639             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4640             if(adexp.ne.adexp) adexp=1.0
4641             expfac=dexp(adexp)
4642 #else
4643             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4644 #endif
4645 cd          print *,'j=',j,' expfac=',expfac
4646             escloc_i=escloc_i+expfac
4647             do k=1,3
4648               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4649             enddo
4650             if (mixed) then
4651               do k=1,3,2
4652                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4653      &            +gaussc(k,2,j,it))*expfac
4654               enddo
4655             endif
4656           enddo
4657
4658         enddo ! iii
4659
4660         dersc(1)=dersc(1)/cos(theti)**2
4661         ddersc(1)=ddersc(1)/cos(theti)**2
4662         ddersc(3)=ddersc(3)
4663
4664         escloci=-(dlog(escloc_i)-emin)
4665         do j=1,3
4666           dersc(j)=dersc(j)/escloc_i
4667         enddo
4668         if (mixed) then
4669           do j=1,3,2
4670             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4671           enddo
4672         endif
4673       return
4674       end
4675 C------------------------------------------------------------------------------
4676       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4677       implicit real*8 (a-h,o-z)
4678       include 'DIMENSIONS'
4679       include 'COMMON.GEO'
4680       include 'COMMON.LOCAL'
4681       include 'COMMON.IOUNITS'
4682       common /sccalc/ time11,time12,time112,theti,it,nlobit
4683       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4684       double precision contr(maxlob)
4685       logical mixed
4686
4687       escloc_i=0.0D0
4688
4689       do j=1,3
4690         dersc(j)=0.0D0
4691       enddo
4692
4693       do j=1,nlobit
4694         do k=1,2
4695           z(k)=x(k)-censc(k,j,it)
4696         enddo
4697         z(3)=dwapi
4698         do k=1,3
4699           Axk=0.0D0
4700           do l=1,3
4701             Axk=Axk+gaussc(l,k,j,it)*z(l)
4702           enddo
4703           Ax(k,j)=Axk
4704         enddo
4705         expfac=0.0D0
4706         do k=1,3
4707           expfac=expfac+Ax(k,j)*z(k)
4708         enddo
4709         contr(j)=expfac
4710       enddo ! j
4711
4712 C As in the case of ebend, we want to avoid underflows in exponentiation and
4713 C subsequent NaNs and INFs in energy calculation.
4714 C Find the largest exponent
4715       emin=contr(1)
4716       do j=1,nlobit
4717         if (emin.gt.contr(j)) emin=contr(j)
4718       enddo
4719       emin=0.5D0*emin
4720
4721 C Compute the contribution to SC energy and derivatives
4722
4723       dersc12=0.0d0
4724       do j=1,nlobit
4725         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4726         escloc_i=escloc_i+expfac
4727         do k=1,2
4728           dersc(k)=dersc(k)+Ax(k,j)*expfac
4729         enddo
4730         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4731      &            +gaussc(1,2,j,it))*expfac
4732         dersc(3)=0.0d0
4733       enddo
4734
4735       dersc(1)=dersc(1)/cos(theti)**2
4736       dersc12=dersc12/cos(theti)**2
4737       escloci=-(dlog(escloc_i)-emin)
4738       do j=1,2
4739         dersc(j)=dersc(j)/escloc_i
4740       enddo
4741       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4742       return
4743       end
4744 #else
4745 c----------------------------------------------------------------------------------
4746       subroutine esc(escloc)
4747 C Calculate the local energy of a side chain and its derivatives in the
4748 C corresponding virtual-bond valence angles THETA and the spherical angles
4749 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4750 C added by Urszula Kozlowska. 07/11/2007
4751 C
4752       implicit real*8 (a-h,o-z)
4753       include 'DIMENSIONS'
4754       include 'COMMON.GEO'
4755       include 'COMMON.LOCAL'
4756       include 'COMMON.VAR'
4757       include 'COMMON.SCROT'
4758       include 'COMMON.INTERACT'
4759       include 'COMMON.DERIV'
4760       include 'COMMON.CHAIN'
4761       include 'COMMON.IOUNITS'
4762       include 'COMMON.NAMES'
4763       include 'COMMON.FFIELD'
4764       include 'COMMON.CONTROL'
4765       include 'COMMON.VECTORS'
4766       double precision x_prime(3),y_prime(3),z_prime(3)
4767      &    , sumene,dsc_i,dp2_i,x(65),
4768      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4769      &    de_dxx,de_dyy,de_dzz,de_dt
4770       double precision s1_t,s1_6_t,s2_t,s2_6_t
4771       double precision
4772      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4773      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4774      & dt_dCi(3),dt_dCi1(3)
4775       common /sccalc/ time11,time12,time112,theti,it,nlobit
4776       delta=0.02d0*pi
4777       escloc=0.0D0
4778       do i=loc_start,loc_end
4779         costtab(i+1) =dcos(theta(i+1))
4780         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4781         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4782         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4783         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4784         cosfac=dsqrt(cosfac2)
4785         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4786         sinfac=dsqrt(sinfac2)
4787         it=itype(i)
4788         if (it.eq.10) goto 1
4789 c
4790 C  Compute the axes of tghe local cartesian coordinates system; store in
4791 c   x_prime, y_prime and z_prime
4792 c
4793         do j=1,3
4794           x_prime(j) = 0.00
4795           y_prime(j) = 0.00
4796           z_prime(j) = 0.00
4797         enddo
4798 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4799 C     &   dc_norm(3,i+nres)
4800         do j = 1,3
4801           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4802           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4803         enddo
4804         do j = 1,3
4805           z_prime(j) = -uz(j,i-1)
4806         enddo
4807 c       write (2,*) "i",i
4808 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4809 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4810 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4811 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4812 c      & " xy",scalar(x_prime(1),y_prime(1)),
4813 c      & " xz",scalar(x_prime(1),z_prime(1)),
4814 c      & " yy",scalar(y_prime(1),y_prime(1)),
4815 c      & " yz",scalar(y_prime(1),z_prime(1)),
4816 c      & " zz",scalar(z_prime(1),z_prime(1))
4817 c
4818 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4819 C to local coordinate system. Store in xx, yy, zz.
4820 c
4821         xx=0.0d0
4822         yy=0.0d0
4823         zz=0.0d0
4824         do j = 1,3
4825           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4826           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4827           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4828         enddo
4829
4830         xxtab(i)=xx
4831         yytab(i)=yy
4832         zztab(i)=zz
4833 C
4834 C Compute the energy of the ith side cbain
4835 C
4836 c        write (2,*) "xx",xx," yy",yy," zz",zz
4837         it=itype(i)
4838         do j = 1,65
4839           x(j) = sc_parmin(j,it)
4840         enddo
4841 #ifdef CHECK_COORD
4842 Cc diagnostics - remove later
4843         xx1 = dcos(alph(2))
4844         yy1 = dsin(alph(2))*dcos(omeg(2))
4845         zz1 = -dsin(alph(2))*dsin(omeg(2))
4846         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4847      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4848      &    xx1,yy1,zz1
4849 C,"  --- ", xx_w,yy_w,zz_w
4850 c end diagnostics
4851 #endif
4852         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4853      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4854      &   + x(10)*yy*zz
4855         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4856      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4857      & + x(20)*yy*zz
4858         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4859      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4860      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4861      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4862      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4863      &  +x(40)*xx*yy*zz
4864         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4865      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4866      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4867      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4868      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4869      &  +x(60)*xx*yy*zz
4870         dsc_i   = 0.743d0+x(61)
4871         dp2_i   = 1.9d0+x(62)
4872         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4873      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4874         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4875      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4876         s1=(1+x(63))/(0.1d0 + dscp1)
4877         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4878         s2=(1+x(65))/(0.1d0 + dscp2)
4879         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4880         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4881      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4882 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4883 c     &   sumene4,
4884 c     &   dscp1,dscp2,sumene
4885 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4886         escloc = escloc + sumene
4887 c        write (2,*) "i",i," escloc",sumene,escloc
4888 #ifdef DEBUG
4889 C
4890 C This section to check the numerical derivatives of the energy of ith side
4891 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4892 C #define DEBUG in the code to turn it on.
4893 C
4894         write (2,*) "sumene               =",sumene
4895         aincr=1.0d-7
4896         xxsave=xx
4897         xx=xx+aincr
4898         write (2,*) xx,yy,zz
4899         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4900         de_dxx_num=(sumenep-sumene)/aincr
4901         xx=xxsave
4902         write (2,*) "xx+ sumene from enesc=",sumenep
4903         yysave=yy
4904         yy=yy+aincr
4905         write (2,*) xx,yy,zz
4906         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4907         de_dyy_num=(sumenep-sumene)/aincr
4908         yy=yysave
4909         write (2,*) "yy+ sumene from enesc=",sumenep
4910         zzsave=zz
4911         zz=zz+aincr
4912         write (2,*) xx,yy,zz
4913         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4914         de_dzz_num=(sumenep-sumene)/aincr
4915         zz=zzsave
4916         write (2,*) "zz+ sumene from enesc=",sumenep
4917         costsave=cost2tab(i+1)
4918         sintsave=sint2tab(i+1)
4919         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4920         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4921         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4922         de_dt_num=(sumenep-sumene)/aincr
4923         write (2,*) " t+ sumene from enesc=",sumenep
4924         cost2tab(i+1)=costsave
4925         sint2tab(i+1)=sintsave
4926 C End of diagnostics section.
4927 #endif
4928 C
4929 C Compute the gradient of esc
4930 C
4931         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4932         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4933         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4934         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4935         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4936         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4937         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4938         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4939         pom1=(sumene3*sint2tab(i+1)+sumene1)
4940      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4941         pom2=(sumene4*cost2tab(i+1)+sumene2)
4942      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4943         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4944         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4945      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4946      &  +x(40)*yy*zz
4947         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4948         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4949      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4950      &  +x(60)*yy*zz
4951         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4952      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4953      &        +(pom1+pom2)*pom_dx
4954 #ifdef DEBUG
4955         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4956 #endif
4957 C
4958         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4959         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4960      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4961      &  +x(40)*xx*zz
4962         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4963         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4964      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4965      &  +x(59)*zz**2 +x(60)*xx*zz
4966         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4967      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4968      &        +(pom1-pom2)*pom_dy
4969 #ifdef DEBUG
4970         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4971 #endif
4972 C
4973         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4974      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4975      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4976      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4977      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4978      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4979      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4980      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4981 #ifdef DEBUG
4982         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4983 #endif
4984 C
4985         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4986      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4987      &  +pom1*pom_dt1+pom2*pom_dt2
4988 #ifdef DEBUG
4989         write(2,*), "de_dt = ", de_dt,de_dt_num
4990 #endif
4991 c
4992 C
4993        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4994        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4995        cosfac2xx=cosfac2*xx
4996        sinfac2yy=sinfac2*yy
4997        do k = 1,3
4998          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4999      &      vbld_inv(i+1)
5000          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5001      &      vbld_inv(i)
5002          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5003          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5004 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5005 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5006 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5007 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5008          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5009          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5010          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5011          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5012          dZZ_Ci1(k)=0.0d0
5013          dZZ_Ci(k)=0.0d0
5014          do j=1,3
5015            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5016            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5017          enddo
5018
5019          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5020          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5021          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5022 c
5023          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5024          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5025        enddo
5026
5027        do k=1,3
5028          dXX_Ctab(k,i)=dXX_Ci(k)
5029          dXX_C1tab(k,i)=dXX_Ci1(k)
5030          dYY_Ctab(k,i)=dYY_Ci(k)
5031          dYY_C1tab(k,i)=dYY_Ci1(k)
5032          dZZ_Ctab(k,i)=dZZ_Ci(k)
5033          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5034          dXX_XYZtab(k,i)=dXX_XYZ(k)
5035          dYY_XYZtab(k,i)=dYY_XYZ(k)
5036          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5037        enddo
5038
5039        do k = 1,3
5040 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5041 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5042 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5043 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5044 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5045 c     &    dt_dci(k)
5046 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5047 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5048          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5049      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5050          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5051      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5052          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5053      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5054        enddo
5055 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5056 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5057
5058 C to check gradient call subroutine check_grad
5059
5060     1 continue
5061       enddo
5062       return
5063       end
5064 c------------------------------------------------------------------------------
5065       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5066       implicit none
5067       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5068      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5069       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5070      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5071      &   + x(10)*yy*zz
5072       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5073      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5074      & + x(20)*yy*zz
5075       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5076      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5077      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5078      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5079      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5080      &  +x(40)*xx*yy*zz
5081       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5082      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5083      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5084      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5085      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5086      &  +x(60)*xx*yy*zz
5087       dsc_i   = 0.743d0+x(61)
5088       dp2_i   = 1.9d0+x(62)
5089       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5090      &          *(xx*cost2+yy*sint2))
5091       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5092      &          *(xx*cost2-yy*sint2))
5093       s1=(1+x(63))/(0.1d0 + dscp1)
5094       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5095       s2=(1+x(65))/(0.1d0 + dscp2)
5096       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5097       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5098      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5099       enesc=sumene
5100       return
5101       end
5102 #endif
5103 c------------------------------------------------------------------------------
5104       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5105 C
5106 C This procedure calculates two-body contact function g(rij) and its derivative:
5107 C
5108 C           eps0ij                                     !       x < -1
5109 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5110 C            0                                         !       x > 1
5111 C
5112 C where x=(rij-r0ij)/delta
5113 C
5114 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5115 C
5116       implicit none
5117       double precision rij,r0ij,eps0ij,fcont,fprimcont
5118       double precision x,x2,x4,delta
5119 c     delta=0.02D0*r0ij
5120 c      delta=0.2D0*r0ij
5121       x=(rij-r0ij)/delta
5122       if (x.lt.-1.0D0) then
5123         fcont=eps0ij
5124         fprimcont=0.0D0
5125       else if (x.le.1.0D0) then
5126         x2=x*x
5127         x4=x2*x2
5128         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5129         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5130       else
5131         fcont=0.0D0
5132         fprimcont=0.0D0
5133       endif
5134       return
5135       end
5136 c------------------------------------------------------------------------------
5137       subroutine splinthet(theti,delta,ss,ssder)
5138       implicit real*8 (a-h,o-z)
5139       include 'DIMENSIONS'
5140       include 'COMMON.VAR'
5141       include 'COMMON.GEO'
5142       thetup=pi-delta
5143       thetlow=delta
5144       if (theti.gt.pipol) then
5145         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5146       else
5147         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5148         ssder=-ssder
5149       endif
5150       return
5151       end
5152 c------------------------------------------------------------------------------
5153       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5154       implicit none
5155       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5156       double precision ksi,ksi2,ksi3,a1,a2,a3
5157       a1=fprim0*delta/(f1-f0)
5158       a2=3.0d0-2.0d0*a1
5159       a3=a1-2.0d0
5160       ksi=(x-x0)/delta
5161       ksi2=ksi*ksi
5162       ksi3=ksi2*ksi
5163       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5164       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5165       return
5166       end
5167 c------------------------------------------------------------------------------
5168       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5169       implicit none
5170       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5171       double precision ksi,ksi2,ksi3,a1,a2,a3
5172       ksi=(x-x0)/delta
5173       ksi2=ksi*ksi
5174       ksi3=ksi2*ksi
5175       a1=fprim0x*delta
5176       a2=3*(f1x-f0x)-2*fprim0x*delta
5177       a3=fprim0x*delta-2*(f1x-f0x)
5178       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5179       return
5180       end
5181 C-----------------------------------------------------------------------------
5182 #ifdef CRYST_TOR
5183 C-----------------------------------------------------------------------------
5184       subroutine etor(etors,edihcnstr)
5185       implicit real*8 (a-h,o-z)
5186       include 'DIMENSIONS'
5187       include 'COMMON.VAR'
5188       include 'COMMON.GEO'
5189       include 'COMMON.LOCAL'
5190       include 'COMMON.TORSION'
5191       include 'COMMON.INTERACT'
5192       include 'COMMON.DERIV'
5193       include 'COMMON.CHAIN'
5194       include 'COMMON.NAMES'
5195       include 'COMMON.IOUNITS'
5196       include 'COMMON.FFIELD'
5197       include 'COMMON.TORCNSTR'
5198       include 'COMMON.CONTROL'
5199       logical lprn
5200 C Set lprn=.true. for debugging
5201       lprn=.false.
5202 c      lprn=.true.
5203       etors=0.0D0
5204       do i=iphi_start,iphi_end
5205       etors_ii=0.0D0
5206         itori=itortyp(itype(i-2))
5207         itori1=itortyp(itype(i-1))
5208         phii=phi(i)
5209         gloci=0.0D0
5210 C Proline-Proline pair is a special case...
5211         if (itori.eq.3 .and. itori1.eq.3) then
5212           if (phii.gt.-dwapi3) then
5213             cosphi=dcos(3*phii)
5214             fac=1.0D0/(1.0D0-cosphi)
5215             etorsi=v1(1,3,3)*fac
5216             etorsi=etorsi+etorsi
5217             etors=etors+etorsi-v1(1,3,3)
5218             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5219             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5220           endif
5221           do j=1,3
5222             v1ij=v1(j+1,itori,itori1)
5223             v2ij=v2(j+1,itori,itori1)
5224             cosphi=dcos(j*phii)
5225             sinphi=dsin(j*phii)
5226             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5227             if (energy_dec) etors_ii=etors_ii+
5228      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5229             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5230           enddo
5231         else
5232           do j=1,nterm_old
5233             v1ij=v1(j,itori,itori1)
5234             v2ij=v2(j,itori,itori1)
5235             cosphi=dcos(j*phii)
5236             sinphi=dsin(j*phii)
5237             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5238             if (energy_dec) etors_ii=etors_ii+
5239      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5240             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5241           enddo
5242         endif
5243         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5244              'etor',i,etors_ii
5245         if (lprn)
5246      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5247      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5248      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5249         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5250 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5251       enddo
5252 ! 6/20/98 - dihedral angle constraints
5253       edihcnstr=0.0d0
5254       do i=1,ndih_constr
5255         itori=idih_constr(i)
5256         phii=phi(itori)
5257         difi=phii-phi0(i)
5258         if (difi.gt.drange(i)) then
5259           difi=difi-drange(i)
5260           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5261           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5262         else if (difi.lt.-drange(i)) then
5263           difi=difi+drange(i)
5264           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5265           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5266         endif
5267 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5268 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5269       enddo
5270 !      write (iout,*) 'edihcnstr',edihcnstr
5271       return
5272       end
5273 c------------------------------------------------------------------------------
5274       subroutine etor_d(etors_d)
5275       etors_d=0.0d0
5276       return
5277       end
5278 c----------------------------------------------------------------------------
5279 #else
5280       subroutine etor(etors,edihcnstr)
5281       implicit real*8 (a-h,o-z)
5282       include 'DIMENSIONS'
5283       include 'COMMON.VAR'
5284       include 'COMMON.GEO'
5285       include 'COMMON.LOCAL'
5286       include 'COMMON.TORSION'
5287       include 'COMMON.INTERACT'
5288       include 'COMMON.DERIV'
5289       include 'COMMON.CHAIN'
5290       include 'COMMON.NAMES'
5291       include 'COMMON.IOUNITS'
5292       include 'COMMON.FFIELD'
5293       include 'COMMON.TORCNSTR'
5294       include 'COMMON.CONTROL'
5295       logical lprn
5296 C Set lprn=.true. for debugging
5297       lprn=.false.
5298 c     lprn=.true.
5299       etors=0.0D0
5300       do i=iphi_start,iphi_end
5301       etors_ii=0.0D0
5302         itori=itortyp(itype(i-2))
5303         itori1=itortyp(itype(i-1))
5304         phii=phi(i)
5305         gloci=0.0D0
5306 C Regular cosine and sine terms
5307         do j=1,nterm(itori,itori1)
5308           v1ij=v1(j,itori,itori1)
5309           v2ij=v2(j,itori,itori1)
5310           cosphi=dcos(j*phii)
5311           sinphi=dsin(j*phii)
5312           etors=etors+v1ij*cosphi+v2ij*sinphi
5313           if (energy_dec) etors_ii=etors_ii+
5314      &                v1ij*cosphi+v2ij*sinphi
5315           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5316         enddo
5317 C Lorentz terms
5318 C                         v1
5319 C  E = SUM ----------------------------------- - v1
5320 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5321 C
5322         cosphi=dcos(0.5d0*phii)
5323         sinphi=dsin(0.5d0*phii)
5324         do j=1,nlor(itori,itori1)
5325           vl1ij=vlor1(j,itori,itori1)
5326           vl2ij=vlor2(j,itori,itori1)
5327           vl3ij=vlor3(j,itori,itori1)
5328           pom=vl2ij*cosphi+vl3ij*sinphi
5329           pom1=1.0d0/(pom*pom+1.0d0)
5330           etors=etors+vl1ij*pom1
5331           if (energy_dec) etors_ii=etors_ii+
5332      &                vl1ij*pom1
5333           pom=-pom*pom1*pom1
5334           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5335         enddo
5336 C Subtract the constant term
5337         etors=etors-v0(itori,itori1)
5338           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5339      &         'etor',i,etors_ii-v0(itori,itori1)
5340         if (lprn)
5341      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5342      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5343      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5344         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5345 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5346       enddo
5347 ! 6/20/98 - dihedral angle constraints
5348       edihcnstr=0.0d0
5349 c      do i=1,ndih_constr
5350       do i=idihconstr_start,idihconstr_end
5351         itori=idih_constr(i)
5352         phii=phi(itori)
5353         difi=pinorm(phii-phi0(i))
5354         if (difi.gt.drange(i)) then
5355           difi=difi-drange(i)
5356           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5357           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5358         else if (difi.lt.-drange(i)) then
5359           difi=difi+drange(i)
5360           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5361           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5362         else
5363           difi=0.0
5364         endif
5365 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5366 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5367 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5368       enddo
5369 cd       write (iout,*) 'edihcnstr',edihcnstr
5370       return
5371       end
5372 c----------------------------------------------------------------------------
5373       subroutine etor_d(etors_d)
5374 C 6/23/01 Compute double torsional energy
5375       implicit real*8 (a-h,o-z)
5376       include 'DIMENSIONS'
5377       include 'COMMON.VAR'
5378       include 'COMMON.GEO'
5379       include 'COMMON.LOCAL'
5380       include 'COMMON.TORSION'
5381       include 'COMMON.INTERACT'
5382       include 'COMMON.DERIV'
5383       include 'COMMON.CHAIN'
5384       include 'COMMON.NAMES'
5385       include 'COMMON.IOUNITS'
5386       include 'COMMON.FFIELD'
5387       include 'COMMON.TORCNSTR'
5388       logical lprn
5389 C Set lprn=.true. for debugging
5390       lprn=.false.
5391 c     lprn=.true.
5392       etors_d=0.0D0
5393       do i=iphid_start,iphid_end
5394         itori=itortyp(itype(i-2))
5395         itori1=itortyp(itype(i-1))
5396         itori2=itortyp(itype(i))
5397         phii=phi(i)
5398         phii1=phi(i+1)
5399         gloci1=0.0D0
5400         gloci2=0.0D0
5401 C Regular cosine and sine terms
5402         do j=1,ntermd_1(itori,itori1,itori2)
5403           v1cij=v1c(1,j,itori,itori1,itori2)
5404           v1sij=v1s(1,j,itori,itori1,itori2)
5405           v2cij=v1c(2,j,itori,itori1,itori2)
5406           v2sij=v1s(2,j,itori,itori1,itori2)
5407           cosphi1=dcos(j*phii)
5408           sinphi1=dsin(j*phii)
5409           cosphi2=dcos(j*phii1)
5410           sinphi2=dsin(j*phii1)
5411           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5412      &     v2cij*cosphi2+v2sij*sinphi2
5413           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5414           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5415         enddo
5416         do k=2,ntermd_2(itori,itori1,itori2)
5417           do l=1,k-1
5418             v1cdij = v2c(k,l,itori,itori1,itori2)
5419             v2cdij = v2c(l,k,itori,itori1,itori2)
5420             v1sdij = v2s(k,l,itori,itori1,itori2)
5421             v2sdij = v2s(l,k,itori,itori1,itori2)
5422             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5423             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5424             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5425             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5426             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5427      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5428             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5429      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5430             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5431      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5432           enddo
5433         enddo
5434         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5435         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5436       enddo
5437       return
5438       end
5439 #endif
5440 c------------------------------------------------------------------------------
5441       subroutine eback_sc_corr(esccor)
5442 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5443 c        conformational states; temporarily implemented as differences
5444 c        between UNRES torsional potentials (dependent on three types of
5445 c        residues) and the torsional potentials dependent on all 20 types
5446 c        of residues computed from AM1  energy surfaces of terminally-blocked
5447 c        amino-acid residues.
5448       implicit real*8 (a-h,o-z)
5449       include 'DIMENSIONS'
5450       include 'COMMON.VAR'
5451       include 'COMMON.GEO'
5452       include 'COMMON.LOCAL'
5453       include 'COMMON.TORSION'
5454       include 'COMMON.SCCOR'
5455       include 'COMMON.INTERACT'
5456       include 'COMMON.DERIV'
5457       include 'COMMON.CHAIN'
5458       include 'COMMON.NAMES'
5459       include 'COMMON.IOUNITS'
5460       include 'COMMON.FFIELD'
5461       include 'COMMON.CONTROL'
5462       logical lprn
5463 C Set lprn=.true. for debugging
5464       lprn=.false.
5465 c      lprn=.true.
5466 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5467       esccor=0.0D0
5468       do i=iphi_start,iphi_end
5469         esccor_ii=0.0D0
5470         itori=itype(i-2)
5471         itori1=itype(i-1)
5472         phii=phi(i)
5473         gloci=0.0D0
5474         do j=1,nterm_sccor
5475           v1ij=v1sccor(j,itori,itori1)
5476           v2ij=v2sccor(j,itori,itori1)
5477           cosphi=dcos(j*phii)
5478           sinphi=dsin(j*phii)
5479           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5480           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5481         enddo
5482         if (lprn)
5483      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5484      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5485      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5486         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5487       enddo
5488       return
5489       end
5490 c----------------------------------------------------------------------------
5491       subroutine multibody(ecorr)
5492 C This subroutine calculates multi-body contributions to energy following
5493 C the idea of Skolnick et al. If side chains I and J make a contact and
5494 C at the same time side chains I+1 and J+1 make a contact, an extra
5495 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5496       implicit real*8 (a-h,o-z)
5497       include 'DIMENSIONS'
5498       include 'COMMON.IOUNITS'
5499       include 'COMMON.DERIV'
5500       include 'COMMON.INTERACT'
5501       include 'COMMON.CONTACTS'
5502       double precision gx(3),gx1(3)
5503       logical lprn
5504
5505 C Set lprn=.true. for debugging
5506       lprn=.false.
5507
5508       if (lprn) then
5509         write (iout,'(a)') 'Contact function values:'
5510         do i=nnt,nct-2
5511           write (iout,'(i2,20(1x,i2,f10.5))')
5512      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5513         enddo
5514       endif
5515       ecorr=0.0D0
5516       do i=nnt,nct
5517         do j=1,3
5518           gradcorr(j,i)=0.0D0
5519           gradxorr(j,i)=0.0D0
5520         enddo
5521       enddo
5522       do i=nnt,nct-2
5523
5524         DO ISHIFT = 3,4
5525
5526         i1=i+ishift
5527         num_conti=num_cont(i)
5528         num_conti1=num_cont(i1)
5529         do jj=1,num_conti
5530           j=jcont(jj,i)
5531           do kk=1,num_conti1
5532             j1=jcont(kk,i1)
5533             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5534 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5535 cd   &                   ' ishift=',ishift
5536 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5537 C The system gains extra energy.
5538               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5539             endif   ! j1==j+-ishift
5540           enddo     ! kk
5541         enddo       ! jj
5542
5543         ENDDO ! ISHIFT
5544
5545       enddo         ! i
5546       return
5547       end
5548 c------------------------------------------------------------------------------
5549       double precision function esccorr(i,j,k,l,jj,kk)
5550       implicit real*8 (a-h,o-z)
5551       include 'DIMENSIONS'
5552       include 'COMMON.IOUNITS'
5553       include 'COMMON.DERIV'
5554       include 'COMMON.INTERACT'
5555       include 'COMMON.CONTACTS'
5556       double precision gx(3),gx1(3)
5557       logical lprn
5558       lprn=.false.
5559       eij=facont(jj,i)
5560       ekl=facont(kk,k)
5561 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5562 C Calculate the multi-body contribution to energy.
5563 C Calculate multi-body contributions to the gradient.
5564 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5565 cd   & k,l,(gacont(m,kk,k),m=1,3)
5566       do m=1,3
5567         gx(m) =ekl*gacont(m,jj,i)
5568         gx1(m)=eij*gacont(m,kk,k)
5569         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5570         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5571         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5572         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5573       enddo
5574       do m=i,j-1
5575         do ll=1,3
5576           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5577         enddo
5578       enddo
5579       do m=k,l-1
5580         do ll=1,3
5581           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5582         enddo
5583       enddo
5584       esccorr=-eij*ekl
5585       return
5586       end
5587 c------------------------------------------------------------------------------
5588 #ifdef MPI
5589       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5590       implicit real*8 (a-h,o-z)
5591       include 'DIMENSIONS'
5592       integer dimen1,dimen2,atom,indx
5593       double precision buffer(dimen1,dimen2)
5594       double precision zapas
5595       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5596      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5597      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5598      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5599       num_kont=num_cont_hb(atom)
5600       do i=1,num_kont
5601         do k=1,8
5602           do j=1,3
5603             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5604           enddo ! j
5605         enddo ! k
5606         buffer(i,indx+25)=facont_hb(i,atom)
5607         buffer(i,indx+26)=ees0p(i,atom)
5608         buffer(i,indx+27)=ees0m(i,atom)
5609         buffer(i,indx+28)=d_cont(i,atom)
5610         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
5611       enddo ! i
5612       buffer(1,indx+30)=dfloat(num_kont)
5613       return
5614       end
5615 c------------------------------------------------------------------------------
5616       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5617       implicit real*8 (a-h,o-z)
5618       include 'DIMENSIONS'
5619       integer dimen1,dimen2,atom,indx
5620       double precision buffer(dimen1,dimen2)
5621       double precision zapas
5622       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5623      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5624      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5625      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5626       num_kont=buffer(1,indx+30)
5627       num_kont_old=num_cont_hb(atom)
5628       num_cont_hb(atom)=num_kont+num_kont_old
5629       do i=1,num_kont
5630         ii=i+num_kont_old
5631         do k=1,8
5632           do j=1,3
5633             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5634           enddo ! j
5635         enddo ! k
5636         facont_hb(ii,atom)=buffer(i,indx+25)
5637         ees0p(ii,atom)=buffer(i,indx+26)
5638         ees0m(ii,atom)=buffer(i,indx+27)
5639         d_cont(i,atom)=buffer(i,indx+28)
5640         jcont_hb(ii,atom)=buffer(i,indx+29)
5641       enddo ! i
5642       return
5643       end
5644 c------------------------------------------------------------------------------
5645 #endif
5646       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5647 C This subroutine calculates multi-body contributions to hydrogen-bonding
5648       implicit real*8 (a-h,o-z)
5649       include 'DIMENSIONS'
5650       include 'COMMON.IOUNITS'
5651 #ifdef MPI
5652       include "mpif.h"
5653       parameter (max_cont=maxconts)
5654       parameter (max_dim=2*(8*3+6))
5655       parameter (msglen1=max_cont*max_dim)
5656       parameter (msglen2=2*msglen1)
5657       integer source,CorrelType,CorrelID,Error
5658       double precision buffer(max_cont,max_dim)
5659       integer status(MPI_STATUS_SIZE)
5660 #endif
5661       include 'COMMON.SETUP'
5662       include 'COMMON.FFIELD'
5663       include 'COMMON.DERIV'
5664       include 'COMMON.INTERACT'
5665       include 'COMMON.CONTACTS'
5666       include 'COMMON.CONTROL'
5667       double precision gx(3),gx1(3),time00
5668       logical lprn,ldone
5669
5670 C Set lprn=.true. for debugging
5671       lprn=.false.
5672 #ifdef MPI
5673       n_corr=0
5674       n_corr1=0
5675       if (nfgtasks.le.1) goto 30
5676       if (lprn) then
5677         write (iout,'(a)') 'Contact function values:'
5678         do i=nnt,nct-2
5679           write (iout,'(2i3,50(1x,i2,f5.2))')
5680      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5681      &    j=1,num_cont_hb(i))
5682         enddo
5683       endif
5684 C Caution! Following code assumes that electrostatic interactions concerning
5685 C a given atom are split among at most two processors!
5686       CorrelType=477
5687       CorrelID=fg_rank+1
5688       ldone=.false.
5689       do i=1,max_cont
5690         do j=1,max_dim
5691           buffer(i,j)=0.0D0
5692         enddo
5693       enddo
5694       mm=mod(fg_rank,2)
5695 c      write (*,*) 'MyRank',MyRank,' mm',mm
5696       if (mm) 20,20,10
5697    10 continue
5698 c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5699       if (fg_rank.gt.0) then
5700 C Send correlation contributions to the preceding processor
5701         msglen=msglen1
5702         nn=num_cont_hb(iatel_s)
5703         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5704 c        write (*,*) 'The BUFFER array:'
5705 c        do i=1,nn
5706 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5707 c        enddo
5708         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5709           msglen=msglen2
5710           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5711 C Clear the contacts of the atom passed to the neighboring processor
5712         nn=num_cont_hb(iatel_s+1)
5713 c        do i=1,nn
5714 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5715 c        enddo
5716             num_cont_hb(iatel_s)=0
5717         endif
5718 cd      write (iout,*) 'Processor ',fg_rank,MyRank,
5719 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5720 cd   & ' msglen=',msglen
5721 c        write (*,*) 'Processor ',fg_rank,MyRank,
5722 c     & ' is sending correlation contribution to processor',fg_rank-1,
5723 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5724         time00=MPI_Wtime()
5725         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5726      &    CorrelType,FG_COMM,IERROR)
5727         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5728 cd      write (iout,*) 'Processor ',fg_rank,
5729 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5730 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5731 c        write (*,*) 'Processor ',fg_rank,
5732 c     & ' has sent correlation contribution to processor',fg_rank-1,
5733 c     & ' msglen=',msglen,' CorrelID=',CorrelID
5734 c        msglen=msglen1
5735       endif ! (fg_rank.gt.0)
5736       if (ldone) goto 30
5737       ldone=.true.
5738    20 continue
5739 c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5740       if (fg_rank.lt.nfgtasks-1) then
5741 C Receive correlation contributions from the next processor
5742         msglen=msglen1
5743         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5744 cd      write (iout,*) 'Processor',fg_rank,
5745 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5746 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5747 c        write (*,*) 'Processor',fg_rank,
5748 c     &' is receiving correlation contribution from processor',fg_rank+1,
5749 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5750         time00=MPI_Wtime()
5751         nbytes=-1
5752         do while (nbytes.le.0)
5753           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5754           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5755         enddo
5756 c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
5757         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5758      &    fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5759         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5760 c        write (*,*) 'Processor',fg_rank,
5761 c     &' has received correlation contribution from processor',fg_rank+1,
5762 c     & ' msglen=',msglen,' nbytes=',nbytes
5763 c        write (*,*) 'The received BUFFER array:'
5764 c        do i=1,max_cont
5765 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
5766 c        enddo
5767         if (msglen.eq.msglen1) then
5768           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5769         else if (msglen.eq.msglen2)  then
5770           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5771           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5772         else
5773           write (iout,*)
5774      & 'ERROR!!!! message length changed while processing correlations.'
5775           write (*,*)
5776      & 'ERROR!!!! message length changed while processing correlations.'
5777           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5778         endif ! msglen.eq.msglen1
5779       endif ! fg_rank.lt.nfgtasks-1
5780       if (ldone) goto 30
5781       ldone=.true.
5782       goto 10
5783    30 continue
5784 #endif
5785       if (lprn) then
5786         write (iout,'(a)') 'Contact function values:'
5787         do i=nnt,nct-2
5788           write (iout,'(2i3,50(1x,i2,f5.2))')
5789      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5790      &    j=1,num_cont_hb(i))
5791         enddo
5792       endif
5793       ecorr=0.0D0
5794 C Remove the loop below after debugging !!!
5795       do i=nnt,nct
5796         do j=1,3
5797           gradcorr(j,i)=0.0D0
5798           gradxorr(j,i)=0.0D0
5799         enddo
5800       enddo
5801 C Calculate the local-electrostatic correlation terms
5802       do i=iatel_s,iatel_e+1
5803         i1=i+1
5804         num_conti=num_cont_hb(i)
5805         num_conti1=num_cont_hb(i+1)
5806         do jj=1,num_conti
5807           j=jcont_hb(jj,i)
5808           do kk=1,num_conti1
5809             j1=jcont_hb(kk,i1)
5810 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5811 c     &         ' jj=',jj,' kk=',kk
5812             if (j1.eq.j+1 .or. j1.eq.j-1) then
5813 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5814 C The system gains extra energy.
5815               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5816               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5817      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5818               n_corr=n_corr+1
5819             else if (j1.eq.j) then
5820 C Contacts I-J and I-(J+1) occur simultaneously.
5821 C The system loses extra energy.
5822 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5823             endif
5824           enddo ! kk
5825           do kk=1,num_conti
5826             j1=jcont_hb(kk,i)
5827 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5828 c    &         ' jj=',jj,' kk=',kk
5829             if (j1.eq.j+1) then
5830 C Contacts I-J and (I+1)-J occur simultaneously.
5831 C The system loses extra energy.
5832 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5833             endif ! j1==j+1
5834           enddo ! kk
5835         enddo ! jj
5836       enddo ! i
5837       return
5838       end
5839 c------------------------------------------------------------------------------
5840       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5841      &  n_corr1)
5842 C This subroutine calculates multi-body contributions to hydrogen-bonding
5843       implicit real*8 (a-h,o-z)
5844       include 'DIMENSIONS'
5845       include 'COMMON.IOUNITS'
5846 #ifdef MPI
5847       include 'mpif.h'
5848       parameter (max_cont=maxconts)
5849       parameter (max_dim=2*(8*3+6))
5850 c      parameter (msglen1=max_cont*max_dim*4)
5851       parameter (msglen1=max_cont*max_dim/2)
5852       parameter (msglen2=2*msglen1)
5853       integer source,CorrelType,CorrelID,Error
5854       double precision buffer(max_cont,max_dim)
5855       integer status(MPI_STATUS_SIZE)
5856 #endif
5857       include 'COMMON.SETUP'
5858       include 'COMMON.FFIELD'
5859       include 'COMMON.DERIV'
5860       include 'COMMON.INTERACT'
5861       include 'COMMON.CONTACTS'
5862       include 'COMMON.CONTROL'
5863       double precision gx(3),gx1(3)
5864       logical lprn,ldone
5865 C Set lprn=.true. for debugging
5866       lprn=.false.
5867       eturn6=0.0d0
5868 #ifdef MPI
5869       n_corr=0
5870       n_corr1=0
5871       if (fgProcs.le.1) goto 30
5872       if (lprn) then
5873         write (iout,'(a)') 'Contact function values:'
5874         do i=nnt,nct-2
5875           write (iout,'(2i3,50(1x,i2,f5.2))')
5876      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5877      &    j=1,num_cont_hb(i))
5878         enddo
5879       endif
5880 C Caution! Following code assumes that electrostatic interactions concerning
5881 C a given atom are split among at most two processors!
5882       CorrelType=477
5883       CorrelID=MyID+1
5884       ldone=.false.
5885       do i=1,max_cont
5886         do j=1,max_dim
5887           buffer(i,j)=0.0D0
5888         enddo
5889       enddo
5890       mm=mod(MyRank,2)
5891 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5892       if (mm) 20,20,10
5893    10 continue
5894 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5895       if (MyRank.gt.0) then
5896 C Send correlation contributions to the preceding processor
5897         msglen=msglen1
5898         nn=num_cont_hb(iatel_s)
5899         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5900 cd      write (iout,*) 'The BUFFER array:'
5901 cd      do i=1,nn
5902 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5903 cd      enddo
5904         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5905           msglen=msglen2
5906             call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5907 C Clear the contacts of the atom passed to the neighboring processor
5908         nn=num_cont_hb(iatel_s+1)
5909 cd      do i=1,nn
5910 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5911 cd      enddo
5912             num_cont_hb(iatel_s)=0
5913         endif
5914 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5915 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5916 cd   & ' msglen=',msglen
5917 cd      write (*,*) 'Processor ',MyID,MyRank,
5918 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5919 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5920         time00=MPI_Wtime()
5921         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5922      &     CorrelType,FG_COMM,IERROR)
5923         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5924 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5925 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5926 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5927 cd      write (*,*) 'Processor ',fg_rank,
5928 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5929 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5930         msglen=msglen1
5931       endif ! (MyRank.gt.0)
5932       if (ldone) goto 30
5933       ldone=.true.
5934    20 continue
5935 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5936       if (fg_rank.lt.nfgtasks-1) then
5937 C Receive correlation contributions from the next processor
5938         msglen=msglen1
5939         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5940 cd      write (iout,*) 'Processor',fg_rank,
5941 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5942 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5943 cd      write (*,*) 'Processor',fg_rank,
5944 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5945 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5946         time00=MPI_Wtime()
5947         nbytes=-1
5948         do while (nbytes.le.0)
5949           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5950           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5951         enddo
5952 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5953         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5954      &    fg_rank+1,CorrelType,status,IERROR)
5955         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5956 cd      write (iout,*) 'Processor',fg_rank,
5957 cd   & ' has received correlation contribution from processor',fg_rank+1,
5958 cd   & ' msglen=',msglen,' nbytes=',nbytes
5959 cd      write (iout,*) 'The received BUFFER array:'
5960 cd      do i=1,max_cont
5961 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5962 cd      enddo
5963         if (msglen.eq.msglen1) then
5964           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5965         else if (msglen.eq.msglen2)  then
5966           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5967           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5968         else
5969           write (iout,*)
5970      & 'ERROR!!!! message length changed while processing correlations.'
5971           write (*,*)
5972      & 'ERROR!!!! message length changed while processing correlations.'
5973           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5974         endif ! msglen.eq.msglen1
5975       endif ! fg_rank.lt.nfgtasks-1
5976       if (ldone) goto 30
5977       ldone=.true.
5978       goto 10
5979    30 continue
5980 #endif
5981       if (lprn) then
5982         write (iout,'(a)') 'Contact function values:'
5983         do i=nnt,nct-2
5984           write (iout,'(2i3,50(1x,i2,f5.2))')
5985      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5986      &    j=1,num_cont_hb(i))
5987         enddo
5988       endif
5989       ecorr=0.0D0
5990       ecorr5=0.0d0
5991       ecorr6=0.0d0
5992 C Remove the loop below after debugging !!!
5993       do i=nnt,nct
5994         do j=1,3
5995           gradcorr(j,i)=0.0D0
5996           gradxorr(j,i)=0.0D0
5997         enddo
5998       enddo
5999 C Calculate the dipole-dipole interaction energies
6000       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6001       do i=iatel_s,iatel_e+1
6002         num_conti=num_cont_hb(i)
6003         do jj=1,num_conti
6004           j=jcont_hb(jj,i)
6005 #ifdef MOMENT
6006           call dipole(i,j,jj)
6007 #endif
6008         enddo
6009       enddo
6010       endif
6011 C Calculate the local-electrostatic correlation terms
6012       do i=iatel_s,iatel_e+1
6013         i1=i+1
6014         num_conti=num_cont_hb(i)
6015         num_conti1=num_cont_hb(i+1)
6016         do jj=1,num_conti
6017           j=jcont_hb(jj,i)
6018           do kk=1,num_conti1
6019             j1=jcont_hb(kk,i1)
6020 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6021 c     &         ' jj=',jj,' kk=',kk
6022             if (j1.eq.j+1 .or. j1.eq.j-1) then
6023 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6024 C The system gains extra energy.
6025               n_corr=n_corr+1
6026               sqd1=dsqrt(d_cont(jj,i))
6027               sqd2=dsqrt(d_cont(kk,i1))
6028               sred_geom = sqd1*sqd2
6029               IF (sred_geom.lt.cutoff_corr) THEN
6030                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6031      &            ekont,fprimcont)
6032 cd               write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6033 cd     &         ' jj=',jj,' kk=',kk
6034                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6035                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6036                 do l=1,3
6037                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6038                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6039                 enddo
6040                 n_corr1=n_corr1+1
6041 cd               write (iout,*) 'sred_geom=',sred_geom,
6042 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6043                 call calc_eello(i,j,i+1,j1,jj,kk)
6044                 if (wcorr4.gt.0.0d0)
6045      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6046                   if (energy_dec.and.wcorr4.gt.0.0d0)
6047      1                 write (iout,'(a6,2i5,0pf7.3)')
6048      2                'ecorr4',i,j,eello4(i,j,i+1,j1,jj,kk)
6049                 if (wcorr5.gt.0.0d0)
6050      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6051                   if (energy_dec.and.wcorr5.gt.0.0d0)
6052      1                 write (iout,'(a6,2i5,0pf7.3)')
6053      2                'ecorr5',i,j,eello5(i,j,i+1,j1,jj,kk)
6054 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6055 cd                write(2,*)'ijkl',i,j,i+1,j1
6056                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6057      &               .or. wturn6.eq.0.0d0))then
6058 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6059                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6060                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6061      1                'ecorr6',i,j,eello6(i,j,i+1,j1,jj,kk)
6062 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6063 cd     &            'ecorr6=',ecorr6
6064 cd                write (iout,'(4e15.5)') sred_geom,
6065 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6066 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6067 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6068                 else if (wturn6.gt.0.0d0
6069      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6070 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6071                   eturn6=eturn6+eello_turn6(i,jj,kk)
6072                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6073      1                 'eturn6',i,j,eello_turn6(i,jj,kk)
6074 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6075                 endif
6076               ENDIF
6077 1111          continue
6078             else if (j1.eq.j) then
6079 C Contacts I-J and I-(J+1) occur simultaneously.
6080 C The system loses extra energy.
6081 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6082             endif
6083           enddo ! kk
6084           do kk=1,num_conti
6085             j1=jcont_hb(kk,i)
6086 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6087 c    &         ' jj=',jj,' kk=',kk
6088             if (j1.eq.j+1) then
6089 C Contacts I-J and (I+1)-J occur simultaneously.
6090 C The system loses extra energy.
6091 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6092             endif ! j1==j+1
6093           enddo ! kk
6094         enddo ! jj
6095       enddo ! i
6096       return
6097       end
6098 c------------------------------------------------------------------------------
6099       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6100       implicit real*8 (a-h,o-z)
6101       include 'DIMENSIONS'
6102       include 'COMMON.IOUNITS'
6103       include 'COMMON.DERIV'
6104       include 'COMMON.INTERACT'
6105       include 'COMMON.CONTACTS'
6106       double precision gx(3),gx1(3)
6107       logical lprn
6108       lprn=.false.
6109       eij=facont_hb(jj,i)
6110       ekl=facont_hb(kk,k)
6111       ees0pij=ees0p(jj,i)
6112       ees0pkl=ees0p(kk,k)
6113       ees0mij=ees0m(jj,i)
6114       ees0mkl=ees0m(kk,k)
6115       ekont=eij*ekl
6116       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6117 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6118 C Following 4 lines for diagnostics.
6119 cd    ees0pkl=0.0D0
6120 cd    ees0pij=1.0D0
6121 cd    ees0mkl=0.0D0
6122 cd    ees0mij=1.0D0
6123 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6124 c    &   ' and',k,l
6125 c     write (iout,*)'Contacts have occurred for peptide groups',
6126 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6127 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6128 C Calculate the multi-body contribution to energy.
6129       ecorr=ecorr+ekont*ees
6130 C Calculate multi-body contributions to the gradient.
6131       do ll=1,3
6132         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6133         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6134      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6135      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6136         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6137      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6138      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6139         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6140         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6141      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6142      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6143         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6144      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6145      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6146       enddo
6147       do m=i+1,j-1
6148         do ll=1,3
6149           gradcorr(ll,m)=gradcorr(ll,m)+
6150      &     ees*ekl*gacont_hbr(ll,jj,i)-
6151      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6152      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6153         enddo
6154       enddo
6155       do m=k+1,l-1
6156         do ll=1,3
6157           gradcorr(ll,m)=gradcorr(ll,m)+
6158      &     ees*eij*gacont_hbr(ll,kk,k)-
6159      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6160      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6161         enddo
6162       enddo
6163       ehbcorr=ekont*ees
6164       return
6165       end
6166 #ifdef MOMENT
6167 C---------------------------------------------------------------------------
6168       subroutine dipole(i,j,jj)
6169       implicit real*8 (a-h,o-z)
6170       include 'DIMENSIONS'
6171       include 'COMMON.IOUNITS'
6172       include 'COMMON.CHAIN'
6173       include 'COMMON.FFIELD'
6174       include 'COMMON.DERIV'
6175       include 'COMMON.INTERACT'
6176       include 'COMMON.CONTACTS'
6177       include 'COMMON.TORSION'
6178       include 'COMMON.VAR'
6179       include 'COMMON.GEO'
6180       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6181      &  auxmat(2,2)
6182       iti1 = itortyp(itype(i+1))
6183       if (j.lt.nres-1) then
6184         itj1 = itortyp(itype(j+1))
6185       else
6186         itj1=ntortyp+1
6187       endif
6188       do iii=1,2
6189         dipi(iii,1)=Ub2(iii,i)
6190         dipderi(iii)=Ub2der(iii,i)
6191         dipi(iii,2)=b1(iii,iti1)
6192         dipj(iii,1)=Ub2(iii,j)
6193         dipderj(iii)=Ub2der(iii,j)
6194         dipj(iii,2)=b1(iii,itj1)
6195       enddo
6196       kkk=0
6197       do iii=1,2
6198         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6199         do jjj=1,2
6200           kkk=kkk+1
6201           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6202         enddo
6203       enddo
6204       do kkk=1,5
6205         do lll=1,3
6206           mmm=0
6207           do iii=1,2
6208             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6209      &        auxvec(1))
6210             do jjj=1,2
6211               mmm=mmm+1
6212               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6213             enddo
6214           enddo
6215         enddo
6216       enddo
6217       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6218       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6219       do iii=1,2
6220         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6221       enddo
6222       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6223       do iii=1,2
6224         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6225       enddo
6226       return
6227       end
6228 #endif
6229 C---------------------------------------------------------------------------
6230       subroutine calc_eello(i,j,k,l,jj,kk)
6231 C
6232 C This subroutine computes matrices and vectors needed to calculate
6233 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6234 C
6235       implicit real*8 (a-h,o-z)
6236       include 'DIMENSIONS'
6237       include 'COMMON.IOUNITS'
6238       include 'COMMON.CHAIN'
6239       include 'COMMON.DERIV'
6240       include 'COMMON.INTERACT'
6241       include 'COMMON.CONTACTS'
6242       include 'COMMON.TORSION'
6243       include 'COMMON.VAR'
6244       include 'COMMON.GEO'
6245       include 'COMMON.FFIELD'
6246       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6247      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6248       logical lprn
6249       common /kutas/ lprn
6250 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6251 cd     & ' jj=',jj,' kk=',kk
6252 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6253       do iii=1,2
6254         do jjj=1,2
6255           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6256           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6257         enddo
6258       enddo
6259       call transpose2(aa1(1,1),aa1t(1,1))
6260       call transpose2(aa2(1,1),aa2t(1,1))
6261       do kkk=1,5
6262         do lll=1,3
6263           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6264      &      aa1tder(1,1,lll,kkk))
6265           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6266      &      aa2tder(1,1,lll,kkk))
6267         enddo
6268       enddo
6269       if (l.eq.j+1) then
6270 C parallel orientation of the two CA-CA-CA frames.
6271         if (i.gt.1) then
6272           iti=itortyp(itype(i))
6273         else
6274           iti=ntortyp+1
6275         endif
6276         itk1=itortyp(itype(k+1))
6277         itj=itortyp(itype(j))
6278         if (l.lt.nres-1) then
6279           itl1=itortyp(itype(l+1))
6280         else
6281           itl1=ntortyp+1
6282         endif
6283 C A1 kernel(j+1) A2T
6284 cd        do iii=1,2
6285 cd          write (iout,'(3f10.5,5x,3f10.5)')
6286 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6287 cd        enddo
6288         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6289      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6290      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6291 C Following matrices are needed only for 6-th order cumulants
6292         IF (wcorr6.gt.0.0d0) THEN
6293         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6294      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6295      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6296         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6297      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6298      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6299      &   ADtEAderx(1,1,1,1,1,1))
6300         lprn=.false.
6301         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6302      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6303      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6304      &   ADtEA1derx(1,1,1,1,1,1))
6305         ENDIF
6306 C End 6-th order cumulants
6307 cd        lprn=.false.
6308 cd        if (lprn) then
6309 cd        write (2,*) 'In calc_eello6'
6310 cd        do iii=1,2
6311 cd          write (2,*) 'iii=',iii
6312 cd          do kkk=1,5
6313 cd            write (2,*) 'kkk=',kkk
6314 cd            do jjj=1,2
6315 cd              write (2,'(3(2f10.5),5x)')
6316 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6317 cd            enddo
6318 cd          enddo
6319 cd        enddo
6320 cd        endif
6321         call transpose2(EUgder(1,1,k),auxmat(1,1))
6322         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6323         call transpose2(EUg(1,1,k),auxmat(1,1))
6324         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6325         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6326         do iii=1,2
6327           do kkk=1,5
6328             do lll=1,3
6329               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6330      &          EAEAderx(1,1,lll,kkk,iii,1))
6331             enddo
6332           enddo
6333         enddo
6334 C A1T kernel(i+1) A2
6335         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6336      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6337      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6338 C Following matrices are needed only for 6-th order cumulants
6339         IF (wcorr6.gt.0.0d0) THEN
6340         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6341      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6342      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6343         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6344      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6345      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6346      &   ADtEAderx(1,1,1,1,1,2))
6347         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6348      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6349      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6350      &   ADtEA1derx(1,1,1,1,1,2))
6351         ENDIF
6352 C End 6-th order cumulants
6353         call transpose2(EUgder(1,1,l),auxmat(1,1))
6354         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6355         call transpose2(EUg(1,1,l),auxmat(1,1))
6356         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6357         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6358         do iii=1,2
6359           do kkk=1,5
6360             do lll=1,3
6361               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6362      &          EAEAderx(1,1,lll,kkk,iii,2))
6363             enddo
6364           enddo
6365         enddo
6366 C AEAb1 and AEAb2
6367 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6368 C They are needed only when the fifth- or the sixth-order cumulants are
6369 C indluded.
6370         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6371         call transpose2(AEA(1,1,1),auxmat(1,1))
6372         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6373         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6374         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6375         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6376         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6377         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6378         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6379         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6380         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6381         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6382         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6383         call transpose2(AEA(1,1,2),auxmat(1,1))
6384         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6385         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6386         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6387         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6388         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6389         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6390         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6391         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6392         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6393         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6394         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6395 C Calculate the Cartesian derivatives of the vectors.
6396         do iii=1,2
6397           do kkk=1,5
6398             do lll=1,3
6399               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6400               call matvec2(auxmat(1,1),b1(1,iti),
6401      &          AEAb1derx(1,lll,kkk,iii,1,1))
6402               call matvec2(auxmat(1,1),Ub2(1,i),
6403      &          AEAb2derx(1,lll,kkk,iii,1,1))
6404               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6405      &          AEAb1derx(1,lll,kkk,iii,2,1))
6406               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6407      &          AEAb2derx(1,lll,kkk,iii,2,1))
6408               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6409               call matvec2(auxmat(1,1),b1(1,itj),
6410      &          AEAb1derx(1,lll,kkk,iii,1,2))
6411               call matvec2(auxmat(1,1),Ub2(1,j),
6412      &          AEAb2derx(1,lll,kkk,iii,1,2))
6413               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6414      &          AEAb1derx(1,lll,kkk,iii,2,2))
6415               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6416      &          AEAb2derx(1,lll,kkk,iii,2,2))
6417             enddo
6418           enddo
6419         enddo
6420         ENDIF
6421 C End vectors
6422       else
6423 C Antiparallel orientation of the two CA-CA-CA frames.
6424         if (i.gt.1) then
6425           iti=itortyp(itype(i))
6426         else
6427           iti=ntortyp+1
6428         endif
6429         itk1=itortyp(itype(k+1))
6430         itl=itortyp(itype(l))
6431         itj=itortyp(itype(j))
6432         if (j.lt.nres-1) then
6433           itj1=itortyp(itype(j+1))
6434         else
6435           itj1=ntortyp+1
6436         endif
6437 C A2 kernel(j-1)T A1T
6438         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6439      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6440      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6441 C Following matrices are needed only for 6-th order cumulants
6442         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6443      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6444         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6445      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6446      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6447         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6448      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6449      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6450      &   ADtEAderx(1,1,1,1,1,1))
6451         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6452      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6453      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6454      &   ADtEA1derx(1,1,1,1,1,1))
6455         ENDIF
6456 C End 6-th order cumulants
6457         call transpose2(EUgder(1,1,k),auxmat(1,1))
6458         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6459         call transpose2(EUg(1,1,k),auxmat(1,1))
6460         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6461         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6462         do iii=1,2
6463           do kkk=1,5
6464             do lll=1,3
6465               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6466      &          EAEAderx(1,1,lll,kkk,iii,1))
6467             enddo
6468           enddo
6469         enddo
6470 C A2T kernel(i+1)T A1
6471         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6472      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6473      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6474 C Following matrices are needed only for 6-th order cumulants
6475         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6476      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6477         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6478      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6479      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6480         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6481      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6482      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6483      &   ADtEAderx(1,1,1,1,1,2))
6484         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6485      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6486      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6487      &   ADtEA1derx(1,1,1,1,1,2))
6488         ENDIF
6489 C End 6-th order cumulants
6490         call transpose2(EUgder(1,1,j),auxmat(1,1))
6491         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6492         call transpose2(EUg(1,1,j),auxmat(1,1))
6493         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6494         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6495         do iii=1,2
6496           do kkk=1,5
6497             do lll=1,3
6498               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6499      &          EAEAderx(1,1,lll,kkk,iii,2))
6500             enddo
6501           enddo
6502         enddo
6503 C AEAb1 and AEAb2
6504 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6505 C They are needed only when the fifth- or the sixth-order cumulants are
6506 C indluded.
6507         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6508      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6509         call transpose2(AEA(1,1,1),auxmat(1,1))
6510         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6511         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6512         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6513         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6514         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6515         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6516         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6517         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6518         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6519         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6520         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6521         call transpose2(AEA(1,1,2),auxmat(1,1))
6522         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6523         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6524         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6525         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6526         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6527         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6528         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6529         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6530         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6531         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6532         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6533 C Calculate the Cartesian derivatives of the vectors.
6534         do iii=1,2
6535           do kkk=1,5
6536             do lll=1,3
6537               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6538               call matvec2(auxmat(1,1),b1(1,iti),
6539      &          AEAb1derx(1,lll,kkk,iii,1,1))
6540               call matvec2(auxmat(1,1),Ub2(1,i),
6541      &          AEAb2derx(1,lll,kkk,iii,1,1))
6542               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6543      &          AEAb1derx(1,lll,kkk,iii,2,1))
6544               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6545      &          AEAb2derx(1,lll,kkk,iii,2,1))
6546               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6547               call matvec2(auxmat(1,1),b1(1,itl),
6548      &          AEAb1derx(1,lll,kkk,iii,1,2))
6549               call matvec2(auxmat(1,1),Ub2(1,l),
6550      &          AEAb2derx(1,lll,kkk,iii,1,2))
6551               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6552      &          AEAb1derx(1,lll,kkk,iii,2,2))
6553               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6554      &          AEAb2derx(1,lll,kkk,iii,2,2))
6555             enddo
6556           enddo
6557         enddo
6558         ENDIF
6559 C End vectors
6560       endif
6561       return
6562       end
6563 C---------------------------------------------------------------------------
6564       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6565      &  KK,KKderg,AKA,AKAderg,AKAderx)
6566       implicit none
6567       integer nderg
6568       logical transp
6569       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6570      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6571      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6572       integer iii,kkk,lll
6573       integer jjj,mmm
6574       logical lprn
6575       common /kutas/ lprn
6576       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6577       do iii=1,nderg
6578         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6579      &    AKAderg(1,1,iii))
6580       enddo
6581 cd      if (lprn) write (2,*) 'In kernel'
6582       do kkk=1,5
6583 cd        if (lprn) write (2,*) 'kkk=',kkk
6584         do lll=1,3
6585           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6586      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6587 cd          if (lprn) then
6588 cd            write (2,*) 'lll=',lll
6589 cd            write (2,*) 'iii=1'
6590 cd            do jjj=1,2
6591 cd              write (2,'(3(2f10.5),5x)')
6592 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6593 cd            enddo
6594 cd          endif
6595           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6596      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6597 cd          if (lprn) then
6598 cd            write (2,*) 'lll=',lll
6599 cd            write (2,*) 'iii=2'
6600 cd            do jjj=1,2
6601 cd              write (2,'(3(2f10.5),5x)')
6602 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6603 cd            enddo
6604 cd          endif
6605         enddo
6606       enddo
6607       return
6608       end
6609 C---------------------------------------------------------------------------
6610       double precision function eello4(i,j,k,l,jj,kk)
6611       implicit real*8 (a-h,o-z)
6612       include 'DIMENSIONS'
6613       include 'COMMON.IOUNITS'
6614       include 'COMMON.CHAIN'
6615       include 'COMMON.DERIV'
6616       include 'COMMON.INTERACT'
6617       include 'COMMON.CONTACTS'
6618       include 'COMMON.TORSION'
6619       include 'COMMON.VAR'
6620       include 'COMMON.GEO'
6621       double precision pizda(2,2),ggg1(3),ggg2(3)
6622 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6623 cd        eello4=0.0d0
6624 cd        return
6625 cd      endif
6626 cd      print *,'eello4:',i,j,k,l,jj,kk
6627 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6628 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6629 cold      eij=facont_hb(jj,i)
6630 cold      ekl=facont_hb(kk,k)
6631 cold      ekont=eij*ekl
6632       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6633 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6634       gcorr_loc(k-1)=gcorr_loc(k-1)
6635      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6636       if (l.eq.j+1) then
6637         gcorr_loc(l-1)=gcorr_loc(l-1)
6638      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6639       else
6640         gcorr_loc(j-1)=gcorr_loc(j-1)
6641      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6642       endif
6643       do iii=1,2
6644         do kkk=1,5
6645           do lll=1,3
6646             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6647      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6648 cd            derx(lll,kkk,iii)=0.0d0
6649           enddo
6650         enddo
6651       enddo
6652 cd      gcorr_loc(l-1)=0.0d0
6653 cd      gcorr_loc(j-1)=0.0d0
6654 cd      gcorr_loc(k-1)=0.0d0
6655 cd      eel4=1.0d0
6656 cd      write (iout,*)'Contacts have occurred for peptide groups',
6657 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6658 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6659       if (j.lt.nres-1) then
6660         j1=j+1
6661         j2=j-1
6662       else
6663         j1=j-1
6664         j2=j-2
6665       endif
6666       if (l.lt.nres-1) then
6667         l1=l+1
6668         l2=l-1
6669       else
6670         l1=l-1
6671         l2=l-2
6672       endif
6673       do ll=1,3
6674 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6675         ggg1(ll)=eel4*g_contij(ll,1)
6676         ggg2(ll)=eel4*g_contij(ll,2)
6677         ghalf=0.5d0*ggg1(ll)
6678 cd        ghalf=0.0d0
6679         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6680         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6681         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6682         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6683 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6684         ghalf=0.5d0*ggg2(ll)
6685 cd        ghalf=0.0d0
6686         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6687         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6688         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6689         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6690       enddo
6691 cd      goto 1112
6692       do m=i+1,j-1
6693         do ll=1,3
6694 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6695           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6696         enddo
6697       enddo
6698       do m=k+1,l-1
6699         do ll=1,3
6700 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6701           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6702         enddo
6703       enddo
6704 1112  continue
6705       do m=i+2,j2
6706         do ll=1,3
6707           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6708         enddo
6709       enddo
6710       do m=k+2,l2
6711         do ll=1,3
6712           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6713         enddo
6714       enddo
6715 cd      do iii=1,nres-3
6716 cd        write (2,*) iii,gcorr_loc(iii)
6717 cd      enddo
6718       eello4=ekont*eel4
6719 cd      write (2,*) 'ekont',ekont
6720 cd      write (iout,*) 'eello4',ekont*eel4
6721       return
6722       end
6723 C---------------------------------------------------------------------------
6724       double precision function eello5(i,j,k,l,jj,kk)
6725       implicit real*8 (a-h,o-z)
6726       include 'DIMENSIONS'
6727       include 'COMMON.IOUNITS'
6728       include 'COMMON.CHAIN'
6729       include 'COMMON.DERIV'
6730       include 'COMMON.INTERACT'
6731       include 'COMMON.CONTACTS'
6732       include 'COMMON.TORSION'
6733       include 'COMMON.VAR'
6734       include 'COMMON.GEO'
6735       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6736       double precision ggg1(3),ggg2(3)
6737 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6738 C                                                                              C
6739 C                            Parallel chains                                   C
6740 C                                                                              C
6741 C          o             o                   o             o                   C
6742 C         /l\           / \             \   / \           / \   /              C
6743 C        /   \         /   \             \ /   \         /   \ /               C
6744 C       j| o |l1       | o |              o| o |         | o |o                C
6745 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6746 C      \i/   \         /   \ /             /   \         /   \                 C
6747 C       o    k1             o                                                  C
6748 C         (I)          (II)                (III)          (IV)                 C
6749 C                                                                              C
6750 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6751 C                                                                              C
6752 C                            Antiparallel chains                               C
6753 C                                                                              C
6754 C          o             o                   o             o                   C
6755 C         /j\           / \             \   / \           / \   /              C
6756 C        /   \         /   \             \ /   \         /   \ /               C
6757 C      j1| o |l        | o |              o| o |         | o |o                C
6758 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6759 C      \i/   \         /   \ /             /   \         /   \                 C
6760 C       o     k1            o                                                  C
6761 C         (I)          (II)                (III)          (IV)                 C
6762 C                                                                              C
6763 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6764 C                                                                              C
6765 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6766 C                                                                              C
6767 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6768 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6769 cd        eello5=0.0d0
6770 cd        return
6771 cd      endif
6772 cd      write (iout,*)
6773 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6774 cd     &   ' and',k,l
6775       itk=itortyp(itype(k))
6776       itl=itortyp(itype(l))
6777       itj=itortyp(itype(j))
6778       eello5_1=0.0d0
6779       eello5_2=0.0d0
6780       eello5_3=0.0d0
6781       eello5_4=0.0d0
6782 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6783 cd     &   eel5_3_num,eel5_4_num)
6784       do iii=1,2
6785         do kkk=1,5
6786           do lll=1,3
6787             derx(lll,kkk,iii)=0.0d0
6788           enddo
6789         enddo
6790       enddo
6791 cd      eij=facont_hb(jj,i)
6792 cd      ekl=facont_hb(kk,k)
6793 cd      ekont=eij*ekl
6794 cd      write (iout,*)'Contacts have occurred for peptide groups',
6795 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6796 cd      goto 1111
6797 C Contribution from the graph I.
6798 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6799 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6800       call transpose2(EUg(1,1,k),auxmat(1,1))
6801       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6802       vv(1)=pizda(1,1)-pizda(2,2)
6803       vv(2)=pizda(1,2)+pizda(2,1)
6804       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6805      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6806 C Explicit gradient in virtual-dihedral angles.
6807       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6808      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6809      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6810       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6811       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6812       vv(1)=pizda(1,1)-pizda(2,2)
6813       vv(2)=pizda(1,2)+pizda(2,1)
6814       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6815      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6816      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6817       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6818       vv(1)=pizda(1,1)-pizda(2,2)
6819       vv(2)=pizda(1,2)+pizda(2,1)
6820       if (l.eq.j+1) then
6821         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6822      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6823      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6824       else
6825         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6826      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6827      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6828       endif
6829 C Cartesian gradient
6830       do iii=1,2
6831         do kkk=1,5
6832           do lll=1,3
6833             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6834      &        pizda(1,1))
6835             vv(1)=pizda(1,1)-pizda(2,2)
6836             vv(2)=pizda(1,2)+pizda(2,1)
6837             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6838      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6839      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6840           enddo
6841         enddo
6842       enddo
6843 c      goto 1112
6844 c1111  continue
6845 C Contribution from graph II
6846       call transpose2(EE(1,1,itk),auxmat(1,1))
6847       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6848       vv(1)=pizda(1,1)+pizda(2,2)
6849       vv(2)=pizda(2,1)-pizda(1,2)
6850       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6851      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6852 C Explicit gradient in virtual-dihedral angles.
6853       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6854      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6855       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6856       vv(1)=pizda(1,1)+pizda(2,2)
6857       vv(2)=pizda(2,1)-pizda(1,2)
6858       if (l.eq.j+1) then
6859         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6860      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6861      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6862       else
6863         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6864      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6865      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6866       endif
6867 C Cartesian gradient
6868       do iii=1,2
6869         do kkk=1,5
6870           do lll=1,3
6871             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6872      &        pizda(1,1))
6873             vv(1)=pizda(1,1)+pizda(2,2)
6874             vv(2)=pizda(2,1)-pizda(1,2)
6875             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6876      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6877      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6878           enddo
6879         enddo
6880       enddo
6881 cd      goto 1112
6882 cd1111  continue
6883       if (l.eq.j+1) then
6884 cd        goto 1110
6885 C Parallel orientation
6886 C Contribution from graph III
6887         call transpose2(EUg(1,1,l),auxmat(1,1))
6888         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6889         vv(1)=pizda(1,1)-pizda(2,2)
6890         vv(2)=pizda(1,2)+pizda(2,1)
6891         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6892      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6893 C Explicit gradient in virtual-dihedral angles.
6894         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6895      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6896      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6897         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6898         vv(1)=pizda(1,1)-pizda(2,2)
6899         vv(2)=pizda(1,2)+pizda(2,1)
6900         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6901      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6902      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6903         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6904         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6905         vv(1)=pizda(1,1)-pizda(2,2)
6906         vv(2)=pizda(1,2)+pizda(2,1)
6907         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6908      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6909      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6910 C Cartesian gradient
6911         do iii=1,2
6912           do kkk=1,5
6913             do lll=1,3
6914               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6915      &          pizda(1,1))
6916               vv(1)=pizda(1,1)-pizda(2,2)
6917               vv(2)=pizda(1,2)+pizda(2,1)
6918               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6919      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6920      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6921             enddo
6922           enddo
6923         enddo
6924 cd        goto 1112
6925 C Contribution from graph IV
6926 cd1110    continue
6927         call transpose2(EE(1,1,itl),auxmat(1,1))
6928         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6929         vv(1)=pizda(1,1)+pizda(2,2)
6930         vv(2)=pizda(2,1)-pizda(1,2)
6931         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6932      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6933 C Explicit gradient in virtual-dihedral angles.
6934         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6935      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6936         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6937         vv(1)=pizda(1,1)+pizda(2,2)
6938         vv(2)=pizda(2,1)-pizda(1,2)
6939         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6940      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6941      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6942 C Cartesian gradient
6943         do iii=1,2
6944           do kkk=1,5
6945             do lll=1,3
6946               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6947      &          pizda(1,1))
6948               vv(1)=pizda(1,1)+pizda(2,2)
6949               vv(2)=pizda(2,1)-pizda(1,2)
6950               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6951      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6952      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6953             enddo
6954           enddo
6955         enddo
6956       else
6957 C Antiparallel orientation
6958 C Contribution from graph III
6959 c        goto 1110
6960         call transpose2(EUg(1,1,j),auxmat(1,1))
6961         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6962         vv(1)=pizda(1,1)-pizda(2,2)
6963         vv(2)=pizda(1,2)+pizda(2,1)
6964         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6965      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6966 C Explicit gradient in virtual-dihedral angles.
6967         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6968      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6969      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6970         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6971         vv(1)=pizda(1,1)-pizda(2,2)
6972         vv(2)=pizda(1,2)+pizda(2,1)
6973         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6974      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6975      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6976         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6977         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6978         vv(1)=pizda(1,1)-pizda(2,2)
6979         vv(2)=pizda(1,2)+pizda(2,1)
6980         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6981      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6982      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6983 C Cartesian gradient
6984         do iii=1,2
6985           do kkk=1,5
6986             do lll=1,3
6987               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6988      &          pizda(1,1))
6989               vv(1)=pizda(1,1)-pizda(2,2)
6990               vv(2)=pizda(1,2)+pizda(2,1)
6991               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6992      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6993      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6994             enddo
6995           enddo
6996         enddo
6997 cd        goto 1112
6998 C Contribution from graph IV
6999 1110    continue
7000         call transpose2(EE(1,1,itj),auxmat(1,1))
7001         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7002         vv(1)=pizda(1,1)+pizda(2,2)
7003         vv(2)=pizda(2,1)-pizda(1,2)
7004         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7005      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7006 C Explicit gradient in virtual-dihedral angles.
7007         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7008      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7009         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7010         vv(1)=pizda(1,1)+pizda(2,2)
7011         vv(2)=pizda(2,1)-pizda(1,2)
7012         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7013      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7014      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7015 C Cartesian gradient
7016         do iii=1,2
7017           do kkk=1,5
7018             do lll=1,3
7019               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7020      &          pizda(1,1))
7021               vv(1)=pizda(1,1)+pizda(2,2)
7022               vv(2)=pizda(2,1)-pizda(1,2)
7023               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7024      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7025      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7026             enddo
7027           enddo
7028         enddo
7029       endif
7030 1112  continue
7031       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7032 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7033 cd        write (2,*) 'ijkl',i,j,k,l
7034 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7035 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7036 cd      endif
7037 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7038 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7039 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7040 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7041       if (j.lt.nres-1) then
7042         j1=j+1
7043         j2=j-1
7044       else
7045         j1=j-1
7046         j2=j-2
7047       endif
7048       if (l.lt.nres-1) then
7049         l1=l+1
7050         l2=l-1
7051       else
7052         l1=l-1
7053         l2=l-2
7054       endif
7055 cd      eij=1.0d0
7056 cd      ekl=1.0d0
7057 cd      ekont=1.0d0
7058 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7059       do ll=1,3
7060         ggg1(ll)=eel5*g_contij(ll,1)
7061         ggg2(ll)=eel5*g_contij(ll,2)
7062 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7063         ghalf=0.5d0*ggg1(ll)
7064 cd        ghalf=0.0d0
7065         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7066         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7067         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7068         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7069 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7070         ghalf=0.5d0*ggg2(ll)
7071 cd        ghalf=0.0d0
7072         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7073         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7074         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7075         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7076       enddo
7077 cd      goto 1112
7078       do m=i+1,j-1
7079         do ll=1,3
7080 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7081           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7082         enddo
7083       enddo
7084       do m=k+1,l-1
7085         do ll=1,3
7086 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7087           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7088         enddo
7089       enddo
7090 c1112  continue
7091       do m=i+2,j2
7092         do ll=1,3
7093           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7094         enddo
7095       enddo
7096       do m=k+2,l2
7097         do ll=1,3
7098           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7099         enddo
7100       enddo
7101 cd      do iii=1,nres-3
7102 cd        write (2,*) iii,g_corr5_loc(iii)
7103 cd      enddo
7104       eello5=ekont*eel5
7105 cd      write (2,*) 'ekont',ekont
7106 cd      write (iout,*) 'eello5',ekont*eel5
7107       return
7108       end
7109 c--------------------------------------------------------------------------
7110       double precision function eello6(i,j,k,l,jj,kk)
7111       implicit real*8 (a-h,o-z)
7112       include 'DIMENSIONS'
7113       include 'COMMON.IOUNITS'
7114       include 'COMMON.CHAIN'
7115       include 'COMMON.DERIV'
7116       include 'COMMON.INTERACT'
7117       include 'COMMON.CONTACTS'
7118       include 'COMMON.TORSION'
7119       include 'COMMON.VAR'
7120       include 'COMMON.GEO'
7121       include 'COMMON.FFIELD'
7122       double precision ggg1(3),ggg2(3)
7123 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7124 cd        eello6=0.0d0
7125 cd        return
7126 cd      endif
7127 cd      write (iout,*)
7128 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7129 cd     &   ' and',k,l
7130       eello6_1=0.0d0
7131       eello6_2=0.0d0
7132       eello6_3=0.0d0
7133       eello6_4=0.0d0
7134       eello6_5=0.0d0
7135       eello6_6=0.0d0
7136 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7137 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7138       do iii=1,2
7139         do kkk=1,5
7140           do lll=1,3
7141             derx(lll,kkk,iii)=0.0d0
7142           enddo
7143         enddo
7144       enddo
7145 cd      eij=facont_hb(jj,i)
7146 cd      ekl=facont_hb(kk,k)
7147 cd      ekont=eij*ekl
7148 cd      eij=1.0d0
7149 cd      ekl=1.0d0
7150 cd      ekont=1.0d0
7151       if (l.eq.j+1) then
7152         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7153         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7154         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7155         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7156         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7157         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7158       else
7159         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7160         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7161         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7162         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7163         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7164           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7165         else
7166           eello6_5=0.0d0
7167         endif
7168         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7169       endif
7170 C If turn contributions are considered, they will be handled separately.
7171       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7172 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7173 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7174 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7175 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7176 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7177 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7178 cd      goto 1112
7179       if (j.lt.nres-1) then
7180         j1=j+1
7181         j2=j-1
7182       else
7183         j1=j-1
7184         j2=j-2
7185       endif
7186       if (l.lt.nres-1) then
7187         l1=l+1
7188         l2=l-1
7189       else
7190         l1=l-1
7191         l2=l-2
7192       endif
7193       do ll=1,3
7194         ggg1(ll)=eel6*g_contij(ll,1)
7195         ggg2(ll)=eel6*g_contij(ll,2)
7196 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7197         ghalf=0.5d0*ggg1(ll)
7198 cd        ghalf=0.0d0
7199         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7200         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7201         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7202         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7203         ghalf=0.5d0*ggg2(ll)
7204 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7205 cd        ghalf=0.0d0
7206         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7207         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7208         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7209         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7210       enddo
7211 cd      goto 1112
7212       do m=i+1,j-1
7213         do ll=1,3
7214 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7215           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7216         enddo
7217       enddo
7218       do m=k+1,l-1
7219         do ll=1,3
7220 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7221           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7222         enddo
7223       enddo
7224 1112  continue
7225       do m=i+2,j2
7226         do ll=1,3
7227           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7228         enddo
7229       enddo
7230       do m=k+2,l2
7231         do ll=1,3
7232           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7233         enddo
7234       enddo
7235 cd      do iii=1,nres-3
7236 cd        write (2,*) iii,g_corr6_loc(iii)
7237 cd      enddo
7238       eello6=ekont*eel6
7239 cd      write (2,*) 'ekont',ekont
7240 cd      write (iout,*) 'eello6',ekont*eel6
7241       return
7242       end
7243 c--------------------------------------------------------------------------
7244       double precision function eello6_graph1(i,j,k,l,imat,swap)
7245       implicit real*8 (a-h,o-z)
7246       include 'DIMENSIONS'
7247       include 'COMMON.IOUNITS'
7248       include 'COMMON.CHAIN'
7249       include 'COMMON.DERIV'
7250       include 'COMMON.INTERACT'
7251       include 'COMMON.CONTACTS'
7252       include 'COMMON.TORSION'
7253       include 'COMMON.VAR'
7254       include 'COMMON.GEO'
7255       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7256       logical swap
7257       logical lprn
7258       common /kutas/ lprn
7259 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7260 C
7261 C      Parallel       Antiparallel
7262 C
7263 C          o             o
7264 C         /l\           /j\
7265 C        /   \         /   \
7266 C       /| o |         | o |\
7267 C     \ j|/k\|  /   \  |/k\|l /
7268 C      \ /   \ /     \ /   \ /
7269 C       o     o       o     o
7270 C       i             i
7271 C
7272 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7273       itk=itortyp(itype(k))
7274       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7275       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7276       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7277       call transpose2(EUgC(1,1,k),auxmat(1,1))
7278       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7279       vv1(1)=pizda1(1,1)-pizda1(2,2)
7280       vv1(2)=pizda1(1,2)+pizda1(2,1)
7281       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7282       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7283       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7284       s5=scalar2(vv(1),Dtobr2(1,i))
7285 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7286       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7287       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7288      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7289      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7290      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7291      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7292      & +scalar2(vv(1),Dtobr2der(1,i)))
7293       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7294       vv1(1)=pizda1(1,1)-pizda1(2,2)
7295       vv1(2)=pizda1(1,2)+pizda1(2,1)
7296       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7297       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7298       if (l.eq.j+1) then
7299         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7300      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7301      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7302      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7303      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7304       else
7305         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7306      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7307      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7308      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7309      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7310       endif
7311       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7312       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7313       vv1(1)=pizda1(1,1)-pizda1(2,2)
7314       vv1(2)=pizda1(1,2)+pizda1(2,1)
7315       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7316      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7317      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7318      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7319       do iii=1,2
7320         if (swap) then
7321           ind=3-iii
7322         else
7323           ind=iii
7324         endif
7325         do kkk=1,5
7326           do lll=1,3
7327             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7328             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7329             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7330             call transpose2(EUgC(1,1,k),auxmat(1,1))
7331             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7332      &        pizda1(1,1))
7333             vv1(1)=pizda1(1,1)-pizda1(2,2)
7334             vv1(2)=pizda1(1,2)+pizda1(2,1)
7335             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7336             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7337      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7338             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7339      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7340             s5=scalar2(vv(1),Dtobr2(1,i))
7341             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7342           enddo
7343         enddo
7344       enddo
7345       return
7346       end
7347 c----------------------------------------------------------------------------
7348       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7349       implicit real*8 (a-h,o-z)
7350       include 'DIMENSIONS'
7351       include 'COMMON.IOUNITS'
7352       include 'COMMON.CHAIN'
7353       include 'COMMON.DERIV'
7354       include 'COMMON.INTERACT'
7355       include 'COMMON.CONTACTS'
7356       include 'COMMON.TORSION'
7357       include 'COMMON.VAR'
7358       include 'COMMON.GEO'
7359       logical swap
7360       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7361      & auxvec1(2),auxvec2(1),auxmat1(2,2)
7362       logical lprn
7363       common /kutas/ lprn
7364 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7365 C
7366 C      Parallel       Antiparallel
7367 C
7368 C          o             o
7369 C     \   /l\           /j\   /
7370 C      \ /   \         /   \ /
7371 C       o| o |         | o |o
7372 C     \ j|/k\|      \  |/k\|l
7373 C      \ /   \       \ /   \
7374 C       o             o
7375 C       i             i
7376 C
7377 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7378 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7379 C AL 7/4/01 s1 would occur in the sixth-order moment,
7380 C           but not in a cluster cumulant
7381 #ifdef MOMENT
7382       s1=dip(1,jj,i)*dip(1,kk,k)
7383 #endif
7384       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7385       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7386       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7387       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7388       call transpose2(EUg(1,1,k),auxmat(1,1))
7389       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7390       vv(1)=pizda(1,1)-pizda(2,2)
7391       vv(2)=pizda(1,2)+pizda(2,1)
7392       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7393 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7394 #ifdef MOMENT
7395       eello6_graph2=-(s1+s2+s3+s4)
7396 #else
7397       eello6_graph2=-(s2+s3+s4)
7398 #endif
7399 c      eello6_graph2=-s3
7400 C Derivatives in gamma(i-1)
7401       if (i.gt.1) then
7402 #ifdef MOMENT
7403         s1=dipderg(1,jj,i)*dip(1,kk,k)
7404 #endif
7405         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7406         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7407         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7408         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7409 #ifdef MOMENT
7410         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7411 #else
7412         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7413 #endif
7414 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7415       endif
7416 C Derivatives in gamma(k-1)
7417 #ifdef MOMENT
7418       s1=dip(1,jj,i)*dipderg(1,kk,k)
7419 #endif
7420       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7421       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7422       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7423       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7424       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7425       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7426       vv(1)=pizda(1,1)-pizda(2,2)
7427       vv(2)=pizda(1,2)+pizda(2,1)
7428       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7429 #ifdef MOMENT
7430       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7431 #else
7432       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7433 #endif
7434 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7435 C Derivatives in gamma(j-1) or gamma(l-1)
7436       if (j.gt.1) then
7437 #ifdef MOMENT
7438         s1=dipderg(3,jj,i)*dip(1,kk,k)
7439 #endif
7440         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7441         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7442         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7443         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7444         vv(1)=pizda(1,1)-pizda(2,2)
7445         vv(2)=pizda(1,2)+pizda(2,1)
7446         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7447 #ifdef MOMENT
7448         if (swap) then
7449           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7450         else
7451           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7452         endif
7453 #endif
7454         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7455 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7456       endif
7457 C Derivatives in gamma(l-1) or gamma(j-1)
7458       if (l.gt.1) then
7459 #ifdef MOMENT
7460         s1=dip(1,jj,i)*dipderg(3,kk,k)
7461 #endif
7462         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7463         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7464         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7465         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7466         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7467         vv(1)=pizda(1,1)-pizda(2,2)
7468         vv(2)=pizda(1,2)+pizda(2,1)
7469         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7470 #ifdef MOMENT
7471         if (swap) then
7472           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7473         else
7474           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7475         endif
7476 #endif
7477         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7478 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7479       endif
7480 C Cartesian derivatives.
7481       if (lprn) then
7482         write (2,*) 'In eello6_graph2'
7483         do iii=1,2
7484           write (2,*) 'iii=',iii
7485           do kkk=1,5
7486             write (2,*) 'kkk=',kkk
7487             do jjj=1,2
7488               write (2,'(3(2f10.5),5x)')
7489      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7490             enddo
7491           enddo
7492         enddo
7493       endif
7494       do iii=1,2
7495         do kkk=1,5
7496           do lll=1,3
7497 #ifdef MOMENT
7498             if (iii.eq.1) then
7499               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7500             else
7501               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7502             endif
7503 #endif
7504             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7505      &        auxvec(1))
7506             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7507             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7508      &        auxvec(1))
7509             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7510             call transpose2(EUg(1,1,k),auxmat(1,1))
7511             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7512      &        pizda(1,1))
7513             vv(1)=pizda(1,1)-pizda(2,2)
7514             vv(2)=pizda(1,2)+pizda(2,1)
7515             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7516 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7517 #ifdef MOMENT
7518             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7519 #else
7520             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7521 #endif
7522             if (swap) then
7523               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7524             else
7525               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7526             endif
7527           enddo
7528         enddo
7529       enddo
7530       return
7531       end
7532 c----------------------------------------------------------------------------
7533       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7534       implicit real*8 (a-h,o-z)
7535       include 'DIMENSIONS'
7536       include 'COMMON.IOUNITS'
7537       include 'COMMON.CHAIN'
7538       include 'COMMON.DERIV'
7539       include 'COMMON.INTERACT'
7540       include 'COMMON.CONTACTS'
7541       include 'COMMON.TORSION'
7542       include 'COMMON.VAR'
7543       include 'COMMON.GEO'
7544       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7545       logical swap
7546 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7547 C
7548 C      Parallel       Antiparallel
7549 C
7550 C          o             o
7551 C         /l\   /   \   /j\
7552 C        /   \ /     \ /   \
7553 C       /| o |o       o| o |\
7554 C       j|/k\|  /      |/k\|l /
7555 C        /   \ /       /   \ /
7556 C       /     o       /     o
7557 C       i             i
7558 C
7559 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7560 C
7561 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7562 C           energy moment and not to the cluster cumulant.
7563       iti=itortyp(itype(i))
7564       if (j.lt.nres-1) then
7565         itj1=itortyp(itype(j+1))
7566       else
7567         itj1=ntortyp+1
7568       endif
7569       itk=itortyp(itype(k))
7570       itk1=itortyp(itype(k+1))
7571       if (l.lt.nres-1) then
7572         itl1=itortyp(itype(l+1))
7573       else
7574         itl1=ntortyp+1
7575       endif
7576 #ifdef MOMENT
7577       s1=dip(4,jj,i)*dip(4,kk,k)
7578 #endif
7579       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7580       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7581       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7582       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7583       call transpose2(EE(1,1,itk),auxmat(1,1))
7584       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7585       vv(1)=pizda(1,1)+pizda(2,2)
7586       vv(2)=pizda(2,1)-pizda(1,2)
7587       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7588 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7589 #ifdef MOMENT
7590       eello6_graph3=-(s1+s2+s3+s4)
7591 #else
7592       eello6_graph3=-(s2+s3+s4)
7593 #endif
7594 c      eello6_graph3=-s4
7595 C Derivatives in gamma(k-1)
7596       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7597       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7598       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7599       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7600 C Derivatives in gamma(l-1)
7601       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7602       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7603       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7604       vv(1)=pizda(1,1)+pizda(2,2)
7605       vv(2)=pizda(2,1)-pizda(1,2)
7606       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7607       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7608 C Cartesian derivatives.
7609       do iii=1,2
7610         do kkk=1,5
7611           do lll=1,3
7612 #ifdef MOMENT
7613             if (iii.eq.1) then
7614               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7615             else
7616               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7617             endif
7618 #endif
7619             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7620      &        auxvec(1))
7621             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7622             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7623      &        auxvec(1))
7624             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7625             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7626      &        pizda(1,1))
7627             vv(1)=pizda(1,1)+pizda(2,2)
7628             vv(2)=pizda(2,1)-pizda(1,2)
7629             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7630 #ifdef MOMENT
7631             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7632 #else
7633             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7634 #endif
7635             if (swap) then
7636               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7637             else
7638               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7639             endif
7640 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7641           enddo
7642         enddo
7643       enddo
7644       return
7645       end
7646 c----------------------------------------------------------------------------
7647       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7648       implicit real*8 (a-h,o-z)
7649       include 'DIMENSIONS'
7650       include 'COMMON.IOUNITS'
7651       include 'COMMON.CHAIN'
7652       include 'COMMON.DERIV'
7653       include 'COMMON.INTERACT'
7654       include 'COMMON.CONTACTS'
7655       include 'COMMON.TORSION'
7656       include 'COMMON.VAR'
7657       include 'COMMON.GEO'
7658       include 'COMMON.FFIELD'
7659       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7660      & auxvec1(2),auxmat1(2,2)
7661       logical swap
7662 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7663 C
7664 C      Parallel       Antiparallel
7665 C
7666 C          o             o
7667 C         /l\   /   \   /j\
7668 C        /   \ /     \ /   \
7669 C       /| o |o       o| o |\
7670 C     \ j|/k\|      \  |/k\|l
7671 C      \ /   \       \ /   \
7672 C       o     \       o     \
7673 C       i             i
7674 C
7675 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7676 C
7677 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7678 C           energy moment and not to the cluster cumulant.
7679 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7680       iti=itortyp(itype(i))
7681       itj=itortyp(itype(j))
7682       if (j.lt.nres-1) then
7683         itj1=itortyp(itype(j+1))
7684       else
7685         itj1=ntortyp+1
7686       endif
7687       itk=itortyp(itype(k))
7688       if (k.lt.nres-1) then
7689         itk1=itortyp(itype(k+1))
7690       else
7691         itk1=ntortyp+1
7692       endif
7693       itl=itortyp(itype(l))
7694       if (l.lt.nres-1) then
7695         itl1=itortyp(itype(l+1))
7696       else
7697         itl1=ntortyp+1
7698       endif
7699 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7700 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7701 cd     & ' itl',itl,' itl1',itl1
7702 #ifdef MOMENT
7703       if (imat.eq.1) then
7704         s1=dip(3,jj,i)*dip(3,kk,k)
7705       else
7706         s1=dip(2,jj,j)*dip(2,kk,l)
7707       endif
7708 #endif
7709       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7710       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7711       if (j.eq.l+1) then
7712         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7713         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7714       else
7715         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7716         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7717       endif
7718       call transpose2(EUg(1,1,k),auxmat(1,1))
7719       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7720       vv(1)=pizda(1,1)-pizda(2,2)
7721       vv(2)=pizda(2,1)+pizda(1,2)
7722       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7723 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7724 #ifdef MOMENT
7725       eello6_graph4=-(s1+s2+s3+s4)
7726 #else
7727       eello6_graph4=-(s2+s3+s4)
7728 #endif
7729 C Derivatives in gamma(i-1)
7730       if (i.gt.1) then
7731 #ifdef MOMENT
7732         if (imat.eq.1) then
7733           s1=dipderg(2,jj,i)*dip(3,kk,k)
7734         else
7735           s1=dipderg(4,jj,j)*dip(2,kk,l)
7736         endif
7737 #endif
7738         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7739         if (j.eq.l+1) then
7740           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7741           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7742         else
7743           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7744           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7745         endif
7746         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7747         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7748 cd          write (2,*) 'turn6 derivatives'
7749 #ifdef MOMENT
7750           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7751 #else
7752           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7753 #endif
7754         else
7755 #ifdef MOMENT
7756           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7757 #else
7758           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7759 #endif
7760         endif
7761       endif
7762 C Derivatives in gamma(k-1)
7763 #ifdef MOMENT
7764       if (imat.eq.1) then
7765         s1=dip(3,jj,i)*dipderg(2,kk,k)
7766       else
7767         s1=dip(2,jj,j)*dipderg(4,kk,l)
7768       endif
7769 #endif
7770       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7771       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7772       if (j.eq.l+1) then
7773         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7774         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7775       else
7776         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7777         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7778       endif
7779       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7780       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7781       vv(1)=pizda(1,1)-pizda(2,2)
7782       vv(2)=pizda(2,1)+pizda(1,2)
7783       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7784       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7785 #ifdef MOMENT
7786         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7787 #else
7788         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7789 #endif
7790       else
7791 #ifdef MOMENT
7792         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7793 #else
7794         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7795 #endif
7796       endif
7797 C Derivatives in gamma(j-1) or gamma(l-1)
7798       if (l.eq.j+1 .and. l.gt.1) then
7799         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7800         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7801         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7802         vv(1)=pizda(1,1)-pizda(2,2)
7803         vv(2)=pizda(2,1)+pizda(1,2)
7804         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7805         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7806       else if (j.gt.1) then
7807         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7808         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7809         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7810         vv(1)=pizda(1,1)-pizda(2,2)
7811         vv(2)=pizda(2,1)+pizda(1,2)
7812         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7813         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7814           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7815         else
7816           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7817         endif
7818       endif
7819 C Cartesian derivatives.
7820       do iii=1,2
7821         do kkk=1,5
7822           do lll=1,3
7823 #ifdef MOMENT
7824             if (iii.eq.1) then
7825               if (imat.eq.1) then
7826                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7827               else
7828                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7829               endif
7830             else
7831               if (imat.eq.1) then
7832                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7833               else
7834                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7835               endif
7836             endif
7837 #endif
7838             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7839      &        auxvec(1))
7840             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7841             if (j.eq.l+1) then
7842               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7843      &          b1(1,itj1),auxvec(1))
7844               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7845             else
7846               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7847      &          b1(1,itl1),auxvec(1))
7848               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7849             endif
7850             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7851      &        pizda(1,1))
7852             vv(1)=pizda(1,1)-pizda(2,2)
7853             vv(2)=pizda(2,1)+pizda(1,2)
7854             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7855             if (swap) then
7856               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7857 #ifdef MOMENT
7858                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7859      &             -(s1+s2+s4)
7860 #else
7861                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7862      &             -(s2+s4)
7863 #endif
7864                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7865               else
7866 #ifdef MOMENT
7867                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7868 #else
7869                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7870 #endif
7871                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7872               endif
7873             else
7874 #ifdef MOMENT
7875               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7876 #else
7877               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7878 #endif
7879               if (l.eq.j+1) then
7880                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7881               else
7882                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7883               endif
7884             endif
7885           enddo
7886         enddo
7887       enddo
7888       return
7889       end
7890 c----------------------------------------------------------------------------
7891       double precision function eello_turn6(i,jj,kk)
7892       implicit real*8 (a-h,o-z)
7893       include 'DIMENSIONS'
7894       include 'COMMON.IOUNITS'
7895       include 'COMMON.CHAIN'
7896       include 'COMMON.DERIV'
7897       include 'COMMON.INTERACT'
7898       include 'COMMON.CONTACTS'
7899       include 'COMMON.TORSION'
7900       include 'COMMON.VAR'
7901       include 'COMMON.GEO'
7902       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7903      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7904      &  ggg1(3),ggg2(3)
7905       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7906      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7907 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7908 C           the respective energy moment and not to the cluster cumulant.
7909       s1=0.0d0
7910       s8=0.0d0
7911       s13=0.0d0
7912 c
7913       eello_turn6=0.0d0
7914       j=i+4
7915       k=i+1
7916       l=i+3
7917       iti=itortyp(itype(i))
7918       itk=itortyp(itype(k))
7919       itk1=itortyp(itype(k+1))
7920       itl=itortyp(itype(l))
7921       itj=itortyp(itype(j))
7922 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7923 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7924 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7925 cd        eello6=0.0d0
7926 cd        return
7927 cd      endif
7928 cd      write (iout,*)
7929 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7930 cd     &   ' and',k,l
7931 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7932       do iii=1,2
7933         do kkk=1,5
7934           do lll=1,3
7935             derx_turn(lll,kkk,iii)=0.0d0
7936           enddo
7937         enddo
7938       enddo
7939 cd      eij=1.0d0
7940 cd      ekl=1.0d0
7941 cd      ekont=1.0d0
7942       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7943 cd      eello6_5=0.0d0
7944 cd      write (2,*) 'eello6_5',eello6_5
7945 #ifdef MOMENT
7946       call transpose2(AEA(1,1,1),auxmat(1,1))
7947       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7948       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7949       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7950 #endif
7951       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7952       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7953       s2 = scalar2(b1(1,itk),vtemp1(1))
7954 #ifdef MOMENT
7955       call transpose2(AEA(1,1,2),atemp(1,1))
7956       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7957       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7958       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7959 #endif
7960       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7961       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7962       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7963 #ifdef MOMENT
7964       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7965       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7966       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7967       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7968       ss13 = scalar2(b1(1,itk),vtemp4(1))
7969       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7970 #endif
7971 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7972 c      s1=0.0d0
7973 c      s2=0.0d0
7974 c      s8=0.0d0
7975 c      s12=0.0d0
7976 c      s13=0.0d0
7977       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7978 C Derivatives in gamma(i+2)
7979       s1d =0.0d0
7980       s8d =0.0d0
7981 #ifdef MOMENT
7982       call transpose2(AEA(1,1,1),auxmatd(1,1))
7983       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7984       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7985       call transpose2(AEAderg(1,1,2),atempd(1,1))
7986       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7987       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7988 #endif
7989       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7990       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7991       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7992 c      s1d=0.0d0
7993 c      s2d=0.0d0
7994 c      s8d=0.0d0
7995 c      s12d=0.0d0
7996 c      s13d=0.0d0
7997       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7998 C Derivatives in gamma(i+3)
7999 #ifdef MOMENT
8000       call transpose2(AEA(1,1,1),auxmatd(1,1))
8001       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8002       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8003       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8004 #endif
8005       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8006       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8007       s2d = scalar2(b1(1,itk),vtemp1d(1))
8008 #ifdef MOMENT
8009       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8010       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8011 #endif
8012       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8013 #ifdef MOMENT
8014       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8015       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8016       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8017 #endif
8018 c      s1d=0.0d0
8019 c      s2d=0.0d0
8020 c      s8d=0.0d0
8021 c      s12d=0.0d0
8022 c      s13d=0.0d0
8023 #ifdef MOMENT
8024       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8025      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8026 #else
8027       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8028      &               -0.5d0*ekont*(s2d+s12d)
8029 #endif
8030 C Derivatives in gamma(i+4)
8031       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8032       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8033       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8034 #ifdef MOMENT
8035       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8036       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8037       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8038 #endif
8039 c      s1d=0.0d0
8040 c      s2d=0.0d0
8041 c      s8d=0.0d0
8042 C      s12d=0.0d0
8043 c      s13d=0.0d0
8044 #ifdef MOMENT
8045       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8046 #else
8047       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8048 #endif
8049 C Derivatives in gamma(i+5)
8050 #ifdef MOMENT
8051       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8052       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8053       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8054 #endif
8055       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8056       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8057       s2d = scalar2(b1(1,itk),vtemp1d(1))
8058 #ifdef MOMENT
8059       call transpose2(AEA(1,1,2),atempd(1,1))
8060       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8061       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8062 #endif
8063       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8064       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8065 #ifdef MOMENT
8066       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8067       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8068       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8069 #endif
8070 c      s1d=0.0d0
8071 c      s2d=0.0d0
8072 c      s8d=0.0d0
8073 c      s12d=0.0d0
8074 c      s13d=0.0d0
8075 #ifdef MOMENT
8076       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8077      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8078 #else
8079       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8080      &               -0.5d0*ekont*(s2d+s12d)
8081 #endif
8082 C Cartesian derivatives
8083       do iii=1,2
8084         do kkk=1,5
8085           do lll=1,3
8086 #ifdef MOMENT
8087             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8088             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8089             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8090 #endif
8091             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8092             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8093      &          vtemp1d(1))
8094             s2d = scalar2(b1(1,itk),vtemp1d(1))
8095 #ifdef MOMENT
8096             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8097             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8098             s8d = -(atempd(1,1)+atempd(2,2))*
8099      &           scalar2(cc(1,1,itl),vtemp2(1))
8100 #endif
8101             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8102      &           auxmatd(1,1))
8103             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8104             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8105 c      s1d=0.0d0
8106 c      s2d=0.0d0
8107 c      s8d=0.0d0
8108 c      s12d=0.0d0
8109 c      s13d=0.0d0
8110 #ifdef MOMENT
8111             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8112      &        - 0.5d0*(s1d+s2d)
8113 #else
8114             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8115      &        - 0.5d0*s2d
8116 #endif
8117 #ifdef MOMENT
8118             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8119      &        - 0.5d0*(s8d+s12d)
8120 #else
8121             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8122      &        - 0.5d0*s12d
8123 #endif
8124           enddo
8125         enddo
8126       enddo
8127 #ifdef MOMENT
8128       do kkk=1,5
8129         do lll=1,3
8130           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8131      &      achuj_tempd(1,1))
8132           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8133           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8134           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8135           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8136           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8137      &      vtemp4d(1))
8138           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8139           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8140           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8141         enddo
8142       enddo
8143 #endif
8144 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8145 cd     &  16*eel_turn6_num
8146 cd      goto 1112
8147       if (j.lt.nres-1) then
8148         j1=j+1
8149         j2=j-1
8150       else
8151         j1=j-1
8152         j2=j-2
8153       endif
8154       if (l.lt.nres-1) then
8155         l1=l+1
8156         l2=l-1
8157       else
8158         l1=l-1
8159         l2=l-2
8160       endif
8161       do ll=1,3
8162         ggg1(ll)=eel_turn6*g_contij(ll,1)
8163         ggg2(ll)=eel_turn6*g_contij(ll,2)
8164         ghalf=0.5d0*ggg1(ll)
8165 cd        ghalf=0.0d0
8166         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8167      &    +ekont*derx_turn(ll,2,1)
8168         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8169         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8170      &    +ekont*derx_turn(ll,4,1)
8171         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8172         ghalf=0.5d0*ggg2(ll)
8173 cd        ghalf=0.0d0
8174         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8175      &    +ekont*derx_turn(ll,2,2)
8176         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8177         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8178      &    +ekont*derx_turn(ll,4,2)
8179         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8180       enddo
8181 cd      goto 1112
8182       do m=i+1,j-1
8183         do ll=1,3
8184           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8185         enddo
8186       enddo
8187       do m=k+1,l-1
8188         do ll=1,3
8189           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8190         enddo
8191       enddo
8192 1112  continue
8193       do m=i+2,j2
8194         do ll=1,3
8195           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8196         enddo
8197       enddo
8198       do m=k+2,l2
8199         do ll=1,3
8200           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8201         enddo
8202       enddo
8203 cd      do iii=1,nres-3
8204 cd        write (2,*) iii,g_corr6_loc(iii)
8205 cd      enddo
8206       eello_turn6=ekont*eel_turn6
8207 cd      write (2,*) 'ekont',ekont
8208 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8209       return
8210       end
8211
8212 C-----------------------------------------------------------------------------
8213       double precision function scalar(u,v)
8214 !DIR$ INLINEALWAYS scalar
8215 #ifndef OSF
8216 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8217 #endif
8218       implicit none
8219       double precision u(3),v(3)
8220 cd      double precision sc
8221 cd      integer i
8222 cd      sc=0.0d0
8223 cd      do i=1,3
8224 cd        sc=sc+u(i)*v(i)
8225 cd      enddo
8226 cd      scalar=sc
8227
8228       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8229       return
8230       end
8231 crc-------------------------------------------------
8232       SUBROUTINE MATVEC2(A1,V1,V2)
8233 !DIR$ INLINEALWAYS MATVEC2
8234 #ifndef OSF
8235 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8236 #endif
8237       implicit real*8 (a-h,o-z)
8238       include 'DIMENSIONS'
8239       DIMENSION A1(2,2),V1(2),V2(2)
8240 c      DO 1 I=1,2
8241 c        VI=0.0
8242 c        DO 3 K=1,2
8243 c    3     VI=VI+A1(I,K)*V1(K)
8244 c        Vaux(I)=VI
8245 c    1 CONTINUE
8246
8247       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8248       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8249
8250       v2(1)=vaux1
8251       v2(2)=vaux2
8252       END
8253 C---------------------------------------
8254       SUBROUTINE MATMAT2(A1,A2,A3)
8255 #ifndef OSF
8256 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8257 #endif
8258       implicit real*8 (a-h,o-z)
8259       include 'DIMENSIONS'
8260       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8261 c      DIMENSION AI3(2,2)
8262 c        DO  J=1,2
8263 c          A3IJ=0.0
8264 c          DO K=1,2
8265 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8266 c          enddo
8267 c          A3(I,J)=A3IJ
8268 c       enddo
8269 c      enddo
8270
8271       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8272       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8273       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8274       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8275
8276       A3(1,1)=AI3_11
8277       A3(2,1)=AI3_21
8278       A3(1,2)=AI3_12
8279       A3(2,2)=AI3_22
8280       END
8281
8282 c-------------------------------------------------------------------------
8283       double precision function scalar2(u,v)
8284 !DIR$ INLINEALWAYS scalar2
8285       implicit none
8286       double precision u(2),v(2)
8287       double precision sc
8288       integer i
8289       scalar2=u(1)*v(1)+u(2)*v(2)
8290       return
8291       end
8292
8293 C-----------------------------------------------------------------------------
8294
8295       subroutine transpose2(a,at)
8296 !DIR$ INLINEALWAYS transpose2
8297 #ifndef OSF
8298 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8299 #endif
8300       implicit none
8301       double precision a(2,2),at(2,2)
8302       at(1,1)=a(1,1)
8303       at(1,2)=a(2,1)
8304       at(2,1)=a(1,2)
8305       at(2,2)=a(2,2)
8306       return
8307       end
8308 c--------------------------------------------------------------------------
8309       subroutine transpose(n,a,at)
8310       implicit none
8311       integer n,i,j
8312       double precision a(n,n),at(n,n)
8313       do i=1,n
8314         do j=1,n
8315           at(j,i)=a(i,j)
8316         enddo
8317       enddo
8318       return
8319       end
8320 C---------------------------------------------------------------------------
8321       subroutine prodmat3(a1,a2,kk,transp,prod)
8322 !DIR$ INLINEALWAYS prodmat3
8323 #ifndef OSF
8324 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8325 #endif
8326       implicit none
8327       integer i,j
8328       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8329       logical transp
8330 crc      double precision auxmat(2,2),prod_(2,2)
8331
8332       if (transp) then
8333 crc        call transpose2(kk(1,1),auxmat(1,1))
8334 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8335 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8336
8337            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8338      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8339            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8340      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8341            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8342      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8343            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8344      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8345
8346       else
8347 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8348 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8349
8350            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8351      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8352            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8353      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8354            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8355      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8356            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8357      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8358
8359       endif
8360 c      call transpose2(a2(1,1),a2t(1,1))
8361
8362 crc      print *,transp
8363 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8364 crc      print *,((prod(i,j),i=1,2),j=1,2)
8365
8366       return
8367       end
8368