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

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 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 #ifdef TIMING
 433       time01=MPI_Wtime()
 434 #endif
 435 #ifdef DEBUG
 436       write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 437       do i=1,nres-1
 438         write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 439      &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 440       enddo
 441       write (iout,*) "gcorr4_turn, gel_loc_turn4"
 442       do i=1,nres-1
 443         write (iout,'(i5,3f10.5,2x,f10.5)')
 444      &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 445       enddo
 446 #endif
 447       do i=nnt,nres-1
 448         do k=1,3
 449           gvdwc(k,i)=0.0d0
 450           gvdwc_scp(k,i)=0.0d0
 451         enddo
 452         do j=i+1,nres
 453           do k=1,3
 454             gvdwc(k,i)=gvdwc(k,i)+gvdwc(k,j)
 455             gvdwc_scp(k,i)=gvdwc_scp(k,i)+gvdwc_scp(k,j)
 456           enddo
 457         enddo
 458       enddo
 459       do i=nnt,nct-1
 460         do k=1,3
 461           gelc(k,i)=gelc(k,i)+0.5d0*gelc_long(k,i)
 462           gvdwpp(k,i)=0.5d0*gvdwpp(k,i)
 463           gvdwc_scp(k,i)=gvdwc_scp(k,i)+0.5d0*gvdwc_scpp(k,i)
 464         enddo
 465         do j=i+1,nct-1
 466           do k=1,3
 467             gelc(k,i)=gelc(k,i)+gelc_long(k,j)
 468             gvdwpp(k,i)=gvdwpp(k,i)+gvdwpp(k,j)
 469             gvdwc_scp(k,i)=gvdwc_scp(k,i)+gvdwc_scpp(k,j)
 470           enddo
 471         enddo
 472       enddo
 473       do i=nnt,nct-1
 474         do k=1,3
 475           gel_loc(k,i)=gel_loc(k,i)+0.5d0*gel_loc_long(k,i)
 476         enddo
 477         do j=i+1,nres-1
 478           do k=1,3
 479             gel_loc(k,i)=gel_loc(k,i)+gel_loc_long(k,j)
 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,nres)=0.0d0
 487       enddo
 488 C
 489 C Sum up the components of the Cartesian gradient.
 490 C
 491 #ifdef SPLITELE
 492       do i=1,nct
 493         do j=1,3
 494           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 495      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 496      &                wbond*gradb(j,i)+
 497      &                wstrain*ghpbc(j,i)+
 498      &                wcorr*gradcorr(j,i)+
 499      &                wel_loc*gel_loc(j,i)+
 500      &                wturn3*gcorr3_turn(j,i)+
 501      &                wturn4*gcorr4_turn(j,i)+
 502      &                wcorr5*gradcorr5(j,i)+
 503      &                wcorr6*gradcorr6(j,i)+
 504      &                wturn6*gcorr6_turn(j,i)+
 505      &                wsccor*gsccorc(j,i)
 506      &               +wscloc*gscloc(j,i)
 507           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 508      &                  wbond*gradbx(j,i)+
 509      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 510      &                  wsccor*gsccorx(j,i)
 511      &                 +wscloc*gsclocx(j,i)
 512         enddo
 513       enddo
 514 #else
 515       do i=1,nct
 516         do j=1,3
 517           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 518      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 519      &                wbond*gradb(j,i)+
 520      &                wcorr*gradcorr(j,i)+
 521      &                wel_loc*gel_loc(j,i)+
 522      &                wturn3*gcorr3_turn(j,i)+
 523      &                wturn4*gcorr4_turn(j,i)+
 524      &                wcorr5*gradcorr5(j,i)+
 525      &                wcorr6*gradcorr6(j,i)+
 526      &                wturn6*gcorr6_turn(j,i)+
 527      &                wsccor*gsccorc(j,i)
 528      &               +wscloc*gscloc(j,i)
 529           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 530      &                  wbond*gradbx(j,i)+
 531      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 532      &                  wsccor*gsccorx(j,i)
 533      &                 +wscloc*gsclocx(j,i)
 534         enddo
 535       enddo
 536 #endif
 537 #ifdef DEBUG
 538       write (iout,*) "gloc before adding corr"
 539       do i=1,4*nres
 540         write (iout,*) i,gloc(i,icg)
 541       enddo
 542 #endif
 543       do i=1,nres-3
 544         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 545      &   +wcorr5*g_corr5_loc(i)
 546      &   +wcorr6*g_corr6_loc(i)
 547      &   +wturn4*gel_loc_turn4(i)
 548      &   +wturn3*gel_loc_turn3(i)
 549      &   +wturn6*gel_loc_turn6(i)
 550      &   +wel_loc*gel_loc_loc(i)
 551      &   +wsccor*gsccor_loc(i)
 552       enddo
 553 #ifdef DEBUG
 554       write (iout,*) "gloc after adding corr"
 555       do i=1,4*nres
 556         write (iout,*) i,gloc(i,icg)
 557       enddo
 558 #endif
 559 #ifdef MPI
 560       if (nfgtasks.gt.1) then
 561         do j=1,3
 562           do i=1,nres
 563             gradbufc(j,i)=gradc(j,i,icg)
 564             gradbufx(j,i)=gradx(j,i,icg)
 565           enddo
 566         enddo
 567         do i=1,4*nres
 568           glocbuf(i)=gloc(i,icg)
 569         enddo
 570 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 571         if (fg_rank.eq.0) call MPI_Bcast(1,1,MPI_INTEGER,
 572      &      king,FG_COMM,IERROR)
 573         time00=MPI_Wtime()
 574         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 575      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 576         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 577      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 578         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 579      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 580         time_reduce=time_reduce+MPI_Wtime()-time00
 581 #ifdef DEBUG
 582       write (iout,*) "gloc after reduce"
 583       do i=1,4*nres
 584         write (iout,*) i,gloc(i,icg)
 585       enddo
 586 #endif
 587       endif
 588 #endif
 589       if (gnorm_check) then
 590 c
 591 c Compute the maximum elements of the gradient
 592 c
 593       gvdwc_max=0.0d0
 594       gvdwc_scp_max=0.0d0
 595       gelc_max=0.0d0
 596       gvdwpp_max=0.0d0
 597       gradb_max=0.0d0
 598       ghpbc_max=0.0d0
 599       gradcorr_max=0.0d0
 600       gel_loc_max=0.0d0
 601       gcorr3_turn_max=0.0d0
 602       gcorr4_turn_max=0.0d0
 603       gradcorr5_max=0.0d0
 604       gradcorr6_max=0.0d0
 605       gcorr6_turn_max=0.0d0
 606       gsccorc_max=0.0d0
 607       gscloc_max=0.0d0
 608       gvdwx_max=0.0d0
 609       gradx_scp_max=0.0d0
 610       ghpbx_max=0.0d0
 611       gradxorr_max=0.0d0
 612       gsccorx_max=0.0d0
 613       gsclocx_max=0.0d0
 614       do i=1,nct
 615         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 616         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 617         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 618         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 619      &   gvdwc_scp_max=gvdwc_scp_norm
 620         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 621         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 622         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 623         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 624         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 625         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 626         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 627         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 628         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 629         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 630         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 631         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 632         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 633      &    gcorr3_turn(1,i)))
 634         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 635      &    gcorr3_turn_max=gcorr3_turn_norm
 636         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 637      &    gcorr4_turn(1,i)))
 638         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 639      &    gcorr4_turn_max=gcorr4_turn_norm
 640         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 641         if (gradcorr5_norm.gt.gradcorr5_max)
 642      &    gradcorr5_max=gradcorr5_norm
 643         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 644         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 645         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 646      &    gcorr6_turn(1,i)))
 647         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 648      &    gcorr6_turn_max=gcorr6_turn_norm
 649         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 650         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 651         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 652         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 653         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 654         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 655         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 656         if (gradx_scp_norm.gt.gradx_scp_max)
 657      &    gradx_scp_max=gradx_scp_norm
 658         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 659         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 660         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 661         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 662         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 663         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 664         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 665         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 666       enddo
 667       if (gradout) then
 668 #ifdef AIX
 669         open(istat,file=statname,position="append")
 670 #else
 671         open(istat,file=statname,access="append")
 672 #endif
 673         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 674      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 675      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 676      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 677      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 678      &     gsccorx_max,gsclocx_max
 679         close(istat)
 680         if (gvdwc_max.gt.1.0d4) then
 681           write (iout,*) "gvdwc gvdwx gradb gradbx"
 682           do i=nnt,nct
 683             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 684      &        gradb(j,i),gradbx(j,i),j=1,3)
 685           enddo
 686           call pdbout(0.0d0,'cipiszcze',iout)
 687           call flush(iout)
 688         endif
 689       endif
 690       endif
 691 #ifdef DEBUG
 692       write (iout,*) "gradc gradx gloc"
 693       do i=1,nres
 694         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 695      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 696       enddo
 697 #endif
 698 #ifdef TIMING
 699       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 700 #endif
 701       return
 702       end
 703 c-------------------------------------------------------------------------------
 704       subroutine rescale_weights(t_bath)
 705       implicit real*8 (a-h,o-z)
 706       include 'DIMENSIONS'
 707       include 'COMMON.IOUNITS'
 708       include 'COMMON.FFIELD'
 709       include 'COMMON.SBRIDGE'
 710       double precision kfac /2.4d0/
 711       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 712 c      facT=temp0/t_bath
 713 c      facT=2*temp0/(t_bath+temp0)
 714       if (rescale_mode.eq.0) then
 715         facT=1.0d0
 716         facT2=1.0d0
 717         facT3=1.0d0
 718         facT4=1.0d0
 719         facT5=1.0d0
 720       else if (rescale_mode.eq.1) then
 721         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 722         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 723         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 724         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 725         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 726       else if (rescale_mode.eq.2) then
 727         x=t_bath/temp0
 728         x2=x*x
 729         x3=x2*x
 730         x4=x3*x
 731         x5=x4*x
 732         facT=licznik/dlog(dexp(x)+dexp(-x))
 733         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 734         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 735         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 736         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 737       else
 738         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 739         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 740 #ifdef MPI
 741        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 742 #endif
 743        stop 555
 744       endif
 745       welec=weights(3)*fact
 746       wcorr=weights(4)*fact3
 747       wcorr5=weights(5)*fact4
 748       wcorr6=weights(6)*fact5
 749       wel_loc=weights(7)*fact2
 750       wturn3=weights(8)*fact2
 751       wturn4=weights(9)*fact3
 752       wturn6=weights(10)*fact5
 753       wtor=weights(13)*fact
 754       wtor_d=weights(14)*fact2
 755       wsccor=weights(21)*fact
 756
 757       return
 758       end
 759 C------------------------------------------------------------------------
 760       subroutine enerprint(energia)
 761       implicit real*8 (a-h,o-z)
 762       include 'DIMENSIONS'
 763       include 'COMMON.IOUNITS'
 764       include 'COMMON.FFIELD'
 765       include 'COMMON.SBRIDGE'
 766       include 'COMMON.MD'
 767       double precision energia(0:n_ene)
 768       etot=energia(0)
 769       evdw=energia(1)
 770       evdw2=energia(2)
 771 #ifdef SCP14
 772       evdw2=energia(2)+energia(18)
 773 #else
 774       evdw2=energia(2)
 775 #endif
 776       ees=energia(3)
 777 #ifdef SPLITELE
 778       evdw1=energia(16)
 779 #endif
 780       ecorr=energia(4)
 781       ecorr5=energia(5)
 782       ecorr6=energia(6)
 783       eel_loc=energia(7)
 784       eello_turn3=energia(8)
 785       eello_turn4=energia(9)
 786       eello_turn6=energia(10)
 787       ebe=energia(11)
 788       escloc=energia(12)
 789       etors=energia(13)
 790       etors_d=energia(14)
 791       ehpb=energia(15)
 792       edihcnstr=energia(19)
 793       estr=energia(17)
 794       Uconst=energia(20)
 795       esccor=energia(21)
 796 #ifdef SPLITELE
 797       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 798      &  estr,wbond,ebe,wang,
 799      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 800      &  ecorr,wcorr,
 801      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 802      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 803      &  edihcnstr,ebr*nss,
 804      &  Uconst,etot
 805    10 format (/'Virtual-chain energies:'//
 806      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 807      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 808      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 809      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 810      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 811      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 812      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 813      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 814      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 815      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 816      & ' (SS bridges & dist. cnstr.)'/
 817      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 818      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 819      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 820      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 821      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 822      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 823      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 824      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 825      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 826      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 827      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 828      & 'ETOT=  ',1pE16.6,' (total)')
 829 #else
 830       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 831      &  estr,wbond,ebe,wang,
 832      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 833      &  ecorr,wcorr,
 834      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 835      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 836      &  ebr*nss,Uconst,etot
 837    10 format (/'Virtual-chain energies:'//
 838      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 839      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 840      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 841      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 842      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 843      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 844      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 845      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 846      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 847      & ' (SS bridges & dist. cnstr.)'/
 848      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 849      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 850      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 851      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 852      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 853      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 854      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 855      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 856      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 857      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 858      & 'UCONST=',1pE16.6,' (Constraint energy)'/
 859      & 'ETOT=  ',1pE16.6,' (total)')
 860 #endif
 861       return
 862       end
 863 C-----------------------------------------------------------------------
 864       subroutine elj(evdw)
 865 C
 866 C This subroutine calculates the interaction energy of nonbonded side chains
 867 C assuming the LJ potential of interaction.
 868 C
 869       implicit real*8 (a-h,o-z)
 870       include 'DIMENSIONS'
 871       parameter (accur=1.0d-10)
 872       include 'COMMON.GEO'
 873       include 'COMMON.VAR'
 874       include 'COMMON.LOCAL'
 875       include 'COMMON.CHAIN'
 876       include 'COMMON.DERIV'
 877       include 'COMMON.INTERACT'
 878       include 'COMMON.TORSION'
 879       include 'COMMON.SBRIDGE'
 880       include 'COMMON.NAMES'
 881       include 'COMMON.IOUNITS'
 882       include 'COMMON.CONTACTS'
 883       dimension gg(3)
 884 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 885       evdw=0.0D0
 886       do i=iatsc_s,iatsc_e
 887         itypi=itype(i)
 888         itypi1=itype(i+1)
 889         xi=c(1,nres+i)
 890         yi=c(2,nres+i)
 891         zi=c(3,nres+i)
 892 C Change 12/1/95
 893         num_conti=0
 894 C
 895 C Calculate SC interaction energy.
 896 C
 897         do iint=1,nint_gr(i)
 898 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 899 cd   &                  'iend=',iend(i,iint)
 900           do j=istart(i,iint),iend(i,iint)
 901             itypj=itype(j)
 902             xj=c(1,nres+j)-xi
 903             yj=c(2,nres+j)-yi
 904             zj=c(3,nres+j)-zi
 905 C Change 12/1/95 to calculate four-body interactions
 906             rij=xj*xj+yj*yj+zj*zj
 907             rrij=1.0D0/rij
 908 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 909             eps0ij=eps(itypi,itypj)
 910             fac=rrij**expon2
 911             e1=fac*fac*aa(itypi,itypj)
 912             e2=fac*bb(itypi,itypj)
 913             evdwij=e1+e2
 914 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 915 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 916 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 917 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 918 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 919 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 920             evdw=evdw+evdwij
 921 C
 922 C Calculate the components of the gradient in DC and X
 923 C
 924             fac=-rrij*(e1+evdwij)
 925             gg(1)=xj*fac
 926             gg(2)=yj*fac
 927             gg(3)=zj*fac
 928             do k=1,3
 929               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 930               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 931               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 932               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 933             enddo
 934 cgrad            do k=i,j-1
 935 cgrad              do l=1,3
 936 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 937 cgrad              enddo
 938 cgrad            enddo
 939 C
 940 C 12/1/95, revised on 5/20/97
 941 C
 942 C Calculate the contact function. The ith column of the array JCONT will
 943 C contain the numbers of atoms that make contacts with the atom I (of numbers
 944 C greater than I). The arrays FACONT and GACONT will contain the values of
 945 C the contact function and its derivative.
 946 C
 947 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 948 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 949 C Uncomment next line, if the correlation interactions are contact function only
 950             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 951               rij=dsqrt(rij)
 952               sigij=sigma(itypi,itypj)
 953               r0ij=rs0(itypi,itypj)
 954 C
 955 C Check whether the SC's are not too far to make a contact.
 956 C
 957               rcut=1.5d0*r0ij
 958               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 959 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 960 C
 961               if (fcont.gt.0.0D0) then
 962 C If the SC-SC distance if close to sigma, apply spline.
 963 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 964 cAdam &             fcont1,fprimcont1)
 965 cAdam           fcont1=1.0d0-fcont1
 966 cAdam           if (fcont1.gt.0.0d0) then
 967 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 968 cAdam             fcont=fcont*fcont1
 969 cAdam           endif
 970 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 971 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 972 cga             do k=1,3
 973 cga               gg(k)=gg(k)*eps0ij
 974 cga             enddo
 975 cga             eps0ij=-evdwij*eps0ij
 976 C Uncomment for AL's type of SC correlation interactions.
 977 cadam           eps0ij=-evdwij
 978                 num_conti=num_conti+1
 979                 jcont(num_conti,i)=j
 980                 facont(num_conti,i)=fcont*eps0ij
 981                 fprimcont=eps0ij*fprimcont/rij
 982                 fcont=expon*fcont
 983 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 984 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 985 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 986 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 987                 gacont(1,num_conti,i)=-fprimcont*xj
 988                 gacont(2,num_conti,i)=-fprimcont*yj
 989                 gacont(3,num_conti,i)=-fprimcont*zj
 990 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 991 cd              write (iout,'(2i3,3f10.5)')
 992 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 993               endif
 994             endif
 995           enddo      ! j
 996         enddo        ! iint
 997 C Change 12/1/95
 998         num_cont(i)=num_conti
 999       enddo          ! i
1000       do i=1,nct
1001         do j=1,3
1002           gvdwc(j,i)=expon*gvdwc(j,i)
1003           gvdwx(j,i)=expon*gvdwx(j,i)
1004         enddo
1005       enddo
1006 C******************************************************************************
1007 C
1008 C                              N O T E !!!
1009 C
1010 C To save time, the factor of EXPON has been extracted from ALL components
1011 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1012 C use!
1013 C
1014 C******************************************************************************
1015       return
1016       end
1017 C-----------------------------------------------------------------------------
1018       subroutine eljk(evdw)
1019 C
1020 C This subroutine calculates the interaction energy of nonbonded side chains
1021 C assuming the LJK potential of interaction.
1022 C
1023       implicit real*8 (a-h,o-z)
1024       include 'DIMENSIONS'
1025       include 'COMMON.GEO'
1026       include 'COMMON.VAR'
1027       include 'COMMON.LOCAL'
1028       include 'COMMON.CHAIN'
1029       include 'COMMON.DERIV'
1030       include 'COMMON.INTERACT'
1031       include 'COMMON.IOUNITS'
1032       include 'COMMON.NAMES'
1033       dimension gg(3)
1034       logical scheck
1035 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1036       evdw=0.0D0
1037       do i=iatsc_s,iatsc_e
1038         itypi=itype(i)
1039         itypi1=itype(i+1)
1040         xi=c(1,nres+i)
1041         yi=c(2,nres+i)
1042         zi=c(3,nres+i)
1043 C
1044 C Calculate SC interaction energy.
1045 C
1046         do iint=1,nint_gr(i)
1047           do j=istart(i,iint),iend(i,iint)
1048             itypj=itype(j)
1049             xj=c(1,nres+j)-xi
1050             yj=c(2,nres+j)-yi
1051             zj=c(3,nres+j)-zi
1052             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1053             fac_augm=rrij**expon
1054             e_augm=augm(itypi,itypj)*fac_augm
1055             r_inv_ij=dsqrt(rrij)
1056             rij=1.0D0/r_inv_ij
1057             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1058             fac=r_shift_inv**expon
1059             e1=fac*fac*aa(itypi,itypj)
1060             e2=fac*bb(itypi,itypj)
1061             evdwij=e_augm+e1+e2
1062 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1063 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1064 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1065 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1066 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1067 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1068 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1069             evdw=evdw+evdwij
1070 C
1071 C Calculate the components of the gradient in DC and X
1072 C
1073             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1074             gg(1)=xj*fac
1075             gg(2)=yj*fac
1076             gg(3)=zj*fac
1077             do k=1,3
1078               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1079               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1080               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1081               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1082             enddo
1083 cgrad            do k=i,j-1
1084 cgrad              do l=1,3
1085 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1086 cgrad              enddo
1087 cgrad            enddo
1088           enddo      ! j
1089         enddo        ! iint
1090       enddo          ! i
1091       do i=1,nct
1092         do j=1,3
1093           gvdwc(j,i)=expon*gvdwc(j,i)
1094           gvdwx(j,i)=expon*gvdwx(j,i)
1095         enddo
1096       enddo
1097       return
1098       end
1099 C-----------------------------------------------------------------------------
1100       subroutine ebp(evdw)
1101 C
1102 C This subroutine calculates the interaction energy of nonbonded side chains
1103 C assuming the Berne-Pechukas potential of interaction.
1104 C
1105       implicit real*8 (a-h,o-z)
1106       include 'DIMENSIONS'
1107       include 'COMMON.GEO'
1108       include 'COMMON.VAR'
1109       include 'COMMON.LOCAL'
1110       include 'COMMON.CHAIN'
1111       include 'COMMON.DERIV'
1112       include 'COMMON.NAMES'
1113       include 'COMMON.INTERACT'
1114       include 'COMMON.IOUNITS'
1115       include 'COMMON.CALC'
1116       common /srutu/ icall
1117 c     double precision rrsave(maxdim)
1118       logical lprn
1119       evdw=0.0D0
1120 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1121       evdw=0.0D0
1122 c     if (icall.eq.0) then
1123 c       lprn=.true.
1124 c     else
1125         lprn=.false.
1126 c     endif
1127       ind=0
1128       do i=iatsc_s,iatsc_e
1129         itypi=itype(i)
1130         itypi1=itype(i+1)
1131         xi=c(1,nres+i)
1132         yi=c(2,nres+i)
1133         zi=c(3,nres+i)
1134         dxi=dc_norm(1,nres+i)
1135         dyi=dc_norm(2,nres+i)
1136         dzi=dc_norm(3,nres+i)
1137 c        dsci_inv=dsc_inv(itypi)
1138         dsci_inv=vbld_inv(i+nres)
1139 C
1140 C Calculate SC interaction energy.
1141 C
1142         do iint=1,nint_gr(i)
1143           do j=istart(i,iint),iend(i,iint)
1144             ind=ind+1
1145             itypj=itype(j)
1146 c            dscj_inv=dsc_inv(itypj)
1147             dscj_inv=vbld_inv(j+nres)
1148             chi1=chi(itypi,itypj)
1149             chi2=chi(itypj,itypi)
1150             chi12=chi1*chi2
1151             chip1=chip(itypi)
1152             chip2=chip(itypj)
1153             chip12=chip1*chip2
1154             alf1=alp(itypi)
1155             alf2=alp(itypj)
1156             alf12=0.5D0*(alf1+alf2)
1157 C For diagnostics only!!!
1158 c           chi1=0.0D0
1159 c           chi2=0.0D0
1160 c           chi12=0.0D0
1161 c           chip1=0.0D0
1162 c           chip2=0.0D0
1163 c           chip12=0.0D0
1164 c           alf1=0.0D0
1165 c           alf2=0.0D0
1166 c           alf12=0.0D0
1167             xj=c(1,nres+j)-xi
1168             yj=c(2,nres+j)-yi
1169             zj=c(3,nres+j)-zi
1170             dxj=dc_norm(1,nres+j)
1171             dyj=dc_norm(2,nres+j)
1172             dzj=dc_norm(3,nres+j)
1173             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1174 cd          if (icall.eq.0) then
1175 cd            rrsave(ind)=rrij
1176 cd          else
1177 cd            rrij=rrsave(ind)
1178 cd          endif
1179             rij=dsqrt(rrij)
1180 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1181             call sc_angular
1182 C Calculate whole angle-dependent part of epsilon and contributions
1183 C to its derivatives
1184             fac=(rrij*sigsq)**expon2
1185             e1=fac*fac*aa(itypi,itypj)
1186             e2=fac*bb(itypi,itypj)
1187             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1188             eps2der=evdwij*eps3rt
1189             eps3der=evdwij*eps2rt
1190             evdwij=evdwij*eps2rt*eps3rt
1191             evdw=evdw+evdwij
1192             if (lprn) then
1193             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1194             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1195 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1196 cd     &        restyp(itypi),i,restyp(itypj),j,
1197 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1198 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1199 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1200 cd     &        evdwij
1201             endif
1202 C Calculate gradient components.
1203             e1=e1*eps1*eps2rt**2*eps3rt**2
1204             fac=-expon*(e1+evdwij)
1205             sigder=fac/sigsq
1206             fac=rrij*fac
1207 C Calculate radial part of the gradient
1208             gg(1)=xj*fac
1209             gg(2)=yj*fac
1210             gg(3)=zj*fac
1211 C Calculate the angular part of the gradient and sum add the contributions
1212 C to the appropriate components of the Cartesian gradient.
1213             call sc_grad
1214           enddo      ! j
1215         enddo        ! iint
1216       enddo          ! i
1217 c     stop
1218       return
1219       end
1220 C-----------------------------------------------------------------------------
1221       subroutine egb(evdw)
1222 C
1223 C This subroutine calculates the interaction energy of nonbonded side chains
1224 C assuming the Gay-Berne potential of interaction.
1225 C
1226       implicit real*8 (a-h,o-z)
1227       include 'DIMENSIONS'
1228       include 'COMMON.GEO'
1229       include 'COMMON.VAR'
1230       include 'COMMON.LOCAL'
1231       include 'COMMON.CHAIN'
1232       include 'COMMON.DERIV'
1233       include 'COMMON.NAMES'
1234       include 'COMMON.INTERACT'
1235       include 'COMMON.IOUNITS'
1236       include 'COMMON.CALC'
1237       include 'COMMON.CONTROL'
1238       logical lprn
1239       evdw=0.0D0
1240 ccccc      energy_dec=.false.
1241 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1242       evdw=0.0D0
1243       lprn=.false.
1244 c     if (icall.eq.0) lprn=.false.
1245       ind=0
1246       do i=iatsc_s,iatsc_e
1247         itypi=itype(i)
1248         itypi1=itype(i+1)
1249         xi=c(1,nres+i)
1250         yi=c(2,nres+i)
1251         zi=c(3,nres+i)
1252         dxi=dc_norm(1,nres+i)
1253         dyi=dc_norm(2,nres+i)
1254         dzi=dc_norm(3,nres+i)
1255 c        dsci_inv=dsc_inv(itypi)
1256         dsci_inv=vbld_inv(i+nres)
1257 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1258 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1259 C
1260 C Calculate SC interaction energy.
1261 C
1262         do iint=1,nint_gr(i)
1263           do j=istart(i,iint),iend(i,iint)
1264             ind=ind+1
1265             itypj=itype(j)
1266 c            dscj_inv=dsc_inv(itypj)
1267             dscj_inv=vbld_inv(j+nres)
1268 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1269 c     &       1.0d0/vbld(j+nres)
1270 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1271             sig0ij=sigma(itypi,itypj)
1272             chi1=chi(itypi,itypj)
1273             chi2=chi(itypj,itypi)
1274             chi12=chi1*chi2
1275             chip1=chip(itypi)
1276             chip2=chip(itypj)
1277             chip12=chip1*chip2
1278             alf1=alp(itypi)
1279             alf2=alp(itypj)
1280             alf12=0.5D0*(alf1+alf2)
1281 C For diagnostics only!!!
1282 c           chi1=0.0D0
1283 c           chi2=0.0D0
1284 c           chi12=0.0D0
1285 c           chip1=0.0D0
1286 c           chip2=0.0D0
1287 c           chip12=0.0D0
1288 c           alf1=0.0D0
1289 c           alf2=0.0D0
1290 c           alf12=0.0D0
1291             xj=c(1,nres+j)-xi
1292             yj=c(2,nres+j)-yi
1293             zj=c(3,nres+j)-zi
1294             dxj=dc_norm(1,nres+j)
1295             dyj=dc_norm(2,nres+j)
1296             dzj=dc_norm(3,nres+j)
1297 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1298 c            write (iout,*) "j",j," dc_norm",
1299 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1300             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1301             rij=dsqrt(rrij)
1302 C Calculate angle-dependent terms of energy and contributions to their
1303 C derivatives.
1304             call sc_angular
1305             sigsq=1.0D0/sigsq
1306             sig=sig0ij*dsqrt(sigsq)
1307             rij_shift=1.0D0/rij-sig+sig0ij
1308 c for diagnostics; uncomment
1309 c            rij_shift=1.2*sig0ij
1310 C I hate to put IF's in the loops, but here don't have another choice!!!!
1311             if (rij_shift.le.0.0D0) then
1312               evdw=1.0D20
1313 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1314 cd     &        restyp(itypi),i,restyp(itypj),j,
1315 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1316               return
1317             endif
1318             sigder=-sig*sigsq
1319 c---------------------------------------------------------------
1320             rij_shift=1.0D0/rij_shift
1321             fac=rij_shift**expon
1322             e1=fac*fac*aa(itypi,itypj)
1323             e2=fac*bb(itypi,itypj)
1324             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1325             eps2der=evdwij*eps3rt
1326             eps3der=evdwij*eps2rt
1327 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1328 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1329             evdwij=evdwij*eps2rt*eps3rt
1330             evdw=evdw+evdwij
1331             if (lprn) then
1332             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1333             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1334             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1335      &        restyp(itypi),i,restyp(itypj),j,
1336      &        epsi,sigm,chi1,chi2,chip1,chip2,
1337      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1338      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1339      &        evdwij
1340             endif
1341
1342             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1343      &                        'evdw',i,j,evdwij
1344
1345 C Calculate gradient components.
1346             e1=e1*eps1*eps2rt**2*eps3rt**2
1347             fac=-expon*(e1+evdwij)*rij_shift
1348             sigder=fac*sigder
1349             fac=rij*fac
1350 c            fac=0.0d0
1351 C Calculate the radial part of the gradient
1352             gg(1)=xj*fac
1353             gg(2)=yj*fac
1354             gg(3)=zj*fac
1355 C Calculate angular part of the gradient.
1356             call sc_grad
1357           enddo      ! j
1358         enddo        ! iint
1359       enddo          ! i
1360 c      write (iout,*) "Number of loop steps in EGB:",ind
1361 cccc      energy_dec=.false.
1362       return
1363       end
1364 C-----------------------------------------------------------------------------
1365       subroutine egbv(evdw)
1366 C
1367 C This subroutine calculates the interaction energy of nonbonded side chains
1368 C assuming the Gay-Berne-Vorobjev potential of interaction.
1369 C
1370       implicit real*8 (a-h,o-z)
1371       include 'DIMENSIONS'
1372       include 'COMMON.GEO'
1373       include 'COMMON.VAR'
1374       include 'COMMON.LOCAL'
1375       include 'COMMON.CHAIN'
1376       include 'COMMON.DERIV'
1377       include 'COMMON.NAMES'
1378       include 'COMMON.INTERACT'
1379       include 'COMMON.IOUNITS'
1380       include 'COMMON.CALC'
1381       common /srutu/ icall
1382       logical lprn
1383       evdw=0.0D0
1384 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1385       evdw=0.0D0
1386       lprn=.false.
1387 c     if (icall.eq.0) lprn=.true.
1388       ind=0
1389       do i=iatsc_s,iatsc_e
1390         itypi=itype(i)
1391         itypi1=itype(i+1)
1392         xi=c(1,nres+i)
1393         yi=c(2,nres+i)
1394         zi=c(3,nres+i)
1395         dxi=dc_norm(1,nres+i)
1396         dyi=dc_norm(2,nres+i)
1397         dzi=dc_norm(3,nres+i)
1398 c        dsci_inv=dsc_inv(itypi)
1399         dsci_inv=vbld_inv(i+nres)
1400 C
1401 C Calculate SC interaction energy.
1402 C
1403         do iint=1,nint_gr(i)
1404           do j=istart(i,iint),iend(i,iint)
1405             ind=ind+1
1406             itypj=itype(j)
1407 c            dscj_inv=dsc_inv(itypj)
1408             dscj_inv=vbld_inv(j+nres)
1409             sig0ij=sigma(itypi,itypj)
1410             r0ij=r0(itypi,itypj)
1411             chi1=chi(itypi,itypj)
1412             chi2=chi(itypj,itypi)
1413             chi12=chi1*chi2
1414             chip1=chip(itypi)
1415             chip2=chip(itypj)
1416             chip12=chip1*chip2
1417             alf1=alp(itypi)
1418             alf2=alp(itypj)
1419             alf12=0.5D0*(alf1+alf2)
1420 C For diagnostics only!!!
1421 c           chi1=0.0D0
1422 c           chi2=0.0D0
1423 c           chi12=0.0D0
1424 c           chip1=0.0D0
1425 c           chip2=0.0D0
1426 c           chip12=0.0D0
1427 c           alf1=0.0D0
1428 c           alf2=0.0D0
1429 c           alf12=0.0D0
1430             xj=c(1,nres+j)-xi
1431             yj=c(2,nres+j)-yi
1432             zj=c(3,nres+j)-zi
1433             dxj=dc_norm(1,nres+j)
1434             dyj=dc_norm(2,nres+j)
1435             dzj=dc_norm(3,nres+j)
1436             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1437             rij=dsqrt(rrij)
1438 C Calculate angle-dependent terms of energy and contributions to their
1439 C derivatives.
1440             call sc_angular
1441             sigsq=1.0D0/sigsq
1442             sig=sig0ij*dsqrt(sigsq)
1443             rij_shift=1.0D0/rij-sig+r0ij
1444 C I hate to put IF's in the loops, but here don't have another choice!!!!
1445             if (rij_shift.le.0.0D0) then
1446               evdw=1.0D20
1447               return
1448             endif
1449             sigder=-sig*sigsq
1450 c---------------------------------------------------------------
1451             rij_shift=1.0D0/rij_shift
1452             fac=rij_shift**expon
1453             e1=fac*fac*aa(itypi,itypj)
1454             e2=fac*bb(itypi,itypj)
1455             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1456             eps2der=evdwij*eps3rt
1457             eps3der=evdwij*eps2rt
1458             fac_augm=rrij**expon
1459             e_augm=augm(itypi,itypj)*fac_augm
1460             evdwij=evdwij*eps2rt*eps3rt
1461             evdw=evdw+evdwij+e_augm
1462             if (lprn) then
1463             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1464             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1465             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1466      &        restyp(itypi),i,restyp(itypj),j,
1467      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1468      &        chi1,chi2,chip1,chip2,
1469      &        eps1,eps2rt**2,eps3rt**2,
1470      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1471      &        evdwij+e_augm
1472             endif
1473 C Calculate gradient components.
1474             e1=e1*eps1*eps2rt**2*eps3rt**2
1475             fac=-expon*(e1+evdwij)*rij_shift
1476             sigder=fac*sigder
1477             fac=rij*fac-2*expon*rrij*e_augm
1478 C Calculate the radial part of the gradient
1479             gg(1)=xj*fac
1480             gg(2)=yj*fac
1481             gg(3)=zj*fac
1482 C Calculate angular part of the gradient.
1483             call sc_grad
1484           enddo      ! j
1485         enddo        ! iint
1486       enddo          ! i
1487       end
1488 C-----------------------------------------------------------------------------
1489       subroutine sc_angular
1490 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1491 C om12. Called by ebp, egb, and egbv.
1492       implicit none
1493       include 'COMMON.CALC'
1494       include 'COMMON.IOUNITS'
1495       erij(1)=xj*rij
1496       erij(2)=yj*rij
1497       erij(3)=zj*rij
1498       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1499       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1500       om12=dxi*dxj+dyi*dyj+dzi*dzj
1501       chiom12=chi12*om12
1502 C Calculate eps1(om12) and its derivative in om12
1503       faceps1=1.0D0-om12*chiom12
1504       faceps1_inv=1.0D0/faceps1
1505       eps1=dsqrt(faceps1_inv)
1506 C Following variable is eps1*deps1/dom12
1507       eps1_om12=faceps1_inv*chiom12
1508 c diagnostics only
1509 c      faceps1_inv=om12
1510 c      eps1=om12
1511 c      eps1_om12=1.0d0
1512 c      write (iout,*) "om12",om12," eps1",eps1
1513 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1514 C and om12.
1515       om1om2=om1*om2
1516       chiom1=chi1*om1
1517       chiom2=chi2*om2
1518       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1519       sigsq=1.0D0-facsig*faceps1_inv
1520       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1521       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1522       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1523 c diagnostics only
1524 c      sigsq=1.0d0
1525 c      sigsq_om1=0.0d0
1526 c      sigsq_om2=0.0d0
1527 c      sigsq_om12=0.0d0
1528 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1529 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1530 c     &    " eps1",eps1
1531 C Calculate eps2 and its derivatives in om1, om2, and om12.
1532       chipom1=chip1*om1
1533       chipom2=chip2*om2
1534       chipom12=chip12*om12
1535       facp=1.0D0-om12*chipom12
1536       facp_inv=1.0D0/facp
1537       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1538 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1539 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1540 C Following variable is the square root of eps2
1541       eps2rt=1.0D0-facp1*facp_inv
1542 C Following three variables are the derivatives of the square root of eps
1543 C in om1, om2, and om12.
1544       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1545       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1546       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1547 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1548       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1549 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1550 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1551 c     &  " eps2rt_om12",eps2rt_om12
1552 C Calculate whole angle-dependent part of epsilon and contributions
1553 C to its derivatives
1554       return
1555       end
1556 C----------------------------------------------------------------------------
1557       subroutine sc_grad
1558       implicit real*8 (a-h,o-z)
1559       include 'DIMENSIONS'
1560       include 'COMMON.CHAIN'
1561       include 'COMMON.DERIV'
1562       include 'COMMON.CALC'
1563       include 'COMMON.IOUNITS'
1564       double precision dcosom1(3),dcosom2(3)
1565       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1566       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1567       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1568      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1569 c diagnostics only
1570 c      eom1=0.0d0
1571 c      eom2=0.0d0
1572 c      eom12=evdwij*eps1_om12
1573 c end diagnostics
1574 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1575 c     &  " sigder",sigder
1576 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1577 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1578       do k=1,3
1579         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1580         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1581       enddo
1582       do k=1,3
1583         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1584       enddo
1585 c      write (iout,*) "gg",(gg(k),k=1,3)
1586       do k=1,3
1587         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1588      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1589      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1590         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1591      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1592      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1593 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1594 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1595 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1596 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1597       enddo
1598 C
1599 C Calculate the components of the gradient in DC and X
1600 C
1601 cgrad      do k=i,j-1
1602 cgrad        do l=1,3
1603 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1604 cgrad        enddo
1605 cgrad      enddo
1606       do l=1,3
1607         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1608         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1609       enddo
1610       return
1611       end
1612 C-----------------------------------------------------------------------
1613       subroutine e_softsphere(evdw)
1614 C
1615 C This subroutine calculates the interaction energy of nonbonded side chains
1616 C assuming the LJ potential of interaction.
1617 C
1618       implicit real*8 (a-h,o-z)
1619       include 'DIMENSIONS'
1620       parameter (accur=1.0d-10)
1621       include 'COMMON.GEO'
1622       include 'COMMON.VAR'
1623       include 'COMMON.LOCAL'
1624       include 'COMMON.CHAIN'
1625       include 'COMMON.DERIV'
1626       include 'COMMON.INTERACT'
1627       include 'COMMON.TORSION'
1628       include 'COMMON.SBRIDGE'
1629       include 'COMMON.NAMES'
1630       include 'COMMON.IOUNITS'
1631       include 'COMMON.CONTACTS'
1632       dimension gg(3)
1633 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1634       evdw=0.0D0
1635       do i=iatsc_s,iatsc_e
1636         itypi=itype(i)
1637         itypi1=itype(i+1)
1638         xi=c(1,nres+i)
1639         yi=c(2,nres+i)
1640         zi=c(3,nres+i)
1641 C
1642 C Calculate SC interaction energy.
1643 C
1644         do iint=1,nint_gr(i)
1645 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1646 cd   &                  'iend=',iend(i,iint)
1647           do j=istart(i,iint),iend(i,iint)
1648             itypj=itype(j)
1649             xj=c(1,nres+j)-xi
1650             yj=c(2,nres+j)-yi
1651             zj=c(3,nres+j)-zi
1652             rij=xj*xj+yj*yj+zj*zj
1653 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1654             r0ij=r0(itypi,itypj)
1655             r0ijsq=r0ij*r0ij
1656 c            print *,i,j,r0ij,dsqrt(rij)
1657             if (rij.lt.r0ijsq) then
1658               evdwij=0.25d0*(rij-r0ijsq)**2
1659               fac=rij-r0ijsq
1660             else
1661               evdwij=0.0d0
1662               fac=0.0d0
1663             endif
1664             evdw=evdw+evdwij
1665 C
1666 C Calculate the components of the gradient in DC and X
1667 C
1668             gg(1)=xj*fac
1669             gg(2)=yj*fac
1670             gg(3)=zj*fac
1671             do k=1,3
1672               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1673               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1674               gvdwc(k,i)=gvdwc(l,k)-gg(k)
1675               gvdwc(k,j)=gvdwc(l,k)+gg(k)
1676             enddo
1677 cgrad            do k=i,j-1
1678 cgrad              do l=1,3
1679 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1680 cgrad              enddo
1681 cgrad            enddo
1682           enddo ! j
1683         enddo ! iint
1684       enddo ! i
1685       return
1686       end
1687 C--------------------------------------------------------------------------
1688       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1689      &              eello_turn4)
1690 C
1691 C Soft-sphere potential of p-p interaction
1692 C
1693       implicit real*8 (a-h,o-z)
1694       include 'DIMENSIONS'
1695       include 'COMMON.CONTROL'
1696       include 'COMMON.IOUNITS'
1697       include 'COMMON.GEO'
1698       include 'COMMON.VAR'
1699       include 'COMMON.LOCAL'
1700       include 'COMMON.CHAIN'
1701       include 'COMMON.DERIV'
1702       include 'COMMON.INTERACT'
1703       include 'COMMON.CONTACTS'
1704       include 'COMMON.TORSION'
1705       include 'COMMON.VECTORS'
1706       include 'COMMON.FFIELD'
1707       dimension ggg(3)
1708 cd      write(iout,*) 'In EELEC_soft_sphere'
1709       ees=0.0D0
1710       evdw1=0.0D0
1711       eel_loc=0.0d0
1712       eello_turn3=0.0d0
1713       eello_turn4=0.0d0
1714       ind=0
1715       do i=iatel_s,iatel_e
1716         dxi=dc(1,i)
1717         dyi=dc(2,i)
1718         dzi=dc(3,i)
1719         xmedi=c(1,i)+0.5d0*dxi
1720         ymedi=c(2,i)+0.5d0*dyi
1721         zmedi=c(3,i)+0.5d0*dzi
1722         num_conti=0
1723 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1724         do j=ielstart(i),ielend(i)
1725           ind=ind+1
1726           iteli=itel(i)
1727           itelj=itel(j)
1728           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1729           r0ij=rpp(iteli,itelj)
1730           r0ijsq=r0ij*r0ij
1731           dxj=dc(1,j)
1732           dyj=dc(2,j)
1733           dzj=dc(3,j)
1734           xj=c(1,j)+0.5D0*dxj-xmedi
1735           yj=c(2,j)+0.5D0*dyj-ymedi
1736           zj=c(3,j)+0.5D0*dzj-zmedi
1737           rij=xj*xj+yj*yj+zj*zj
1738           if (rij.lt.r0ijsq) then
1739             evdw1ij=0.25d0*(rij-r0ijsq)**2
1740             fac=rij-r0ijsq
1741           else
1742             evdw1ij=0.0d0
1743             fac=0.0d0
1744           endif
1745           evdw1=evdw1+evdw1ij
1746 C
1747 C Calculate contributions to the Cartesian gradient.
1748 C
1749           ggg(1)=fac*xj
1750           ggg(2)=fac*yj
1751           ggg(3)=fac*zj
1752           do k=1,3
1753             gelc(k,i)=gelc(k,i)-ggg(k)
1754             gelc(k,j)=gelc(k,j)+ggg(k)
1755           enddo
1756 *
1757 * Loop over residues i+1 thru j-1.
1758 *
1759 cgrad          do k=i+1,j-1
1760 cgrad            do l=1,3
1761 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1762 cgrad            enddo
1763 cgrad          enddo
1764         enddo ! j
1765       enddo   ! i
1766       do i=nnt,nct-1
1767         do k=1,3
1768           gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1769         enddo
1770         do j=i+1,nct-1
1771           do k=1,3
1772             gelc(k,i)=gelc(k,i)+gelc(k,j)
1773           enddo
1774         enddo
1775       enddo
1776       return
1777       end
1778 c------------------------------------------------------------------------------
1779       subroutine vec_and_deriv
1780       implicit real*8 (a-h,o-z)
1781       include 'DIMENSIONS'
1782 #ifdef MPI
1783       include 'mpif.h'
1784 #endif
1785       include 'COMMON.IOUNITS'
1786       include 'COMMON.GEO'
1787       include 'COMMON.VAR'
1788       include 'COMMON.LOCAL'
1789       include 'COMMON.CHAIN'
1790       include 'COMMON.VECTORS'
1791       include 'COMMON.SETUP'
1792       include 'COMMON.TIME1'
1793       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1794 C Compute the local reference systems. For reference system (i), the
1795 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1796 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1797 #ifdef PARVEC
1798       do i=ivec_start,ivec_end
1799 #else
1800       do i=1,nres-1
1801 #endif
1802           if (i.eq.nres-1) then
1803 C Case of the last full residue
1804 C Compute the Z-axis
1805             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1806             costh=dcos(pi-theta(nres))
1807             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1808             do k=1,3
1809               uz(k,i)=fac*uz(k,i)
1810             enddo
1811 C Compute the derivatives of uz
1812             uzder(1,1,1)= 0.0d0
1813             uzder(2,1,1)=-dc_norm(3,i-1)
1814             uzder(3,1,1)= dc_norm(2,i-1)
1815             uzder(1,2,1)= dc_norm(3,i-1)
1816             uzder(2,2,1)= 0.0d0
1817             uzder(3,2,1)=-dc_norm(1,i-1)
1818             uzder(1,3,1)=-dc_norm(2,i-1)
1819             uzder(2,3,1)= dc_norm(1,i-1)
1820             uzder(3,3,1)= 0.0d0
1821             uzder(1,1,2)= 0.0d0
1822             uzder(2,1,2)= dc_norm(3,i)
1823             uzder(3,1,2)=-dc_norm(2,i)
1824             uzder(1,2,2)=-dc_norm(3,i)
1825             uzder(2,2,2)= 0.0d0
1826             uzder(3,2,2)= dc_norm(1,i)
1827             uzder(1,3,2)= dc_norm(2,i)
1828             uzder(2,3,2)=-dc_norm(1,i)
1829             uzder(3,3,2)= 0.0d0
1830 C Compute the Y-axis
1831             facy=fac
1832             do k=1,3
1833               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1834             enddo
1835 C Compute the derivatives of uy
1836             do j=1,3
1837               do k=1,3
1838                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1839      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1840                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1841               enddo
1842               uyder(j,j,1)=uyder(j,j,1)-costh
1843               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1844             enddo
1845             do j=1,2
1846               do k=1,3
1847                 do l=1,3
1848                   uygrad(l,k,j,i)=uyder(l,k,j)
1849                   uzgrad(l,k,j,i)=uzder(l,k,j)
1850                 enddo
1851               enddo
1852             enddo
1853             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1854             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1855             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1856             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1857           else
1858 C Other residues
1859 C Compute the Z-axis
1860             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1861             costh=dcos(pi-theta(i+2))
1862             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1863             do k=1,3
1864               uz(k,i)=fac*uz(k,i)
1865             enddo
1866 C Compute the derivatives of uz
1867             uzder(1,1,1)= 0.0d0
1868             uzder(2,1,1)=-dc_norm(3,i+1)
1869             uzder(3,1,1)= dc_norm(2,i+1)
1870             uzder(1,2,1)= dc_norm(3,i+1)
1871             uzder(2,2,1)= 0.0d0
1872             uzder(3,2,1)=-dc_norm(1,i+1)
1873             uzder(1,3,1)=-dc_norm(2,i+1)
1874             uzder(2,3,1)= dc_norm(1,i+1)
1875             uzder(3,3,1)= 0.0d0
1876             uzder(1,1,2)= 0.0d0
1877             uzder(2,1,2)= dc_norm(3,i)
1878             uzder(3,1,2)=-dc_norm(2,i)
1879             uzder(1,2,2)=-dc_norm(3,i)
1880             uzder(2,2,2)= 0.0d0
1881             uzder(3,2,2)= dc_norm(1,i)
1882             uzder(1,3,2)= dc_norm(2,i)
1883             uzder(2,3,2)=-dc_norm(1,i)
1884             uzder(3,3,2)= 0.0d0
1885 C Compute the Y-axis
1886             facy=fac
1887             do k=1,3
1888               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1889             enddo
1890 C Compute the derivatives of uy
1891             do j=1,3
1892               do k=1,3
1893                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1894      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1895                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1896               enddo
1897               uyder(j,j,1)=uyder(j,j,1)-costh
1898               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1899             enddo
1900             do j=1,2
1901               do k=1,3
1902                 do l=1,3
1903                   uygrad(l,k,j,i)=uyder(l,k,j)
1904                   uzgrad(l,k,j,i)=uzder(l,k,j)
1905                 enddo
1906               enddo
1907             enddo
1908             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1909             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1910             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1911             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1912           endif
1913       enddo
1914       do i=1,nres-1
1915         vbld_inv_temp(1)=vbld_inv(i+1)
1916         if (i.lt.nres-1) then
1917           vbld_inv_temp(2)=vbld_inv(i+2)
1918           else
1919           vbld_inv_temp(2)=vbld_inv(i)
1920           endif
1921         do j=1,2
1922           do k=1,3
1923             do l=1,3
1924               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1925               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1926             enddo
1927           enddo
1928         enddo
1929       enddo
1930 #if defined(PARVEC) && defined(MPI)
1931       if (nfgtasks.gt.1) then
1932         time00=MPI_Wtime()
1933 c        print *,"Processor",fg_rank,kolor," ivec_start",ivec_start,
1934 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
1935 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
1936         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank),
1937      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1938      &   FG_COMM,IERR)
1939         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank),
1940      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1941      &   FG_COMM,IERR)
1942         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
1943      &   ivec_count(fg_rank),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
1944      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1945         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
1946      &   ivec_count(fg_rank),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
1947      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1948         time_gather=time_gather+MPI_Wtime()-time00
1949       endif
1950 c      if (fg_rank.eq.0) then
1951 c        write (iout,*) "Arrays UY and UZ"
1952 c        do i=1,nres-1
1953 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1954 c     &     (uz(k,i),k=1,3)
1955 c        enddo
1956 c      endif
1957 #endif
1958       return
1959       end
1960 C-----------------------------------------------------------------------------
1961       subroutine check_vecgrad
1962       implicit real*8 (a-h,o-z)
1963       include 'DIMENSIONS'
1964       include 'COMMON.IOUNITS'
1965       include 'COMMON.GEO'
1966       include 'COMMON.VAR'
1967       include 'COMMON.LOCAL'
1968       include 'COMMON.CHAIN'
1969       include 'COMMON.VECTORS'
1970       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1971       dimension uyt(3,maxres),uzt(3,maxres)
1972       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1973       double precision delta /1.0d-7/
1974       call vec_and_deriv
1975 cd      do i=1,nres
1976 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1977 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1978 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1979 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1980 cd     &     (dc_norm(if90,i),if90=1,3)
1981 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1982 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1983 cd          write(iout,'(a)')
1984 cd      enddo
1985       do i=1,nres
1986         do j=1,2
1987           do k=1,3
1988             do l=1,3
1989               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1990               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1991             enddo
1992           enddo
1993         enddo
1994       enddo
1995       call vec_and_deriv
1996       do i=1,nres
1997         do j=1,3
1998           uyt(j,i)=uy(j,i)
1999           uzt(j,i)=uz(j,i)
2000         enddo
2001       enddo
2002       do i=1,nres
2003 cd        write (iout,*) 'i=',i
2004         do k=1,3
2005           erij(k)=dc_norm(k,i)
2006         enddo
2007         do j=1,3
2008           do k=1,3
2009             dc_norm(k,i)=erij(k)
2010           enddo
2011           dc_norm(j,i)=dc_norm(j,i)+delta
2012 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2013 c          do k=1,3
2014 c            dc_norm(k,i)=dc_norm(k,i)/fac
2015 c          enddo
2016 c          write (iout,*) (dc_norm(k,i),k=1,3)
2017 c          write (iout,*) (erij(k),k=1,3)
2018           call vec_and_deriv
2019           do k=1,3
2020             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2021             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2022             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2023             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2024           enddo
2025 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2026 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2027 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2028         enddo
2029         do k=1,3
2030           dc_norm(k,i)=erij(k)
2031         enddo
2032 cd        do k=1,3
2033 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2034 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2035 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2036 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2037 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2038 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2039 cd          write (iout,'(a)')
2040 cd        enddo
2041       enddo
2042       return
2043       end
2044 C--------------------------------------------------------------------------
2045       subroutine set_matrices
2046       implicit real*8 (a-h,o-z)
2047       include 'DIMENSIONS'
2048 #ifdef MPI
2049       include "mpif.h"
2050       include "COMMON.SETUP"
2051       integer IERR
2052       integer status(MPI_STATUS_SIZE)
2053 #endif
2054       include 'COMMON.IOUNITS'
2055       include 'COMMON.GEO'
2056       include 'COMMON.VAR'
2057       include 'COMMON.LOCAL'
2058       include 'COMMON.CHAIN'
2059       include 'COMMON.DERIV'
2060       include 'COMMON.INTERACT'
2061       include 'COMMON.CONTACTS'
2062       include 'COMMON.TORSION'
2063       include 'COMMON.VECTORS'
2064       include 'COMMON.FFIELD'
2065       double precision auxvec(2),auxmat(2,2)
2066 C
2067 C Compute the virtual-bond-torsional-angle dependent quantities needed
2068 C to calculate the el-loc multibody terms of various order.
2069 C
2070 #ifdef PARMAT
2071       do i=ivec_start+2,ivec_end+2
2072 #else
2073       do i=3,nres+1
2074 #endif
2075         if (i .lt. nres+1) then
2076           sin1=dsin(phi(i))
2077           cos1=dcos(phi(i))
2078           sintab(i-2)=sin1
2079           costab(i-2)=cos1
2080           obrot(1,i-2)=cos1
2081           obrot(2,i-2)=sin1
2082           sin2=dsin(2*phi(i))
2083           cos2=dcos(2*phi(i))
2084           sintab2(i-2)=sin2
2085           costab2(i-2)=cos2
2086           obrot2(1,i-2)=cos2
2087           obrot2(2,i-2)=sin2
2088           Ug(1,1,i-2)=-cos1
2089           Ug(1,2,i-2)=-sin1
2090           Ug(2,1,i-2)=-sin1
2091           Ug(2,2,i-2)= cos1
2092           Ug2(1,1,i-2)=-cos2
2093           Ug2(1,2,i-2)=-sin2
2094           Ug2(2,1,i-2)=-sin2
2095           Ug2(2,2,i-2)= cos2
2096         else
2097           costab(i-2)=1.0d0
2098           sintab(i-2)=0.0d0
2099           obrot(1,i-2)=1.0d0
2100           obrot(2,i-2)=0.0d0
2101           obrot2(1,i-2)=0.0d0
2102           obrot2(2,i-2)=0.0d0
2103           Ug(1,1,i-2)=1.0d0
2104           Ug(1,2,i-2)=0.0d0
2105           Ug(2,1,i-2)=0.0d0
2106           Ug(2,2,i-2)=1.0d0
2107           Ug2(1,1,i-2)=0.0d0
2108           Ug2(1,2,i-2)=0.0d0
2109           Ug2(2,1,i-2)=0.0d0
2110           Ug2(2,2,i-2)=0.0d0
2111         endif
2112         if (i .gt. 3 .and. i .lt. nres+1) then
2113           obrot_der(1,i-2)=-sin1
2114           obrot_der(2,i-2)= cos1
2115           Ugder(1,1,i-2)= sin1
2116           Ugder(1,2,i-2)=-cos1
2117           Ugder(2,1,i-2)=-cos1
2118           Ugder(2,2,i-2)=-sin1
2119           dwacos2=cos2+cos2
2120           dwasin2=sin2+sin2
2121           obrot2_der(1,i-2)=-dwasin2
2122           obrot2_der(2,i-2)= dwacos2
2123           Ug2der(1,1,i-2)= dwasin2
2124           Ug2der(1,2,i-2)=-dwacos2
2125           Ug2der(2,1,i-2)=-dwacos2
2126           Ug2der(2,2,i-2)=-dwasin2
2127         else
2128           obrot_der(1,i-2)=0.0d0
2129           obrot_der(2,i-2)=0.0d0
2130           Ugder(1,1,i-2)=0.0d0
2131           Ugder(1,2,i-2)=0.0d0
2132           Ugder(2,1,i-2)=0.0d0
2133           Ugder(2,2,i-2)=0.0d0
2134           obrot2_der(1,i-2)=0.0d0
2135           obrot2_der(2,i-2)=0.0d0
2136           Ug2der(1,1,i-2)=0.0d0
2137           Ug2der(1,2,i-2)=0.0d0
2138           Ug2der(2,1,i-2)=0.0d0
2139           Ug2der(2,2,i-2)=0.0d0
2140         endif
2141 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2142         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2143           iti = itortyp(itype(i-2))
2144         else
2145           iti=ntortyp+1
2146         endif
2147 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2148         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2149           iti1 = itortyp(itype(i-1))
2150         else
2151           iti1=ntortyp+1
2152         endif
2153 cd        write (iout,*) '*******i',i,' iti1',iti
2154 cd        write (iout,*) 'b1',b1(:,iti)
2155 cd        write (iout,*) 'b2',b2(:,iti)
2156 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2157 c        if (i .gt. iatel_s+2) then
2158         if (i .gt. nnt+2) then
2159           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2160           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2161           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2162      &    then
2163           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2164           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2165           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2166           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2167           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2168           endif
2169         else
2170           do k=1,2
2171             Ub2(k,i-2)=0.0d0
2172             Ctobr(k,i-2)=0.0d0
2173             Dtobr2(k,i-2)=0.0d0
2174             do l=1,2
2175               EUg(l,k,i-2)=0.0d0
2176               CUg(l,k,i-2)=0.0d0
2177               DUg(l,k,i-2)=0.0d0
2178               DtUg2(l,k,i-2)=0.0d0
2179             enddo
2180           enddo
2181         endif
2182         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2183         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2184         do k=1,2
2185           muder(k,i-2)=Ub2der(k,i-2)
2186         enddo
2187 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2188         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2189           iti1 = itortyp(itype(i-1))
2190         else
2191           iti1=ntortyp+1
2192         endif
2193         do k=1,2
2194           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2195         enddo
2196 cd        write (iout,*) 'mu ',mu(:,i-2)
2197 cd        write (iout,*) 'mu1',mu1(:,i-2)
2198 cd        write (iout,*) 'mu2',mu2(:,i-2)
2199         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2200      &  then
2201         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2202         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2203         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2204         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2205         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2206 C Vectors and matrices dependent on a single virtual-bond dihedral.
2207         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2208         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2209         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2210         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2211         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2212         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2213         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2214         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2215         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2216         endif
2217       enddo
2218 C Matrices dependent on two consecutive virtual-bond dihedrals.
2219 C The order of matrices is from left to right.
2220       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2221      &then
2222       do i=ivec_start,ivec_end
2223 c      do i=2,nres-1
2224         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2225         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2226         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2227         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2228         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2229         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2230         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2231         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2232       enddo
2233       endif
2234 #if defined(MPI) && defined(PARMAT)
2235 #ifdef DEBUG
2236 c      if (fg_rank.eq.0) then
2237         write (iout,*) "Arrays UG and UGDER before GATHER"
2238         do i=1,nres-1
2239           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2240      &     ((ug(l,k,i),l=1,2),k=1,2),
2241      &     ((ugder(l,k,i),l=1,2),k=1,2)
2242         enddo
2243         write (iout,*) "Arrays UG2 and UG2DER"
2244         do i=1,nres-1
2245           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2246      &     ((ug2(l,k,i),l=1,2),k=1,2),
2247      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2248         enddo
2249         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2250         do i=1,nres-1
2251           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2252      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2253      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2254         enddo
2255         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2256         do i=1,nres-1
2257           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2258      &     costab(i),sintab(i),costab2(i),sintab2(i)
2259         enddo
2260         write (iout,*) "Array MUDER"
2261         do i=1,nres-1
2262           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2263         enddo
2264 c      endif
2265 #endif
2266       if (nfgtasks.gt.1) then
2267         time00=MPI_Wtime()
2268 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2269 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2270 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2271 #ifdef MATGATHER
2272 c        write (iout,*) "MPI_ROTAT",MPI_ROTAT
2273 c        call MPI_Allgatherv(ug(1,1,ivec_start),ivec_count(fg_rank),
2274 c     &   MPI_MAT1,ug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2275 c     &   FG_COMM,IERR)
2276 c        call MPI_Allgatherv(ugder(1,1,ivec_start),ivec_count(fg_rank),
2277 c     &   MPI_MAT1,ugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2278 c     &   FG_COMM,IERR)
2279 c        call MPI_Allgatherv(ug2(1,1,ivec_start),ivec_count(fg_rank),
2280 c     &   MPI_MAT1,ug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2281 c     &   FG_COMM,IERR)
2282 c        call MPI_Allgatherv(ug2der(1,1,ivec_start),ivec_count(fg_rank),
2283 c     &   MPI_MAT1,ug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2284 c     &   FG_COMM,IERR)
2285 c        call MPI_Allgatherv(obrot(1,ivec_start),ivec_count(fg_rank),
2286 c     &   MPI_MU,obrot(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2287 c     &   FG_COMM,IERR)
2288 c        call MPI_Allgatherv(obrot2(1,ivec_start),ivec_count(fg_rank),
2289 c     &   MPI_MU,obrot2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2290 c     &   FG_COMM,IERR)
2291 c        call MPI_Allgatherv(obrot_der(1,ivec_start),ivec_count(fg_rank),
2292 c     &   MPI_MU,obrot_der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2293 c     &   FG_COMM,IERR)
2294 c        call MPI_Allgatherv(obrot2_der(1,ivec_start),
2295 c     &   ivec_count(fg_rank),
2296 c     &   MPI_MU,obrot2_der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2297 c     &   FG_COMM,IERR)
2298         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank),
2299      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2300      &   FG_COMM,IERR)
2301         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank),
2302      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2303      &   FG_COMM,IERR)
2304         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank),
2305      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2306      &   FG_COMM,IERR)
2307         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank),
2308      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2309      &   FG_COMM,IERR)
2310         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank),
2311      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2312      &   FG_COMM,IERR)
2313         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank),
2314      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2315      &   FG_COMM,IERR)
2316         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank),
2317      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2318      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2319         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank),
2320      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2321      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2322         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank),
2323      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2324      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2325         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank),
2326      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2327      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2328         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2329      &  then
2330         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank),
2331      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2332      &   FG_COMM,IERR)
2333         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank),
2334      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2335      &   FG_COMM,IERR)
2336         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank),
2337      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2338      &   FG_COMM,IERR)
2339         call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank),
2340      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2341      &   FG_COMM,IERR)
2342         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank),
2343      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2344      &   FG_COMM,IERR)
2345         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2346      &   ivec_count(fg_rank),
2347      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2348      &   FG_COMM,IERR)
2349         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank),
2350      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2351      &   FG_COMM,IERR)
2352         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank),
2353      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2354      &   FG_COMM,IERR)
2355         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank),
2356      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2357      &   FG_COMM,IERR)
2358         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank),
2359      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2360      &   FG_COMM,IERR)
2361         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank),
2362      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2363      &   FG_COMM,IERR)
2364         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank),
2365      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2366      &   FG_COMM,IERR)
2367         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank),
2368      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2369      &   FG_COMM,IERR)
2370         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2371      &   ivec_count(fg_rank),
2372      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2373      &   FG_COMM,IERR)
2374         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank),
2375      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2376      &   FG_COMM,IERR)
2377         call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank),
2378      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2379      &   FG_COMM,IERR)
2380         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank),
2381      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2382      &   FG_COMM,IERR)
2383         call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank),
2384      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2385      &   FG_COMM,IERR)
2386         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2387      &   ivec_count(fg_rank),
2388      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2389      &   FG_COMM,IERR)
2390         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2391      &   ivec_count(fg_rank),
2392      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2393      &   FG_COMM,IERR)
2394         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2395      &   ivec_count(fg_rank),
2396      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2397      &   MPI_MAT2,FG_COMM,IERR)
2398         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2399      &   ivec_count(fg_rank),
2400      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2401      &   MPI_MAT2,FG_COMM,IERR)
2402         endif
2403 #else
2404 c Passes matrix info through the ring
2405       isend=fg_rank
2406       irecv=fg_rank-1
2407       if (irecv.lt.0) irecv=nfgtasks-1
2408       iprev=irecv
2409       inext=fg_rank+1
2410       if (inext.ge.nfgtasks) inext=0
2411       do i=1,nfgtasks-1
2412 c        write (iout,*) "isend",isend," irecv",irecv
2413 c        call flush(iout)
2414         lensend=lentyp(isend)
2415         lenrecv=lentyp(irecv)
2416 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2417 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2418 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2419 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2420 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2421 c        write (iout,*) "Gather ROTAT1"
2422 c        call flush(iout)
2423 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2424 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2425 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2426 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2427 c        write (iout,*) "Gather ROTAT2"
2428 c        call flush(iout)
2429         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2430      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2431      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2432      &   iprev,4400+irecv,FG_COMM,status,IERR)
2433 c        write (iout,*) "Gather ROTAT_OLD"
2434 c        call flush(iout)
2435         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2436      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2437      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2438      &   iprev,5500+irecv,FG_COMM,status,IERR)
2439 c        write (iout,*) "Gather PRECOMP11"
2440 c        call flush(iout)
2441         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2442      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2443      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2444      &   iprev,6600+irecv,FG_COMM,status,IERR)
2445 c        write (iout,*) "Gather PRECOMP12"
2446 c        call flush(iout)
2447         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2448      &  then
2449         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2450      &   MPI_ROTAT2(lensend),inext,7700+isend,
2451      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2452      &   iprev,7700+irecv,FG_COMM,status,IERR)
2453 c        write (iout,*) "Gather PRECOMP21"
2454 c        call flush(iout)
2455         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2456      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2457      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2458      &   iprev,8800+irecv,FG_COMM,status,IERR)
2459 c        write (iout,*) "Gather PRECOMP22"
2460 c        call flush(iout)
2461         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2462      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2463      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2464      &   MPI_PRECOMP23(lenrecv),
2465      &   iprev,9900+irecv,FG_COMM,status,IERR)
2466 c        write (iout,*) "Gather PRECOMP23"
2467 c        call flush(iout)
2468         endif
2469         isend=irecv
2470         irecv=irecv-1
2471         if (irecv.lt.0) irecv=nfgtasks-1
2472       enddo
2473 #endif
2474         time_gather=time_gather+MPI_Wtime()-time00
2475       endif
2476 #ifdef DEBUG
2477 c      if (fg_rank.eq.0) then
2478         write (iout,*) "Arrays UG and UGDER"
2479         do i=1,nres-1
2480           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2481      &     ((ug(l,k,i),l=1,2),k=1,2),
2482      &     ((ugder(l,k,i),l=1,2),k=1,2)
2483         enddo
2484         write (iout,*) "Arrays UG2 and UG2DER"
2485         do i=1,nres-1
2486           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2487      &     ((ug2(l,k,i),l=1,2),k=1,2),
2488      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2489         enddo
2490         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2491         do i=1,nres-1
2492           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2493      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2494      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2495         enddo
2496         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2497         do i=1,nres-1
2498           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2499      &     costab(i),sintab(i),costab2(i),sintab2(i)
2500         enddo
2501         write (iout,*) "Array MUDER"
2502         do i=1,nres-1
2503           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2504         enddo
2505 c      endif
2506 #endif
2507 #endif
2508 cd      do i=1,nres
2509 cd        iti = itortyp(itype(i))
2510 cd        write (iout,*) i
2511 cd        do j=1,2
2512 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2513 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2514 cd        enddo
2515 cd      enddo
2516       return
2517       end
2518 C--------------------------------------------------------------------------
2519       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2520 C
2521 C This subroutine calculates the average interaction energy and its gradient
2522 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2523 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2524 C The potential depends both on the distance of peptide-group centers and on
2525 C the orientation of the CA-CA virtual bonds.
2526 C
2527       implicit real*8 (a-h,o-z)
2528       include 'DIMENSIONS'
2529       include 'COMMON.CONTROL'
2530       include 'COMMON.SETUP'
2531       include 'COMMON.IOUNITS'
2532       include 'COMMON.GEO'
2533       include 'COMMON.VAR'
2534       include 'COMMON.LOCAL'
2535       include 'COMMON.CHAIN'
2536       include 'COMMON.DERIV'
2537       include 'COMMON.INTERACT'
2538       include 'COMMON.CONTACTS'
2539       include 'COMMON.TORSION'
2540       include 'COMMON.VECTORS'
2541       include 'COMMON.FFIELD'
2542       include 'COMMON.TIME1'
2543       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2544      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2545       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2546      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2547       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2548      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2549      &    num_conti,j1,j2
2550 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2551 #ifdef MOMENT
2552       double precision scal_el /1.0d0/
2553 #else
2554       double precision scal_el /0.5d0/
2555 #endif
2556 C 12/13/98
2557 C 13-go grudnia roku pamietnego...
2558       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2559      &                   0.0d0,1.0d0,0.0d0,
2560      &                   0.0d0,0.0d0,1.0d0/
2561 cd      write(iout,*) 'In EELEC'
2562 cd      do i=1,nloctyp
2563 cd        write(iout,*) 'Type',i
2564 cd        write(iout,*) 'B1',B1(:,i)
2565 cd        write(iout,*) 'B2',B2(:,i)
2566 cd        write(iout,*) 'CC',CC(:,:,i)
2567 cd        write(iout,*) 'DD',DD(:,:,i)
2568 cd        write(iout,*) 'EE',EE(:,:,i)
2569 cd      enddo
2570 cd      call check_vecgrad
2571 cd      stop
2572       if (icheckgrad.eq.1) then
2573         do i=1,nres-1
2574           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2575           do k=1,3
2576             dc_norm(k,i)=dc(k,i)*fac
2577           enddo
2578 c          write (iout,*) 'i',i,' fac',fac
2579         enddo
2580       endif
2581       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2582      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2583      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2584 c        call vec_and_deriv
2585         call set_matrices
2586       endif
2587 cd      do i=1,nres-1
2588 cd        write (iout,*) 'i=',i
2589 cd        do k=1,3
2590 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2591 cd        enddo
2592 cd        do k=1,3
2593 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2594 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2595 cd        enddo
2596 cd      enddo
2597       t_eelecij=0.0d0
2598       ees=0.0D0
2599       evdw1=0.0D0
2600       eel_loc=0.0d0
2601       eello_turn3=0.0d0
2602       eello_turn4=0.0d0
2603       ind=0
2604       do i=1,nres
2605         num_cont_hb(i)=0
2606       enddo
2607 cd      print '(a)','Enter EELEC'
2608 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2609       do i=1,nres
2610         gel_loc_loc(i)=0.0d0
2611         gcorr_loc(i)=0.0d0
2612       enddo
2613 c
2614 c
2615 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2616 C
2617 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2618 C
2619       do i=iturn3_start,iturn3_end
2620         dxi=dc(1,i)
2621         dyi=dc(2,i)
2622         dzi=dc(3,i)
2623         dx_normi=dc_norm(1,i)
2624         dy_normi=dc_norm(2,i)
2625         dz_normi=dc_norm(3,i)
2626         xmedi=c(1,i)+0.5d0*dxi
2627         ymedi=c(2,i)+0.5d0*dyi
2628         zmedi=c(3,i)+0.5d0*dzi
2629         num_conti=0
2630         call eelecij(i,i+2,ees,evdw1,eel_loc)
2631         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2632         num_cont_hb(i)=num_conti
2633       enddo
2634       do i=iturn4_start,iturn4_end
2635         dxi=dc(1,i)
2636         dyi=dc(2,i)
2637         dzi=dc(3,i)
2638         dx_normi=dc_norm(1,i)
2639         dy_normi=dc_norm(2,i)
2640         dz_normi=dc_norm(3,i)
2641         xmedi=c(1,i)+0.5d0*dxi
2642         ymedi=c(2,i)+0.5d0*dyi
2643         zmedi=c(3,i)+0.5d0*dzi
2644         num_conti=0
2645         call eelecij(i,i+3,ees,evdw1,eel_loc)
2646         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
2647         num_cont_hb(i)=num_cont_hb(i)+num_conti
2648       enddo   ! i
2649 c
2650 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2651 c
2652       do i=iatel_s,iatel_e
2653         dxi=dc(1,i)
2654         dyi=dc(2,i)
2655         dzi=dc(3,i)
2656         dx_normi=dc_norm(1,i)
2657         dy_normi=dc_norm(2,i)
2658         dz_normi=dc_norm(3,i)
2659         xmedi=c(1,i)+0.5d0*dxi
2660         ymedi=c(2,i)+0.5d0*dyi
2661         zmedi=c(3,i)+0.5d0*dzi
2662         num_conti=0
2663 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2664         do j=ielstart(i),ielend(i)
2665           call eelecij(i,j,ees,evdw1,eel_loc)
2666         enddo ! j
2667         num_cont_hb(i)=num_cont_hb(i)+num_conti
2668       enddo   ! i
2669 c      write (iout,*) "Number of loop steps in EELEC:",ind
2670 cd      do i=1,nres
2671 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2672 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2673 cd      enddo
2674 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2675 ccc      eel_loc=eel_loc+eello_turn3
2676 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2677       return
2678       end
2679 C-------------------------------------------------------------------------------
2680       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2681       implicit real*8 (a-h,o-z)
2682       include 'DIMENSIONS'
2683 #ifdef MPI
2684       include "mpif.h"
2685 #endif
2686       include 'COMMON.CONTROL'
2687       include 'COMMON.IOUNITS'
2688       include 'COMMON.GEO'
2689       include 'COMMON.VAR'
2690       include 'COMMON.LOCAL'
2691       include 'COMMON.CHAIN'
2692       include 'COMMON.DERIV'
2693       include 'COMMON.INTERACT'
2694       include 'COMMON.CONTACTS'
2695       include 'COMMON.TORSION'
2696       include 'COMMON.VECTORS'
2697       include 'COMMON.FFIELD'
2698       include 'COMMON.TIME1'
2699       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2700      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2701       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2702      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2703       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2704      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2705      &    num_conti,j1,j2
2706 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2707 #ifdef MOMENT
2708       double precision scal_el /1.0d0/
2709 #else
2710       double precision scal_el /0.5d0/
2711 #endif
2712 C 12/13/98
2713 C 13-go grudnia roku pamietnego...
2714       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2715      &                   0.0d0,1.0d0,0.0d0,
2716      &                   0.0d0,0.0d0,1.0d0/
2717 c          time00=MPI_Wtime()
2718 cd      write (iout,*) "eelecij",i,j
2719           ind=ind+1
2720           iteli=itel(i)
2721           itelj=itel(j)
2722           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2723           aaa=app(iteli,itelj)
2724           bbb=bpp(iteli,itelj)
2725           ael6i=ael6(iteli,itelj)
2726           ael3i=ael3(iteli,itelj)
2727           dxj=dc(1,j)
2728           dyj=dc(2,j)
2729           dzj=dc(3,j)
2730           dx_normj=dc_norm(1,j)
2731           dy_normj=dc_norm(2,j)
2732           dz_normj=dc_norm(3,j)
2733           xj=c(1,j)+0.5D0*dxj-xmedi
2734           yj=c(2,j)+0.5D0*dyj-ymedi
2735           zj=c(3,j)+0.5D0*dzj-zmedi
2736           rij=xj*xj+yj*yj+zj*zj
2737           rrmij=1.0D0/rij
2738           rij=dsqrt(rij)
2739           rmij=1.0D0/rij
2740           r3ij=rrmij*rmij
2741           r6ij=r3ij*r3ij
2742           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2743           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2744           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2745           fac=cosa-3.0D0*cosb*cosg
2746           ev1=aaa*r6ij*r6ij
2747 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2748           if (j.eq.i+2) ev1=scal_el*ev1
2749           ev2=bbb*r6ij
2750           fac3=ael6i*r6ij
2751           fac4=ael3i*r3ij
2752           evdwij=ev1+ev2
2753           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2754           el2=fac4*fac
2755           eesij=el1+el2
2756 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2757           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2758           ees=ees+eesij
2759           evdw1=evdw1+evdwij
2760 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2761 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2762 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2763 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2764
2765           if (energy_dec) then
2766               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2767               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2768           endif
2769
2770 C
2771 C Calculate contributions to the Cartesian gradient.
2772 C
2773 #ifdef SPLITELE
2774           facvdw=-6*rrmij*(ev1+evdwij)
2775           facel=-3*rrmij*(el1+eesij)
2776           fac1=fac
2777           erij(1)=xj*rmij
2778           erij(2)=yj*rmij
2779           erij(3)=zj*rmij
2780 *
2781 * Radial derivatives. First process both termini of the fragment (i,j)
2782 *
2783           ggg(1)=facel*xj
2784           ggg(2)=facel*yj
2785           ggg(3)=facel*zj
2786 c          do k=1,3
2787 c            ghalf=0.5D0*ggg(k)
2788 c            gelc(k,i)=gelc(k,i)+ghalf
2789 c            gelc(k,j)=gelc(k,j)+ghalf
2790 c          enddo
2791 c 9/28/08 AL Gradient compotents will be summed only at the end
2792           do k=1,3
2793             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2794             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2795           enddo
2796 *
2797 * Loop over residues i+1 thru j-1.
2798 *
2799 cgrad          do k=i+1,j-1
2800 cgrad            do l=1,3
2801 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2802 cgrad            enddo
2803 cgrad          enddo
2804           ggg(1)=facvdw*xj
2805           ggg(2)=facvdw*yj
2806           ggg(3)=facvdw*zj
2807 c          do k=1,3
2808 c            ghalf=0.5D0*ggg(k)
2809 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2810 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2811 c          enddo
2812 c 9/28/08 AL Gradient compotents will be summed only at the end
2813           do k=1,3
2814             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2815             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2816           enddo
2817 *
2818 * Loop over residues i+1 thru j-1.
2819 *
2820 cgrad          do k=i+1,j-1
2821 cgrad            do l=1,3
2822 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2823 cgrad            enddo
2824 cgrad          enddo
2825 #else
2826           facvdw=ev1+evdwij
2827           facel=el1+eesij
2828           fac1=fac
2829           fac=-3*rrmij*(facvdw+facvdw+facel)
2830           erij(1)=xj*rmij
2831           erij(2)=yj*rmij
2832           erij(3)=zj*rmij
2833 *
2834 * Radial derivatives. First process both termini of the fragment (i,j)
2835 *
2836           ggg(1)=fac*xj
2837           ggg(2)=fac*yj
2838           ggg(3)=fac*zj
2839 c          do k=1,3
2840 c            ghalf=0.5D0*ggg(k)
2841 c            gelc(k,i)=gelc(k,i)+ghalf
2842 c            gelc(k,j)=gelc(k,j)+ghalf
2843 c          enddo
2844 c 9/28/08 AL Gradient compotents will be summed only at the end
2845           do k=1,3
2846             gelc_long(k,j)=gelc(k,j)+ggg(k)
2847             gelc_long(k,i)=gelc(k,i)-ggg(k)
2848           enddo
2849 *
2850 * Loop over residues i+1 thru j-1.
2851 *
2852 cgrad          do k=i+1,j-1
2853 cgrad            do l=1,3
2854 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2855 cgrad            enddo
2856 cgrad          enddo
2857 c 9/28/08 AL Gradient compotents will be summed only at the end
2858           ggg(1)=facvdw*xj
2859           ggg(2)=facvdw*yj
2860           ggg(3)=facvdw*zj
2861           do k=1,3
2862             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2863             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2864           enddo
2865 #endif
2866 *
2867 * Angular part
2868 *
2869           ecosa=2.0D0*fac3*fac1+fac4
2870           fac4=-3.0D0*fac4
2871           fac3=-6.0D0*fac3
2872           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2873           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2874           do k=1,3
2875             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2876             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2877           enddo
2878 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2879 cd   &          (dcosg(k),k=1,3)
2880           do k=1,3
2881             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2882           enddo
2883 c          do k=1,3
2884 c            ghalf=0.5D0*ggg(k)
2885 c            gelc(k,i)=gelc(k,i)+ghalf
2886 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2887 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2888 c            gelc(k,j)=gelc(k,j)+ghalf
2889 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2890 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2891 c          enddo
2892 cgrad          do k=i+1,j-1
2893 cgrad            do l=1,3
2894 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2895 cgrad            enddo
2896 cgrad          enddo
2897           do k=1,3
2898             gelc(k,i)=gelc(k,i)
2899      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2900      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2901             gelc(k,j)=gelc(k,j)
2902      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2903      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2904             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2905             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2906           enddo
2907           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2908      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2909      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2910 C
2911 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2912 C   energy of a peptide unit is assumed in the form of a second-order
2913 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2914 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2915 C   are computed for EVERY pair of non-contiguous peptide groups.
2916 C
2917           if (j.lt.nres-1) then
2918             j1=j+1
2919             j2=j-1
2920           else
2921             j1=j-1
2922             j2=j-2
2923           endif
2924           kkk=0
2925           do k=1,2
2926             do l=1,2
2927               kkk=kkk+1
2928               muij(kkk)=mu(k,i)*mu(l,j)
2929             enddo
2930           enddo
2931 cd         write (iout,*) 'EELEC: i',i,' j',j
2932 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2933 cd          write(iout,*) 'muij',muij
2934           ury=scalar(uy(1,i),erij)
2935           urz=scalar(uz(1,i),erij)
2936           vry=scalar(uy(1,j),erij)
2937           vrz=scalar(uz(1,j),erij)
2938           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2939           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2940           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2941           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2942           fac=dsqrt(-ael6i)*r3ij
2943           a22=a22*fac
2944           a23=a23*fac
2945           a32=a32*fac
2946           a33=a33*fac
2947 cd          write (iout,'(4i5,4f10.5)')
2948 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2949 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2950 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2951 cd     &      uy(:,j),uz(:,j)
2952 cd          write (iout,'(4f10.5)')
2953 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2954 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2955 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2956 cd           write (iout,'(9f10.5/)')
2957 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2958 C Derivatives of the elements of A in virtual-bond vectors
2959           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2960           do k=1,3
2961             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2962             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2963             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2964             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2965             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2966             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2967             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2968             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2969             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2970             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2971             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2972             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2973           enddo
2974 C Compute radial contributions to the gradient
2975           facr=-3.0d0*rrmij
2976           a22der=a22*facr
2977           a23der=a23*facr
2978           a32der=a32*facr
2979           a33der=a33*facr
2980           agg(1,1)=a22der*xj
2981           agg(2,1)=a22der*yj
2982           agg(3,1)=a22der*zj
2983           agg(1,2)=a23der*xj
2984           agg(2,2)=a23der*yj
2985           agg(3,2)=a23der*zj
2986           agg(1,3)=a32der*xj
2987           agg(2,3)=a32der*yj
2988           agg(3,3)=a32der*zj
2989           agg(1,4)=a33der*xj
2990           agg(2,4)=a33der*yj
2991           agg(3,4)=a33der*zj
2992 C Add the contributions coming from er
2993           fac3=-3.0d0*fac
2994           do k=1,3
2995             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2996             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2997             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2998             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2999           enddo
3000           do k=1,3
3001 C Derivatives in DC(i)
3002             ghalf1=0.5d0*agg(k,1)
3003             ghalf2=0.5d0*agg(k,2)
3004             ghalf3=0.5d0*agg(k,3)
3005             ghalf4=0.5d0*agg(k,4)
3006             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3007      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3008             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3009      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3010             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3011      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3012             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3013      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3014 C Derivatives in DC(i+1)
3015             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3016      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3017             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3018      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3019             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3020      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3021             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3022      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3023 C Derivatives in DC(j)
3024             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3025      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3026             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3027      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3028             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3029      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3030             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3031      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3032 C Derivatives in DC(j+1) or DC(nres-1)
3033             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3034      &      -3.0d0*vryg(k,3)*ury)
3035             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3036      &      -3.0d0*vrzg(k,3)*ury)
3037             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3038      &      -3.0d0*vryg(k,3)*urz)
3039             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3040      &      -3.0d0*vrzg(k,3)*urz)
3041 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3042 cgrad              do l=1,4
3043 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3044 cgrad              enddo
3045 cgrad            endif
3046           enddo
3047           acipa(1,1)=a22
3048           acipa(1,2)=a23
3049           acipa(2,1)=a32
3050           acipa(2,2)=a33
3051           a22=-a22
3052           a23=-a23
3053           do l=1,2
3054             do k=1,3
3055               agg(k,l)=-agg(k,l)
3056               aggi(k,l)=-aggi(k,l)
3057               aggi1(k,l)=-aggi1(k,l)
3058               aggj(k,l)=-aggj(k,l)
3059               aggj1(k,l)=-aggj1(k,l)
3060             enddo
3061           enddo
3062           if (j.lt.nres-1) then
3063             a22=-a22
3064             a32=-a32
3065             do l=1,3,2
3066               do k=1,3
3067                 agg(k,l)=-agg(k,l)
3068                 aggi(k,l)=-aggi(k,l)
3069                 aggi1(k,l)=-aggi1(k,l)
3070                 aggj(k,l)=-aggj(k,l)
3071                 aggj1(k,l)=-aggj1(k,l)
3072               enddo
3073             enddo
3074           else
3075             a22=-a22
3076             a23=-a23
3077             a32=-a32
3078             a33=-a33
3079             do l=1,4
3080               do k=1,3
3081                 agg(k,l)=-agg(k,l)
3082                 aggi(k,l)=-aggi(k,l)
3083                 aggi1(k,l)=-aggi1(k,l)
3084                 aggj(k,l)=-aggj(k,l)
3085                 aggj1(k,l)=-aggj1(k,l)
3086               enddo
3087             enddo
3088           endif
3089           ENDIF ! WCORR
3090           IF (wel_loc.gt.0.0d0) THEN
3091 C Contribution to the local-electrostatic energy coming from the i-j pair
3092           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3093      &     +a33*muij(4)
3094 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3095
3096           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3097      &            'eelloc',i,j,eel_loc_ij
3098
3099           eel_loc=eel_loc+eel_loc_ij
3100 C Partial derivatives in virtual-bond dihedral angles gamma
3101           if (i.gt.1)
3102      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3103      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3104      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3105           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3106      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3107      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3108 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3109           do l=1,3
3110             ggg(l)=agg(l,1)*muij(1)+
3111      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3112             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3113             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3114 cgrad            ghalf=0.5d0*ggg(l)
3115 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3116 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3117           enddo
3118 cgrad          do k=i+1,j2
3119 cgrad            do l=1,3
3120 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3121 cgrad            enddo
3122 cgrad          enddo
3123 C Remaining derivatives of eello
3124           do l=1,3
3125             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3126      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3127             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3128      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3129             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3130      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3131             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3132      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3133           enddo
3134           ENDIF
3135           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3136             do k=1,4
3137               do l=1,3
3138                 ghalf=0.5d0*agg(l,k)
3139                 aggi(l,k)=aggi(l,k)+ghalf
3140                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3141                 aggj(l,k)=aggj(l,k)+ghalf
3142               enddo
3143             enddo
3144             if (j.eq.nres-1 .and. i.lt.j-2) then
3145               do k=1,4
3146                 do l=1,3
3147                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3148                 enddo
3149               enddo
3150             endif
3151           endif
3152 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3153 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3154           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3155      &       .and. num_conti.le.maxconts) then
3156 c            write (iout,*) i,j," entered corr"
3157 C
3158 C Calculate the contact function. The ith column of the array JCONT will
3159 C contain the numbers of atoms that make contacts with the atom I (of numbers
3160 C greater than I). The arrays FACONT and GACONT will contain the values of
3161 C the contact function and its derivative.
3162 c           r0ij=1.02D0*rpp(iteli,itelj)
3163 c           r0ij=1.11D0*rpp(iteli,itelj)
3164             r0ij=2.20D0*rpp(iteli,itelj)
3165 c           r0ij=1.55D0*rpp(iteli,itelj)
3166             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3167             if (fcont.gt.0.0D0) then
3168               num_conti=num_conti+1
3169               if (num_conti.gt.maxconts) then
3170                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3171      &                         ' will skip next contacts for this conf.'
3172               else
3173                 jcont_hb(num_conti,i)=j
3174                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3175      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3176 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3177 C  terms.
3178                 d_cont(num_conti,i)=rij
3179 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3180 C     --- Electrostatic-interaction matrix ---
3181                 a_chuj(1,1,num_conti,i)=a22
3182                 a_chuj(1,2,num_conti,i)=a23
3183                 a_chuj(2,1,num_conti,i)=a32
3184                 a_chuj(2,2,num_conti,i)=a33
3185 C     --- Gradient of rij
3186                 do kkk=1,3
3187                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3188                 enddo
3189                 kkll=0
3190                 do k=1,2
3191                   do l=1,2
3192                     kkll=kkll+1
3193                     do m=1,3
3194                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3195                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3196                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3197                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3198                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3199                     enddo
3200                   enddo
3201                 enddo
3202                 ENDIF
3203                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3204 C Calculate contact energies
3205                 cosa4=4.0D0*cosa
3206                 wij=cosa-3.0D0*cosb*cosg
3207                 cosbg1=cosb+cosg
3208                 cosbg2=cosb-cosg
3209 c               fac3=dsqrt(-ael6i)/r0ij**3
3210                 fac3=dsqrt(-ael6i)*r3ij
3211 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3212                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3213                 if (ees0tmp.gt.0) then
3214                   ees0pij=dsqrt(ees0tmp)
3215                 else
3216                   ees0pij=0
3217                 endif
3218 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3219                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3220                 if (ees0tmp.gt.0) then
3221                   ees0mij=dsqrt(ees0tmp)
3222                 else
3223                   ees0mij=0
3224                 endif
3225 c               ees0mij=0.0D0
3226                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3227                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3228 C Diagnostics. Comment out or remove after debugging!
3229 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3230 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3231 c               ees0m(num_conti,i)=0.0D0
3232 C End diagnostics.
3233 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3234 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3235 C Angular derivatives of the contact function
3236                 ees0pij1=fac3/ees0pij
3237                 ees0mij1=fac3/ees0mij
3238                 fac3p=-3.0D0*fac3*rrmij
3239                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3240                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3241 c               ees0mij1=0.0D0
3242                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3243                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3244                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3245                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3246                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3247                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3248                 ecosap=ecosa1+ecosa2
3249                 ecosbp=ecosb1+ecosb2
3250                 ecosgp=ecosg1+ecosg2
3251                 ecosam=ecosa1-ecosa2
3252                 ecosbm=ecosb1-ecosb2
3253                 ecosgm=ecosg1-ecosg2
3254 C Diagnostics
3255 c               ecosap=ecosa1
3256 c               ecosbp=ecosb1
3257 c               ecosgp=ecosg1
3258 c               ecosam=0.0D0
3259 c               ecosbm=0.0D0
3260 c               ecosgm=0.0D0
3261 C End diagnostics
3262                 facont_hb(num_conti,i)=fcont
3263                 fprimcont=fprimcont/rij
3264 cd              facont_hb(num_conti,i)=1.0D0
3265 C Following line is for diagnostics.
3266 cd              fprimcont=0.0D0
3267                 do k=1,3
3268                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3269                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3270                 enddo
3271                 do k=1,3
3272                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3273                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3274                 enddo
3275                 gggp(1)=gggp(1)+ees0pijp*xj
3276                 gggp(2)=gggp(2)+ees0pijp*yj
3277                 gggp(3)=gggp(3)+ees0pijp*zj
3278                 gggm(1)=gggm(1)+ees0mijp*xj
3279                 gggm(2)=gggm(2)+ees0mijp*yj
3280                 gggm(3)=gggm(3)+ees0mijp*zj
3281 C Derivatives due to the contact function
3282                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3283                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3284                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3285                 do k=1,3
3286                   ghalfp=0.5D0*gggp(k)
3287                   ghalfm=0.5D0*gggm(k)
3288                   gacontp_hb1(k,num_conti,i)=ghalfp
3289      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3290      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3291                   gacontp_hb2(k,num_conti,i)=ghalfp
3292      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3293      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3294                   gacontp_hb3(k,num_conti,i)=gggp(k)
3295                   gacontm_hb1(k,num_conti,i)=ghalfm
3296      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3297      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3298                   gacontm_hb2(k,num_conti,i)=ghalfm
3299      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3300      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3301                   gacontm_hb3(k,num_conti,i)=gggm(k)
3302                 enddo
3303 C Diagnostics. Comment out or remove after debugging!
3304 cdiag           do k=1,3
3305 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3306 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3307 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3308 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3309 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3310 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3311 cdiag           enddo
3312               ENDIF ! wcorr
3313               endif  ! num_conti.le.maxconts
3314             endif  ! fcont.gt.0
3315           endif    ! j.gt.i+1
3316 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3317       return
3318       end
3319 C-----------------------------------------------------------------------------
3320       subroutine eturn3(i,eello_turn3)
3321 C Third- and fourth-order contributions from turns
3322       implicit real*8 (a-h,o-z)
3323       include 'DIMENSIONS'
3324       include 'COMMON.IOUNITS'
3325       include 'COMMON.GEO'
3326       include 'COMMON.VAR'
3327       include 'COMMON.LOCAL'
3328       include 'COMMON.CHAIN'
3329       include 'COMMON.DERIV'
3330       include 'COMMON.INTERACT'
3331       include 'COMMON.CONTACTS'
3332       include 'COMMON.TORSION'
3333       include 'COMMON.VECTORS'
3334       include 'COMMON.FFIELD'
3335       include 'COMMON.CONTROL'
3336       dimension ggg(3)
3337       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3338      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3339      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3340       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3341      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3342       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3343      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3344      &    num_conti,j1,j2
3345       j=i+2
3346 c      write (iout,*) "eturn3",i,j,j1,j2
3347       a_temp(1,1)=a22
3348       a_temp(1,2)=a23
3349       a_temp(2,1)=a32
3350       a_temp(2,2)=a33
3351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3352 C
3353 C               Third-order contributions
3354 C
3355 C                 (i+2)o----(i+3)
3356 C                      | |
3357 C                      | |
3358 C                 (i+1)o----i
3359 C
3360 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3361 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3362         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3363         call transpose2(auxmat(1,1),auxmat1(1,1))
3364         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3365         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3366         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3367      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3368 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3369 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3370 cd     &    ' eello_turn3_num',4*eello_turn3_num
3371 C Derivatives in gamma(i)
3372         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3373         call transpose2(auxmat2(1,1),auxmat3(1,1))
3374         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3375         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3376 C Derivatives in gamma(i+1)
3377         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3378         call transpose2(auxmat2(1,1),auxmat3(1,1))
3379         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3380         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3381      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3382 C Cartesian derivatives
3383         do l=1,3
3384 c            ghalf1=0.5d0*agg(l,1)
3385 c            ghalf2=0.5d0*agg(l,2)
3386 c            ghalf3=0.5d0*agg(l,3)
3387 c            ghalf4=0.5d0*agg(l,4)
3388           a_temp(1,1)=aggi(l,1)!+ghalf1
3389           a_temp(1,2)=aggi(l,2)!+ghalf2
3390           a_temp(2,1)=aggi(l,3)!+ghalf3
3391           a_temp(2,2)=aggi(l,4)!+ghalf4
3392           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3393           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3394      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3395           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3396           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3397           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3398           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3399           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3400           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3401      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3402           a_temp(1,1)=aggj(l,1)!+ghalf1
3403           a_temp(1,2)=aggj(l,2)!+ghalf2
3404           a_temp(2,1)=aggj(l,3)!+ghalf3
3405           a_temp(2,2)=aggj(l,4)!+ghalf4
3406           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3407           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3408      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3409           a_temp(1,1)=aggj1(l,1)
3410           a_temp(1,2)=aggj1(l,2)
3411           a_temp(2,1)=aggj1(l,3)
3412           a_temp(2,2)=aggj1(l,4)
3413           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3414           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3415      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3416         enddo
3417       return
3418       end
3419 C-------------------------------------------------------------------------------
3420       subroutine eturn4(i,eello_turn4)
3421 C Third- and fourth-order contributions from turns
3422       implicit real*8 (a-h,o-z)
3423       include 'DIMENSIONS'
3424       include 'COMMON.IOUNITS'
3425       include 'COMMON.GEO'
3426       include 'COMMON.VAR'
3427       include 'COMMON.LOCAL'
3428       include 'COMMON.CHAIN'
3429       include 'COMMON.DERIV'
3430       include 'COMMON.INTERACT'
3431       include 'COMMON.CONTACTS'
3432       include 'COMMON.TORSION'
3433       include 'COMMON.VECTORS'
3434       include 'COMMON.FFIELD'
3435       include 'COMMON.CONTROL'
3436       dimension ggg(3)
3437       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3438      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3439      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3440       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3441      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3442       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3443      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3444      &    num_conti,j1,j2
3445       j=i+3
3446 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3447 C
3448 C               Fourth-order contributions
3449 C
3450 C                 (i+3)o----(i+4)
3451 C                     /  |
3452 C               (i+2)o   |
3453 C                     \  |
3454 C                 (i+1)o----i
3455 C
3456 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3457 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3458 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3459         a_temp(1,1)=a22
3460         a_temp(1,2)=a23
3461         a_temp(2,1)=a32
3462         a_temp(2,2)=a33
3463         iti1=itortyp(itype(i+1))
3464         iti2=itortyp(itype(i+2))
3465         iti3=itortyp(itype(i+3))
3466 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3467         call transpose2(EUg(1,1,i+1),e1t(1,1))
3468         call transpose2(Eug(1,1,i+2),e2t(1,1))
3469         call transpose2(Eug(1,1,i+3),e3t(1,1))
3470         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3471         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3472         s1=scalar2(b1(1,iti2),auxvec(1))
3473         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3474         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3475         s2=scalar2(b1(1,iti1),auxvec(1))
3476         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3477         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3478         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3479         eello_turn4=eello_turn4-(s1+s2+s3)
3480         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3481      &      'eturn4',i,j,-(s1+s2+s3)
3482 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3483 cd     &    ' eello_turn4_num',8*eello_turn4_num
3484 C Derivatives in gamma(i)
3485         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3486         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3487         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3488         s1=scalar2(b1(1,iti2),auxvec(1))
3489         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3490         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3491         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3492 C Derivatives in gamma(i+1)
3493         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3494         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3495         s2=scalar2(b1(1,iti1),auxvec(1))
3496         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3497         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3498         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3499         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3500 C Derivatives in gamma(i+2)
3501         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3502         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3503         s1=scalar2(b1(1,iti2),auxvec(1))
3504         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3505         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3506         s2=scalar2(b1(1,iti1),auxvec(1))
3507         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3508         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3509         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3510         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3511 C Cartesian derivatives
3512 C Derivatives of this turn contributions in DC(i+2)
3513         if (j.lt.nres-1) then
3514           do l=1,3
3515             a_temp(1,1)=agg(l,1)
3516             a_temp(1,2)=agg(l,2)
3517             a_temp(2,1)=agg(l,3)
3518             a_temp(2,2)=agg(l,4)
3519             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3520             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3521             s1=scalar2(b1(1,iti2),auxvec(1))
3522             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3523             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3524             s2=scalar2(b1(1,iti1),auxvec(1))
3525             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3526             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3527             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3528             ggg(l)=-(s1+s2+s3)
3529             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3530           enddo
3531         endif
3532 C Remaining derivatives of this turn contribution
3533         do l=1,3
3534           a_temp(1,1)=aggi(l,1)
3535           a_temp(1,2)=aggi(l,2)
3536           a_temp(2,1)=aggi(l,3)
3537           a_temp(2,2)=aggi(l,4)
3538           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3539           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3540           s1=scalar2(b1(1,iti2),auxvec(1))
3541           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3542           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3543           s2=scalar2(b1(1,iti1),auxvec(1))
3544           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3545           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3546           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3547           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3548           a_temp(1,1)=aggi1(l,1)
3549           a_temp(1,2)=aggi1(l,2)
3550           a_temp(2,1)=aggi1(l,3)
3551           a_temp(2,2)=aggi1(l,4)
3552           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3553           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3554           s1=scalar2(b1(1,iti2),auxvec(1))
3555           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3556           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3557           s2=scalar2(b1(1,iti1),auxvec(1))
3558           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3559           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3560           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3561           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3562           a_temp(1,1)=aggj(l,1)
3563           a_temp(1,2)=aggj(l,2)
3564           a_temp(2,1)=aggj(l,3)
3565           a_temp(2,2)=aggj(l,4)
3566           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3567           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3568           s1=scalar2(b1(1,iti2),auxvec(1))
3569           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3570           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3571           s2=scalar2(b1(1,iti1),auxvec(1))
3572           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3573           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3574           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3575           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3576           a_temp(1,1)=aggj1(l,1)
3577           a_temp(1,2)=aggj1(l,2)
3578           a_temp(2,1)=aggj1(l,3)
3579           a_temp(2,2)=aggj1(l,4)
3580           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3581           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3582           s1=scalar2(b1(1,iti2),auxvec(1))
3583           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3584           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3585           s2=scalar2(b1(1,iti1),auxvec(1))
3586           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3587           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3588           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3589 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3590           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3591         enddo
3592       return
3593       end
3594 C-----------------------------------------------------------------------------
3595       subroutine vecpr(u,v,w)
3596       implicit real*8(a-h,o-z)
3597       dimension u(3),v(3),w(3)
3598       w(1)=u(2)*v(3)-u(3)*v(2)
3599       w(2)=-u(1)*v(3)+u(3)*v(1)
3600       w(3)=u(1)*v(2)-u(2)*v(1)
3601       return
3602       end
3603 C-----------------------------------------------------------------------------
3604       subroutine unormderiv(u,ugrad,unorm,ungrad)
3605 C This subroutine computes the derivatives of a normalized vector u, given
3606 C the derivatives computed without normalization conditions, ugrad. Returns
3607 C ungrad.
3608       implicit none
3609       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3610       double precision vec(3)
3611       double precision scalar
3612       integer i,j
3613 c      write (2,*) 'ugrad',ugrad
3614 c      write (2,*) 'u',u
3615       do i=1,3
3616         vec(i)=scalar(ugrad(1,i),u(1))
3617       enddo
3618 c      write (2,*) 'vec',vec
3619       do i=1,3
3620         do j=1,3
3621           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3622         enddo
3623       enddo
3624 c      write (2,*) 'ungrad',ungrad
3625       return
3626       end
3627 C-----------------------------------------------------------------------------
3628       subroutine escp_soft_sphere(evdw2,evdw2_14)
3629 C
3630 C This subroutine calculates the excluded-volume interaction energy between
3631 C peptide-group centers and side chains and its gradient in virtual-bond and
3632 C side-chain vectors.
3633 C
3634       implicit real*8 (a-h,o-z)
3635       include 'DIMENSIONS'
3636       include 'COMMON.GEO'
3637       include 'COMMON.VAR'
3638       include 'COMMON.LOCAL'
3639       include 'COMMON.CHAIN'
3640       include 'COMMON.DERIV'
3641       include 'COMMON.INTERACT'
3642       include 'COMMON.FFIELD'
3643       include 'COMMON.IOUNITS'
3644       include 'COMMON.CONTROL'
3645       dimension ggg(3)
3646       evdw2=0.0D0
3647       evdw2_14=0.0d0
3648       r0_scp=4.5d0
3649 cd    print '(a)','Enter ESCP'
3650 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3651       do i=iatscp_s,iatscp_e
3652         iteli=itel(i)
3653         xi=0.5D0*(c(1,i)+c(1,i+1))
3654         yi=0.5D0*(c(2,i)+c(2,i+1))
3655         zi=0.5D0*(c(3,i)+c(3,i+1))
3656
3657         do iint=1,nscp_gr(i)
3658
3659         do j=iscpstart(i,iint),iscpend(i,iint)
3660           itypj=itype(j)
3661 C Uncomment following three lines for SC-p interactions
3662 c         xj=c(1,nres+j)-xi
3663 c         yj=c(2,nres+j)-yi
3664 c         zj=c(3,nres+j)-zi
3665 C Uncomment following three lines for Ca-p interactions
3666           xj=c(1,j)-xi
3667           yj=c(2,j)-yi
3668           zj=c(3,j)-zi
3669           rij=xj*xj+yj*yj+zj*zj
3670           r0ij=r0_scp
3671           r0ijsq=r0ij*r0ij
3672           if (rij.lt.r0ijsq) then
3673             evdwij=0.25d0*(rij-r0ijsq)**2
3674             fac=rij-r0ijsq
3675           else
3676             evdwij=0.0d0
3677             fac=0.0d0
3678           endif
3679           evdw2=evdw2+evdwij
3680 C
3681 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3682 C
3683           ggg(1)=xj*fac
3684           ggg(2)=yj*fac
3685           ggg(3)=zj*fac
3686           if (j.lt.i) then
3687 cd          write (iout,*) 'j<i'
3688 C Uncomment following three lines for SC-p interactions
3689 c           do k=1,3
3690 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3691 c           enddo
3692           else
3693 cd          write (iout,*) 'j>i'
3694             do k=1,3
3695               ggg(k)=-ggg(k)
3696 C Uncomment following line for SC-p interactions
3697 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3698             enddo
3699           endif
3700           do k=1,3
3701             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3702           enddo
3703           kstart=min0(i+1,j)
3704           kend=max0(i-1,j-1)
3705 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3706 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3707           do k=kstart,kend
3708             do l=1,3
3709               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3710             enddo
3711           enddo
3712         enddo
3713
3714         enddo ! iint
3715       enddo ! i
3716       return
3717       end
3718 C-----------------------------------------------------------------------------
3719       subroutine escp(evdw2,evdw2_14)
3720 C
3721 C This subroutine calculates the excluded-volume interaction energy between
3722 C peptide-group centers and side chains and its gradient in virtual-bond and
3723 C side-chain vectors.
3724 C
3725       implicit real*8 (a-h,o-z)
3726       include 'DIMENSIONS'
3727       include 'COMMON.GEO'
3728       include 'COMMON.VAR'
3729       include 'COMMON.LOCAL'
3730       include 'COMMON.CHAIN'
3731       include 'COMMON.DERIV'
3732       include 'COMMON.INTERACT'
3733       include 'COMMON.FFIELD'
3734       include 'COMMON.IOUNITS'
3735       include 'COMMON.CONTROL'
3736       dimension ggg(3)
3737       evdw2=0.0D0
3738       evdw2_14=0.0d0
3739 cd    print '(a)','Enter ESCP'
3740 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3741       do i=iatscp_s,iatscp_e
3742         iteli=itel(i)
3743         xi=0.5D0*(c(1,i)+c(1,i+1))
3744         yi=0.5D0*(c(2,i)+c(2,i+1))
3745         zi=0.5D0*(c(3,i)+c(3,i+1))
3746
3747         do iint=1,nscp_gr(i)
3748
3749         do j=iscpstart(i,iint),iscpend(i,iint)
3750           itypj=itype(j)
3751 C Uncomment following three lines for SC-p interactions
3752 c         xj=c(1,nres+j)-xi
3753 c         yj=c(2,nres+j)-yi
3754 c         zj=c(3,nres+j)-zi
3755 C Uncomment following three lines for Ca-p interactions
3756           xj=c(1,j)-xi
3757           yj=c(2,j)-yi
3758           zj=c(3,j)-zi
3759           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3760           fac=rrij**expon2
3761           e1=fac*fac*aad(itypj,iteli)
3762           e2=fac*bad(itypj,iteli)
3763           if (iabs(j-i) .le. 2) then
3764             e1=scal14*e1
3765             e2=scal14*e2
3766             evdw2_14=evdw2_14+e1+e2
3767           endif
3768           evdwij=e1+e2
3769           evdw2=evdw2+evdwij
3770           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3771      &        'evdw2',i,j,evdwij
3772 C
3773 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3774 C
3775           fac=-(evdwij+e1)*rrij
3776           ggg(1)=xj*fac
3777           ggg(2)=yj*fac
3778           ggg(3)=zj*fac
3779 cgrad          if (j.lt.i) then
3780 cd          write (iout,*) 'j<i'
3781 C Uncomment following three lines for SC-p interactions
3782 c           do k=1,3
3783 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3784 c           enddo
3785 cgrad          else
3786 cd          write (iout,*) 'j>i'
3787 cgrad            do k=1,3
3788 cgrad              ggg(k)=-ggg(k)
3789 C Uncomment following line for SC-p interactions
3790 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3791 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3792 cgrad            enddo
3793 cgrad          endif
3794 cgrad          do k=1,3
3795 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3796 cgrad          enddo
3797 cgrad          kstart=min0(i+1,j)
3798 cgrad          kend=max0(i-1,j-1)
3799 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3800 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3801 cgrad          do k=kstart,kend
3802 cgrad            do l=1,3
3803 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3804 cgrad            enddo
3805 cgrad          enddo
3806           do k=1,3
3807             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3808             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3809           enddo
3810         enddo
3811
3812         enddo ! iint
3813       enddo ! i
3814       do i=1,nct
3815         do j=1,3
3816           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3817           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3818           gradx_scp(j,i)=expon*gradx_scp(j,i)
3819         enddo
3820       enddo
3821 C******************************************************************************
3822 C
3823 C                              N O T E !!!
3824 C
3825 C To save time the factor EXPON has been extracted from ALL components
3826 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3827 C use!
3828 C
3829 C******************************************************************************
3830       return
3831       end
3832 C--------------------------------------------------------------------------
3833       subroutine edis(ehpb)
3834 C
3835 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3836 C
3837       implicit real*8 (a-h,o-z)
3838       include 'DIMENSIONS'
3839       include 'COMMON.SBRIDGE'
3840       include 'COMMON.CHAIN'
3841       include 'COMMON.DERIV'
3842       include 'COMMON.VAR'
3843       include 'COMMON.INTERACT'
3844       dimension ggg(3)
3845       ehpb=0.0D0
3846 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3847 cd    print *,'link_start=',link_start,' link_end=',link_end
3848       if (link_end.eq.0) return
3849       do i=link_start,link_end
3850 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3851 C CA-CA distance used in regularization of structure.
3852         ii=ihpb(i)
3853         jj=jhpb(i)
3854 C iii and jjj point to the residues for which the distance is assigned.
3855         if (ii.gt.nres) then
3856           iii=ii-nres
3857           jjj=jj-nres
3858         else
3859           iii=ii
3860           jjj=jj
3861         endif
3862 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3863 C    distance and angle dependent SS bond potential.
3864         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3865           call ssbond_ene(iii,jjj,eij)
3866           ehpb=ehpb+2*eij
3867         else
3868 C Calculate the distance between the two points and its difference from the
3869 C target distance.
3870         dd=dist(ii,jj)
3871         rdis=dd-dhpb(i)
3872 C Get the force constant corresponding to this distance.
3873         waga=forcon(i)
3874 C Calculate the contribution to energy.
3875         ehpb=ehpb+waga*rdis*rdis
3876 C
3877 C Evaluate gradient.
3878 C
3879         fac=waga*rdis/dd
3880 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3881 cd   &   ' waga=',waga,' fac=',fac
3882         do j=1,3
3883           ggg(j)=fac*(c(j,jj)-c(j,ii))
3884         enddo
3885 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3886 C If this is a SC-SC distance, we need to calculate the contributions to the
3887 C Cartesian gradient in the SC vectors (ghpbx).
3888         if (iii.lt.ii) then
3889           do j=1,3
3890             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3891             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3892           enddo
3893         endif
3894         do j=iii,jjj-1
3895           do k=1,3
3896             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3897           enddo
3898         enddo
3899         endif
3900       enddo
3901       ehpb=0.5D0*ehpb
3902       return
3903       end
3904 C--------------------------------------------------------------------------
3905       subroutine ssbond_ene(i,j,eij)
3906 C
3907 C Calculate the distance and angle dependent SS-bond potential energy
3908 C using a free-energy function derived based on RHF/6-31G** ab initio
3909 C calculations of diethyl disulfide.
3910 C
3911 C A. Liwo and U. Kozlowska, 11/24/03
3912 C
3913       implicit real*8 (a-h,o-z)
3914       include 'DIMENSIONS'
3915       include 'COMMON.SBRIDGE'
3916       include 'COMMON.CHAIN'
3917       include 'COMMON.DERIV'
3918       include 'COMMON.LOCAL'
3919       include 'COMMON.INTERACT'
3920       include 'COMMON.VAR'
3921       include 'COMMON.IOUNITS'
3922       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3923       itypi=itype(i)
3924       xi=c(1,nres+i)
3925       yi=c(2,nres+i)
3926       zi=c(3,nres+i)
3927       dxi=dc_norm(1,nres+i)
3928       dyi=dc_norm(2,nres+i)
3929       dzi=dc_norm(3,nres+i)
3930       dsci_inv=dsc_inv(itypi)
3931       itypj=itype(j)
3932       dscj_inv=dsc_inv(itypj)
3933       xj=c(1,nres+j)-xi
3934       yj=c(2,nres+j)-yi
3935       zj=c(3,nres+j)-zi
3936       dxj=dc_norm(1,nres+j)
3937       dyj=dc_norm(2,nres+j)
3938       dzj=dc_norm(3,nres+j)
3939       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3940       rij=dsqrt(rrij)
3941       erij(1)=xj*rij
3942       erij(2)=yj*rij
3943       erij(3)=zj*rij
3944       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3945       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3946       om12=dxi*dxj+dyi*dyj+dzi*dzj
3947       do k=1,3
3948         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3949         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3950       enddo
3951       rij=1.0d0/rij
3952       deltad=rij-d0cm
3953       deltat1=1.0d0-om1
3954       deltat2=1.0d0+om2
3955       deltat12=om2-om1+2.0d0
3956       cosphi=om12-om1*om2
3957       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3958      &  +akct*deltad*deltat12
3959      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3960 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3961 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3962 c     &  " deltat12",deltat12," eij",eij
3963       ed=2*akcm*deltad+akct*deltat12
3964       pom1=akct*deltad
3965       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3966       eom1=-2*akth*deltat1-pom1-om2*pom2
3967       eom2= 2*akth*deltat2+pom1-om1*pom2
3968       eom12=pom2
3969       do k=1,3
3970         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3971       enddo
3972       do k=1,3
3973         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3974      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3975         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3976      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3977       enddo
3978 C
3979 C Calculate the components of the gradient in DC and X
3980 C
3981       do k=i,j-1
3982         do l=1,3
3983           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3984         enddo
3985       enddo
3986       return
3987       end
3988 C--------------------------------------------------------------------------
3989       subroutine ebond(estr)
3990 c
3991 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3992 c
3993       implicit real*8 (a-h,o-z)
3994       include 'DIMENSIONS'
3995       include 'COMMON.LOCAL'
3996       include 'COMMON.GEO'
3997       include 'COMMON.INTERACT'
3998       include 'COMMON.DERIV'
3999       include 'COMMON.VAR'
4000       include 'COMMON.CHAIN'
4001       include 'COMMON.IOUNITS'
4002       include 'COMMON.NAMES'
4003       include 'COMMON.FFIELD'
4004       include 'COMMON.CONTROL'
4005       include 'COMMON.SETUP'
4006       double precision u(3),ud(3)
4007       estr=0.0d0
4008       do i=ibondp_start,ibondp_end
4009         diff = vbld(i)-vbldp0
4010 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4011         estr=estr+diff*diff
4012         do j=1,3
4013           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4014         enddo
4015 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4016       enddo
4017       estr=0.5d0*AKP*estr
4018 c
4019 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4020 c
4021       do i=ibond_start,ibond_end
4022         iti=itype(i)
4023         if (iti.ne.10) then
4024           nbi=nbondterm(iti)
4025           if (nbi.eq.1) then
4026             diff=vbld(i+nres)-vbldsc0(1,iti)
4027 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4028 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4029             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4030             do j=1,3
4031               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4032             enddo
4033           else
4034             do j=1,nbi
4035               diff=vbld(i+nres)-vbldsc0(j,iti)
4036               ud(j)=aksc(j,iti)*diff
4037               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4038             enddo
4039             uprod=u(1)
4040             do j=2,nbi
4041               uprod=uprod*u(j)
4042             enddo
4043             usum=0.0d0
4044             usumsqder=0.0d0
4045             do j=1,nbi
4046               uprod1=1.0d0
4047               uprod2=1.0d0
4048               do k=1,nbi
4049                 if (k.ne.j) then
4050                   uprod1=uprod1*u(k)
4051                   uprod2=uprod2*u(k)*u(k)
4052                 endif
4053               enddo
4054               usum=usum+uprod1
4055               usumsqder=usumsqder+ud(j)*uprod2
4056             enddo
4057             estr=estr+uprod/usum
4058             do j=1,3
4059              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4060             enddo
4061           endif
4062         endif
4063       enddo
4064       return
4065       end
4066 #ifdef CRYST_THETA
4067 C--------------------------------------------------------------------------
4068       subroutine ebend(etheta)
4069 C
4070 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4071 C angles gamma and its derivatives in consecutive thetas and gammas.
4072 C
4073       implicit real*8 (a-h,o-z)
4074       include 'DIMENSIONS'
4075       include 'COMMON.LOCAL'
4076       include 'COMMON.GEO'
4077       include 'COMMON.INTERACT'
4078       include 'COMMON.DERIV'
4079       include 'COMMON.VAR'
4080       include 'COMMON.CHAIN'
4081       include 'COMMON.IOUNITS'
4082       include 'COMMON.NAMES'
4083       include 'COMMON.FFIELD'
4084       include 'COMMON.CONTROL'
4085       common /calcthet/ term1,term2,termm,diffak,ratak,
4086      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4087      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4088       double precision y(2),z(2)
4089       delta=0.02d0*pi
4090 c      time11=dexp(-2*time)
4091 c      time12=1.0d0
4092       etheta=0.0D0
4093 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4094       do i=ithet_start,ithet_end
4095 C Zero the energy function and its derivative at 0 or pi.
4096         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4097         it=itype(i-1)
4098         if (i.gt.3) then
4099 #ifdef OSF
4100           phii=phi(i)
4101           if (phii.ne.phii) phii=150.0
4102 #else
4103           phii=phi(i)
4104 #endif
4105           y(1)=dcos(phii)
4106           y(2)=dsin(phii)
4107         else
4108           y(1)=0.0D0
4109           y(2)=0.0D0
4110         endif
4111         if (i.lt.nres) then
4112 #ifdef OSF
4113           phii1=phi(i+1)
4114           if (phii1.ne.phii1) phii1=150.0
4115           phii1=pinorm(phii1)
4116           z(1)=cos(phii1)
4117 #else
4118           phii1=phi(i+1)
4119           z(1)=dcos(phii1)
4120 #endif
4121           z(2)=dsin(phii1)
4122         else
4123           z(1)=0.0D0
4124           z(2)=0.0D0
4125         endif
4126 C Calculate the "mean" value of theta from the part of the distribution
4127 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4128 C In following comments this theta will be referred to as t_c.
4129         thet_pred_mean=0.0d0
4130         do k=1,2
4131           athetk=athet(k,it)
4132           bthetk=bthet(k,it)
4133           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4134         enddo
4135         dthett=thet_pred_mean*ssd
4136         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4137 C Derivatives of the "mean" values in gamma1 and gamma2.
4138         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4139         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4140         if (theta(i).gt.pi-delta) then
4141           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4142      &         E_tc0)
4143           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4144           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4145           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4146      &        E_theta)
4147           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4148      &        E_tc)
4149         else if (theta(i).lt.delta) then
4150           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4151           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4152           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4153      &        E_theta)
4154           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4155           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4156      &        E_tc)
4157         else
4158           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4159      &        E_theta,E_tc)
4160         endif
4161         etheta=etheta+ethetai
4162         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4163      &      'ebend',i,ethetai
4164         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4165         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4166         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4167       enddo
4168 C Ufff.... We've done all this!!!
4169       return
4170       end
4171 C---------------------------------------------------------------------------
4172       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4173      &     E_tc)
4174       implicit real*8 (a-h,o-z)
4175       include 'DIMENSIONS'
4176       include 'COMMON.LOCAL'
4177       include 'COMMON.IOUNITS'
4178       common /calcthet/ term1,term2,termm,diffak,ratak,
4179      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4180      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4181 C Calculate the contributions to both Gaussian lobes.
4182 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4183 C The "polynomial part" of the "standard deviation" of this part of
4184 C the distribution.
4185         sig=polthet(3,it)
4186         do j=2,0,-1
4187           sig=sig*thet_pred_mean+polthet(j,it)
4188         enddo
4189 C Derivative of the "interior part" of the "standard deviation of the"
4190 C gamma-dependent Gaussian lobe in t_c.
4191         sigtc=3*polthet(3,it)
4192         do j=2,1,-1
4193           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4194         enddo
4195         sigtc=sig*sigtc
4196 C Set the parameters of both Gaussian lobes of the distribution.
4197 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4198         fac=sig*sig+sigc0(it)
4199         sigcsq=fac+fac
4200         sigc=1.0D0/sigcsq
4201 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4202         sigsqtc=-4.0D0*sigcsq*sigtc
4203 c       print *,i,sig,sigtc,sigsqtc
4204 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4205         sigtc=-sigtc/(fac*fac)
4206 C Following variable is sigma(t_c)**(-2)
4207         sigcsq=sigcsq*sigcsq
4208         sig0i=sig0(it)
4209         sig0inv=1.0D0/sig0i**2
4210         delthec=thetai-thet_pred_mean
4211         delthe0=thetai-theta0i
4212         term1=-0.5D0*sigcsq*delthec*delthec
4213         term2=-0.5D0*sig0inv*delthe0*delthe0
4214 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4215 C NaNs in taking the logarithm. We extract the largest exponent which is added
4216 C to the energy (this being the log of the distribution) at the end of energy
4217 C term evaluation for this virtual-bond angle.
4218         if (term1.gt.term2) then
4219           termm=term1
4220           term2=dexp(term2-termm)
4221           term1=1.0d0
4222         else
4223           termm=term2
4224           term1=dexp(term1-termm)
4225           term2=1.0d0
4226         endif
4227 C The ratio between the gamma-independent and gamma-dependent lobes of
4228 C the distribution is a Gaussian function of thet_pred_mean too.
4229         diffak=gthet(2,it)-thet_pred_mean
4230         ratak=diffak/gthet(3,it)**2
4231         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4232 C Let's differentiate it in thet_pred_mean NOW.
4233         aktc=ak*ratak
4234 C Now put together the distribution terms to make complete distribution.
4235         termexp=term1+ak*term2
4236         termpre=sigc+ak*sig0i
4237 C Contribution of the bending energy from this theta is just the -log of
4238 C the sum of the contributions from the two lobes and the pre-exponential
4239 C factor. Simple enough, isn't it?
4240         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4241 C NOW the derivatives!!!
4242 C 6/6/97 Take into account the deformation.
4243         E_theta=(delthec*sigcsq*term1
4244      &       +ak*delthe0*sig0inv*term2)/termexp
4245         E_tc=((sigtc+aktc*sig0i)/termpre
4246      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4247      &       aktc*term2)/termexp)
4248       return
4249       end
4250 c-----------------------------------------------------------------------------
4251       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4252       implicit real*8 (a-h,o-z)
4253       include 'DIMENSIONS'
4254       include 'COMMON.LOCAL'
4255       include 'COMMON.IOUNITS'
4256       common /calcthet/ term1,term2,termm,diffak,ratak,
4257      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4258      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4259       delthec=thetai-thet_pred_mean
4260       delthe0=thetai-theta0i
4261 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4262       t3 = thetai-thet_pred_mean
4263       t6 = t3**2
4264       t9 = term1
4265       t12 = t3*sigcsq
4266       t14 = t12+t6*sigsqtc
4267       t16 = 1.0d0
4268       t21 = thetai-theta0i
4269       t23 = t21**2
4270       t26 = term2
4271       t27 = t21*t26
4272       t32 = termexp
4273       t40 = t32**2
4274       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4275      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4276      & *(-t12*t9-ak*sig0inv*t27)
4277       return
4278       end
4279 #else
4280 C--------------------------------------------------------------------------
4281       subroutine ebend(etheta)
4282 C
4283 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4284 C angles gamma and its derivatives in consecutive thetas and gammas.
4285 C ab initio-derived potentials from
4286 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4287 C
4288       implicit real*8 (a-h,o-z)
4289       include 'DIMENSIONS'
4290       include 'COMMON.LOCAL'
4291       include 'COMMON.GEO'
4292       include 'COMMON.INTERACT'
4293       include 'COMMON.DERIV'
4294       include 'COMMON.VAR'
4295       include 'COMMON.CHAIN'
4296       include 'COMMON.IOUNITS'
4297       include 'COMMON.NAMES'
4298       include 'COMMON.FFIELD'
4299       include 'COMMON.CONTROL'
4300       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4301      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4302      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4303      & sinph1ph2(maxdouble,maxdouble)
4304       logical lprn /.false./, lprn1 /.false./
4305       etheta=0.0D0
4306       do i=ithet_start,ithet_end
4307         dethetai=0.0d0
4308         dephii=0.0d0
4309         dephii1=0.0d0
4310         theti2=0.5d0*theta(i)
4311         ityp2=ithetyp(itype(i-1))
4312         do k=1,nntheterm
4313           coskt(k)=dcos(k*theti2)
4314           sinkt(k)=dsin(k*theti2)
4315         enddo
4316         if (i.gt.3) then
4317 #ifdef OSF
4318           phii=phi(i)
4319           if (phii.ne.phii) phii=150.0
4320 #else
4321           phii=phi(i)
4322 #endif
4323           ityp1=ithetyp(itype(i-2))
4324           do k=1,nsingle
4325             cosph1(k)=dcos(k*phii)
4326             sinph1(k)=dsin(k*phii)
4327           enddo
4328         else
4329           phii=0.0d0
4330           ityp1=nthetyp+1
4331           do k=1,nsingle
4332             cosph1(k)=0.0d0
4333             sinph1(k)=0.0d0
4334           enddo
4335         endif
4336         if (i.lt.nres) then
4337 #ifdef OSF
4338           phii1=phi(i+1)
4339           if (phii1.ne.phii1) phii1=150.0
4340           phii1=pinorm(phii1)
4341 #else
4342           phii1=phi(i+1)
4343 #endif
4344           ityp3=ithetyp(itype(i))
4345           do k=1,nsingle
4346             cosph2(k)=dcos(k*phii1)
4347             sinph2(k)=dsin(k*phii1)
4348           enddo
4349         else
4350           phii1=0.0d0
4351           ityp3=nthetyp+1
4352           do k=1,nsingle
4353             cosph2(k)=0.0d0
4354             sinph2(k)=0.0d0
4355           enddo
4356         endif
4357         ethetai=aa0thet(ityp1,ityp2,ityp3)
4358         do k=1,ndouble
4359           do l=1,k-1
4360             ccl=cosph1(l)*cosph2(k-l)
4361             ssl=sinph1(l)*sinph2(k-l)
4362             scl=sinph1(l)*cosph2(k-l)
4363             csl=cosph1(l)*sinph2(k-l)
4364             cosph1ph2(l,k)=ccl-ssl
4365             cosph1ph2(k,l)=ccl+ssl
4366             sinph1ph2(l,k)=scl+csl
4367             sinph1ph2(k,l)=scl-csl
4368           enddo
4369         enddo
4370         if (lprn) then
4371         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4372      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4373         write (iout,*) "coskt and sinkt"
4374         do k=1,nntheterm
4375           write (iout,*) k,coskt(k),sinkt(k)
4376         enddo
4377         endif
4378         do k=1,ntheterm
4379           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4380           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4381      &      *coskt(k)
4382           if (lprn)
4383      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4384      &     " ethetai",ethetai
4385         enddo
4386         if (lprn) then
4387         write (iout,*) "cosph and sinph"
4388         do k=1,nsingle
4389           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4390         enddo
4391         write (iout,*) "cosph1ph2 and sinph2ph2"
4392         do k=2,ndouble
4393           do l=1,k-1
4394             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4395      &         sinph1ph2(l,k),sinph1ph2(k,l)
4396           enddo
4397         enddo
4398         write(iout,*) "ethetai",ethetai
4399         endif
4400         do m=1,ntheterm2
4401           do k=1,nsingle
4402             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4403      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4404      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4405      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4406             ethetai=ethetai+sinkt(m)*aux
4407             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4408             dephii=dephii+k*sinkt(m)*(
4409      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4410      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4411             dephii1=dephii1+k*sinkt(m)*(
4412      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4413      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4414             if (lprn)
4415      &      write (iout,*) "m",m," k",k," bbthet",
4416      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4417      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4418      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4419      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4420           enddo
4421         enddo
4422         if (lprn)
4423      &  write(iout,*) "ethetai",ethetai
4424         do m=1,ntheterm3
4425           do k=2,ndouble
4426             do l=1,k-1
4427               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4428      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4429      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4430      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4431               ethetai=ethetai+sinkt(m)*aux
4432               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4433               dephii=dephii+l*sinkt(m)*(
4434      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4435      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4436      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4437      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4438               dephii1=dephii1+(k-l)*sinkt(m)*(
4439      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4440      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4441      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4442      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4443               if (lprn) then
4444               write (iout,*) "m",m," k",k," l",l," ffthet",
4445      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4446      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4447      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4448      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4449               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4450      &            cosph1ph2(k,l)*sinkt(m),
4451      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4452               endif
4453             enddo
4454           enddo
4455         enddo
4456 10      continue
4457         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4458      &   i,theta(i)*rad2deg,phii*rad2deg,
4459      &   phii1*rad2deg,ethetai
4460         etheta=etheta+ethetai
4461         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4462         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4463         gloc(nphi+i-2,icg)=wang*dethetai
4464       enddo
4465       return
4466       end
4467 #endif
4468 #ifdef CRYST_SC
4469 c-----------------------------------------------------------------------------
4470       subroutine esc(escloc)
4471 C Calculate the local energy of a side chain and its derivatives in the
4472 C corresponding virtual-bond valence angles THETA and the spherical angles
4473 C ALPHA and OMEGA.
4474       implicit real*8 (a-h,o-z)
4475       include 'DIMENSIONS'
4476       include 'COMMON.GEO'
4477       include 'COMMON.LOCAL'
4478       include 'COMMON.VAR'
4479       include 'COMMON.INTERACT'
4480       include 'COMMON.DERIV'
4481       include 'COMMON.CHAIN'
4482       include 'COMMON.IOUNITS'
4483       include 'COMMON.NAMES'
4484       include 'COMMON.FFIELD'
4485       include 'COMMON.CONTROL'
4486       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4487      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4488       common /sccalc/ time11,time12,time112,theti,it,nlobit
4489       delta=0.02d0*pi
4490       escloc=0.0D0
4491 c     write (iout,'(a)') 'ESC'
4492       do i=loc_start,loc_end
4493         it=itype(i)
4494         if (it.eq.10) goto 1
4495         nlobit=nlob(it)
4496 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4497 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4498         theti=theta(i+1)-pipol
4499         x(1)=dtan(theti)
4500         x(2)=alph(i)
4501         x(3)=omeg(i)
4502
4503         if (x(2).gt.pi-delta) then
4504           xtemp(1)=x(1)
4505           xtemp(2)=pi-delta
4506           xtemp(3)=x(3)
4507           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4508           xtemp(2)=pi
4509           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4510           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4511      &        escloci,dersc(2))
4512           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4513      &        ddersc0(1),dersc(1))
4514           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4515      &        ddersc0(3),dersc(3))
4516           xtemp(2)=pi-delta
4517           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4518           xtemp(2)=pi
4519           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4520           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4521      &            dersc0(2),esclocbi,dersc02)
4522           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4523      &            dersc12,dersc01)
4524           call splinthet(x(2),0.5d0*delta,ss,ssd)
4525           dersc0(1)=dersc01
4526           dersc0(2)=dersc02
4527           dersc0(3)=0.0d0
4528           do k=1,3
4529             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4530           enddo
4531           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4532 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4533 c    &             esclocbi,ss,ssd
4534           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4535 c         escloci=esclocbi
4536 c         write (iout,*) escloci
4537         else if (x(2).lt.delta) then
4538           xtemp(1)=x(1)
4539           xtemp(2)=delta
4540           xtemp(3)=x(3)
4541           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4542           xtemp(2)=0.0d0
4543           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4544           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4545      &        escloci,dersc(2))
4546           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4547      &        ddersc0(1),dersc(1))
4548           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4549      &        ddersc0(3),dersc(3))
4550           xtemp(2)=delta
4551           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4552           xtemp(2)=0.0d0
4553           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4554           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4555      &            dersc0(2),esclocbi,dersc02)
4556           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4557      &            dersc12,dersc01)
4558           dersc0(1)=dersc01
4559           dersc0(2)=dersc02
4560           dersc0(3)=0.0d0
4561           call splinthet(x(2),0.5d0*delta,ss,ssd)
4562           do k=1,3
4563             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4564           enddo
4565           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4566 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4567 c    &             esclocbi,ss,ssd
4568           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4569 c         write (iout,*) escloci
4570         else
4571           call enesc(x,escloci,dersc,ddummy,.false.)
4572         endif
4573
4574         escloc=escloc+escloci
4575         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4576      &     'escloc',i,escloci
4577 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4578
4579         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4580      &   wscloc*dersc(1)
4581         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4582         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4583     1   continue
4584       enddo
4585       return
4586       end
4587 C---------------------------------------------------------------------------
4588       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4589       implicit real*8 (a-h,o-z)
4590       include 'DIMENSIONS'
4591       include 'COMMON.GEO'
4592       include 'COMMON.LOCAL'
4593       include 'COMMON.IOUNITS'
4594       common /sccalc/ time11,time12,time112,theti,it,nlobit
4595       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4596       double precision contr(maxlob,-1:1)
4597       logical mixed
4598 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4599         escloc_i=0.0D0
4600         do j=1,3
4601           dersc(j)=0.0D0
4602           if (mixed) ddersc(j)=0.0d0
4603         enddo
4604         x3=x(3)
4605
4606 C Because of periodicity of the dependence of the SC energy in omega we have
4607 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4608 C To avoid underflows, first compute & store the exponents.
4609
4610         do iii=-1,1
4611
4612           x(3)=x3+iii*dwapi
4613
4614           do j=1,nlobit
4615             do k=1,3
4616               z(k)=x(k)-censc(k,j,it)
4617             enddo
4618             do k=1,3
4619               Axk=0.0D0
4620               do l=1,3
4621                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4622               enddo
4623               Ax(k,j,iii)=Axk
4624             enddo
4625             expfac=0.0D0
4626             do k=1,3
4627               expfac=expfac+Ax(k,j,iii)*z(k)
4628             enddo
4629             contr(j,iii)=expfac
4630           enddo ! j
4631
4632         enddo ! iii
4633
4634         x(3)=x3
4635 C As in the case of ebend, we want to avoid underflows in exponentiation and
4636 C subsequent NaNs and INFs in energy calculation.
4637 C Find the largest exponent
4638         emin=contr(1,-1)
4639         do iii=-1,1
4640           do j=1,nlobit
4641             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4642           enddo
4643         enddo
4644         emin=0.5D0*emin
4645 cd      print *,'it=',it,' emin=',emin
4646
4647 C Compute the contribution to SC energy and derivatives
4648         do iii=-1,1
4649
4650           do j=1,nlobit
4651 #ifdef OSF
4652             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4653             if(adexp.ne.adexp) adexp=1.0
4654             expfac=dexp(adexp)
4655 #else
4656             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4657 #endif
4658 cd          print *,'j=',j,' expfac=',expfac
4659             escloc_i=escloc_i+expfac
4660             do k=1,3
4661               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4662             enddo
4663             if (mixed) then
4664               do k=1,3,2
4665                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4666      &            +gaussc(k,2,j,it))*expfac
4667               enddo
4668             endif
4669           enddo
4670
4671         enddo ! iii
4672
4673         dersc(1)=dersc(1)/cos(theti)**2
4674         ddersc(1)=ddersc(1)/cos(theti)**2
4675         ddersc(3)=ddersc(3)
4676
4677         escloci=-(dlog(escloc_i)-emin)
4678         do j=1,3
4679           dersc(j)=dersc(j)/escloc_i
4680         enddo
4681         if (mixed) then
4682           do j=1,3,2
4683             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4684           enddo
4685         endif
4686       return
4687       end
4688 C------------------------------------------------------------------------------
4689       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4690       implicit real*8 (a-h,o-z)
4691       include 'DIMENSIONS'
4692       include 'COMMON.GEO'
4693       include 'COMMON.LOCAL'
4694       include 'COMMON.IOUNITS'
4695       common /sccalc/ time11,time12,time112,theti,it,nlobit
4696       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4697       double precision contr(maxlob)
4698       logical mixed
4699
4700       escloc_i=0.0D0
4701
4702       do j=1,3
4703         dersc(j)=0.0D0
4704       enddo
4705
4706       do j=1,nlobit
4707         do k=1,2
4708           z(k)=x(k)-censc(k,j,it)
4709         enddo
4710         z(3)=dwapi
4711         do k=1,3
4712           Axk=0.0D0
4713           do l=1,3
4714             Axk=Axk+gaussc(l,k,j,it)*z(l)
4715           enddo
4716           Ax(k,j)=Axk
4717         enddo
4718         expfac=0.0D0
4719         do k=1,3
4720           expfac=expfac+Ax(k,j)*z(k)
4721         enddo
4722         contr(j)=expfac
4723       enddo ! j
4724
4725 C As in the case of ebend, we want to avoid underflows in exponentiation and
4726 C subsequent NaNs and INFs in energy calculation.
4727 C Find the largest exponent
4728       emin=contr(1)
4729       do j=1,nlobit
4730         if (emin.gt.contr(j)) emin=contr(j)
4731       enddo
4732       emin=0.5D0*emin
4733
4734 C Compute the contribution to SC energy and derivatives
4735
4736       dersc12=0.0d0
4737       do j=1,nlobit
4738         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4739         escloc_i=escloc_i+expfac
4740         do k=1,2
4741           dersc(k)=dersc(k)+Ax(k,j)*expfac
4742         enddo
4743         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4744      &            +gaussc(1,2,j,it))*expfac
4745         dersc(3)=0.0d0
4746       enddo
4747
4748       dersc(1)=dersc(1)/cos(theti)**2
4749       dersc12=dersc12/cos(theti)**2
4750       escloci=-(dlog(escloc_i)-emin)
4751       do j=1,2
4752         dersc(j)=dersc(j)/escloc_i
4753       enddo
4754       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4755       return
4756       end
4757 #else
4758 c----------------------------------------------------------------------------------
4759       subroutine esc(escloc)
4760 C Calculate the local energy of a side chain and its derivatives in the
4761 C corresponding virtual-bond valence angles THETA and the spherical angles
4762 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4763 C added by Urszula Kozlowska. 07/11/2007
4764 C
4765       implicit real*8 (a-h,o-z)
4766       include 'DIMENSIONS'
4767       include 'COMMON.GEO'
4768       include 'COMMON.LOCAL'
4769       include 'COMMON.VAR'
4770       include 'COMMON.SCROT'
4771       include 'COMMON.INTERACT'
4772       include 'COMMON.DERIV'
4773       include 'COMMON.CHAIN'
4774       include 'COMMON.IOUNITS'
4775       include 'COMMON.NAMES'
4776       include 'COMMON.FFIELD'
4777       include 'COMMON.CONTROL'
4778       include 'COMMON.VECTORS'
4779       double precision x_prime(3),y_prime(3),z_prime(3)
4780      &    , sumene,dsc_i,dp2_i,x(65),
4781      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4782      &    de_dxx,de_dyy,de_dzz,de_dt
4783       double precision s1_t,s1_6_t,s2_t,s2_6_t
4784       double precision
4785      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4786      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4787      & dt_dCi(3),dt_dCi1(3)
4788       common /sccalc/ time11,time12,time112,theti,it,nlobit
4789       delta=0.02d0*pi
4790       escloc=0.0D0
4791       do i=loc_start,loc_end
4792         costtab(i+1) =dcos(theta(i+1))
4793         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4794         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4795         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4796         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4797         cosfac=dsqrt(cosfac2)
4798         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4799         sinfac=dsqrt(sinfac2)
4800         it=itype(i)
4801         if (it.eq.10) goto 1
4802 c
4803 C  Compute the axes of tghe local cartesian coordinates system; store in
4804 c   x_prime, y_prime and z_prime
4805 c
4806         do j=1,3
4807           x_prime(j) = 0.00
4808           y_prime(j) = 0.00
4809           z_prime(j) = 0.00
4810         enddo
4811 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4812 C     &   dc_norm(3,i+nres)
4813         do j = 1,3
4814           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4815           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4816         enddo
4817         do j = 1,3
4818           z_prime(j) = -uz(j,i-1)
4819         enddo
4820 c       write (2,*) "i",i
4821 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4822 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4823 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4824 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4825 c      & " xy",scalar(x_prime(1),y_prime(1)),
4826 c      & " xz",scalar(x_prime(1),z_prime(1)),
4827 c      & " yy",scalar(y_prime(1),y_prime(1)),
4828 c      & " yz",scalar(y_prime(1),z_prime(1)),
4829 c      & " zz",scalar(z_prime(1),z_prime(1))
4830 c
4831 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4832 C to local coordinate system. Store in xx, yy, zz.
4833 c
4834         xx=0.0d0
4835         yy=0.0d0
4836         zz=0.0d0
4837         do j = 1,3
4838           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4839           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4840           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4841         enddo
4842
4843         xxtab(i)=xx
4844         yytab(i)=yy
4845         zztab(i)=zz
4846 C
4847 C Compute the energy of the ith side cbain
4848 C
4849 c        write (2,*) "xx",xx," yy",yy," zz",zz
4850         it=itype(i)
4851         do j = 1,65
4852           x(j) = sc_parmin(j,it)
4853         enddo
4854 #ifdef CHECK_COORD
4855 Cc diagnostics - remove later
4856         xx1 = dcos(alph(2))
4857         yy1 = dsin(alph(2))*dcos(omeg(2))
4858         zz1 = -dsin(alph(2))*dsin(omeg(2))
4859         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4860      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4861      &    xx1,yy1,zz1
4862 C,"  --- ", xx_w,yy_w,zz_w
4863 c end diagnostics
4864 #endif
4865         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4866      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4867      &   + x(10)*yy*zz
4868         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4869      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4870      & + x(20)*yy*zz
4871         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4872      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4873      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4874      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4875      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4876      &  +x(40)*xx*yy*zz
4877         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4878      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4879      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4880      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4881      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4882      &  +x(60)*xx*yy*zz
4883         dsc_i   = 0.743d0+x(61)
4884         dp2_i   = 1.9d0+x(62)
4885         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4886      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4887         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4888      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4889         s1=(1+x(63))/(0.1d0 + dscp1)
4890         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4891         s2=(1+x(65))/(0.1d0 + dscp2)
4892         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4893         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4894      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4895 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4896 c     &   sumene4,
4897 c     &   dscp1,dscp2,sumene
4898 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4899         escloc = escloc + sumene
4900 c        write (2,*) "i",i," escloc",sumene,escloc
4901 #ifdef DEBUG
4902 C
4903 C This section to check the numerical derivatives of the energy of ith side
4904 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4905 C #define DEBUG in the code to turn it on.
4906 C
4907         write (2,*) "sumene               =",sumene
4908         aincr=1.0d-7
4909         xxsave=xx
4910         xx=xx+aincr
4911         write (2,*) xx,yy,zz
4912         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4913         de_dxx_num=(sumenep-sumene)/aincr
4914         xx=xxsave
4915         write (2,*) "xx+ sumene from enesc=",sumenep
4916         yysave=yy
4917         yy=yy+aincr
4918         write (2,*) xx,yy,zz
4919         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4920         de_dyy_num=(sumenep-sumene)/aincr
4921         yy=yysave
4922         write (2,*) "yy+ sumene from enesc=",sumenep
4923         zzsave=zz
4924         zz=zz+aincr
4925         write (2,*) xx,yy,zz
4926         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4927         de_dzz_num=(sumenep-sumene)/aincr
4928         zz=zzsave
4929         write (2,*) "zz+ sumene from enesc=",sumenep
4930         costsave=cost2tab(i+1)
4931         sintsave=sint2tab(i+1)
4932         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4933         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4934         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4935         de_dt_num=(sumenep-sumene)/aincr
4936         write (2,*) " t+ sumene from enesc=",sumenep
4937         cost2tab(i+1)=costsave
4938         sint2tab(i+1)=sintsave
4939 C End of diagnostics section.
4940 #endif
4941 C
4942 C Compute the gradient of esc
4943 C
4944         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4945         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4946         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4947         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4948         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4949         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4950         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4951         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4952         pom1=(sumene3*sint2tab(i+1)+sumene1)
4953      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4954         pom2=(sumene4*cost2tab(i+1)+sumene2)
4955      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4956         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4957         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4958      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4959      &  +x(40)*yy*zz
4960         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4961         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4962      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4963      &  +x(60)*yy*zz
4964         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4965      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4966      &        +(pom1+pom2)*pom_dx
4967 #ifdef DEBUG
4968         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4969 #endif
4970 C
4971         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4972         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4973      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4974      &  +x(40)*xx*zz
4975         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4976         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4977      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4978      &  +x(59)*zz**2 +x(60)*xx*zz
4979         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4980      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4981      &        +(pom1-pom2)*pom_dy
4982 #ifdef DEBUG
4983         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4984 #endif
4985 C
4986         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4987      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4988      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4989      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4990      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4991      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4992      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4993      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4994 #ifdef DEBUG
4995         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4996 #endif
4997 C
4998         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4999      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5000      &  +pom1*pom_dt1+pom2*pom_dt2
5001 #ifdef DEBUG
5002         write(2,*), "de_dt = ", de_dt,de_dt_num
5003 #endif
5004 c
5005 C
5006        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5007        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5008        cosfac2xx=cosfac2*xx
5009        sinfac2yy=sinfac2*yy
5010        do k = 1,3
5011          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5012      &      vbld_inv(i+1)
5013          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5014      &      vbld_inv(i)
5015          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5016          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5017 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5018 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5019 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5020 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5021          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5022          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5023          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5024          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5025          dZZ_Ci1(k)=0.0d0
5026          dZZ_Ci(k)=0.0d0
5027          do j=1,3
5028            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5029            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5030          enddo
5031
5032          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5033          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5034          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5035 c
5036          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5037          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5038        enddo
5039
5040        do k=1,3
5041          dXX_Ctab(k,i)=dXX_Ci(k)
5042          dXX_C1tab(k,i)=dXX_Ci1(k)
5043          dYY_Ctab(k,i)=dYY_Ci(k)
5044          dYY_C1tab(k,i)=dYY_Ci1(k)
5045          dZZ_Ctab(k,i)=dZZ_Ci(k)
5046          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5047          dXX_XYZtab(k,i)=dXX_XYZ(k)
5048          dYY_XYZtab(k,i)=dYY_XYZ(k)
5049          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5050        enddo
5051
5052        do k = 1,3
5053 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5054 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5055 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5056 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5057 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5058 c     &    dt_dci(k)
5059 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5060 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5061          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5062      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5063          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5064      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5065          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5066      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5067        enddo
5068 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5069 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5070
5071 C to check gradient call subroutine check_grad
5072
5073     1 continue
5074       enddo
5075       return
5076       end
5077 c------------------------------------------------------------------------------
5078       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5079       implicit none
5080       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5081      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5082       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5083      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5084      &   + x(10)*yy*zz
5085       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5086      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5087      & + x(20)*yy*zz
5088       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5089      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5090      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5091      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5092      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5093      &  +x(40)*xx*yy*zz
5094       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5095      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5096      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5097      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5098      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5099      &  +x(60)*xx*yy*zz
5100       dsc_i   = 0.743d0+x(61)
5101       dp2_i   = 1.9d0+x(62)
5102       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5103      &          *(xx*cost2+yy*sint2))
5104       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5105      &          *(xx*cost2-yy*sint2))
5106       s1=(1+x(63))/(0.1d0 + dscp1)
5107       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5108       s2=(1+x(65))/(0.1d0 + dscp2)
5109       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5110       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5111      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5112       enesc=sumene
5113       return
5114       end
5115 #endif
5116 c------------------------------------------------------------------------------
5117       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5118 C
5119 C This procedure calculates two-body contact function g(rij) and its derivative:
5120 C
5121 C           eps0ij                                     !       x < -1
5122 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5123 C            0                                         !       x > 1
5124 C
5125 C where x=(rij-r0ij)/delta
5126 C
5127 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5128 C
5129       implicit none
5130       double precision rij,r0ij,eps0ij,fcont,fprimcont
5131       double precision x,x2,x4,delta
5132 c     delta=0.02D0*r0ij
5133 c      delta=0.2D0*r0ij
5134       x=(rij-r0ij)/delta
5135       if (x.lt.-1.0D0) then
5136         fcont=eps0ij
5137         fprimcont=0.0D0
5138       else if (x.le.1.0D0) then
5139         x2=x*x
5140         x4=x2*x2
5141         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5142         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5143       else
5144         fcont=0.0D0
5145         fprimcont=0.0D0
5146       endif
5147       return
5148       end
5149 c------------------------------------------------------------------------------
5150       subroutine splinthet(theti,delta,ss,ssder)
5151       implicit real*8 (a-h,o-z)
5152       include 'DIMENSIONS'
5153       include 'COMMON.VAR'
5154       include 'COMMON.GEO'
5155       thetup=pi-delta
5156       thetlow=delta
5157       if (theti.gt.pipol) then
5158         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5159       else
5160         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5161         ssder=-ssder
5162       endif
5163       return
5164       end
5165 c------------------------------------------------------------------------------
5166       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5167       implicit none
5168       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5169       double precision ksi,ksi2,ksi3,a1,a2,a3
5170       a1=fprim0*delta/(f1-f0)
5171       a2=3.0d0-2.0d0*a1
5172       a3=a1-2.0d0
5173       ksi=(x-x0)/delta
5174       ksi2=ksi*ksi
5175       ksi3=ksi2*ksi
5176       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5177       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5178       return
5179       end
5180 c------------------------------------------------------------------------------
5181       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5182       implicit none
5183       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5184       double precision ksi,ksi2,ksi3,a1,a2,a3
5185       ksi=(x-x0)/delta
5186       ksi2=ksi*ksi
5187       ksi3=ksi2*ksi
5188       a1=fprim0x*delta
5189       a2=3*(f1x-f0x)-2*fprim0x*delta
5190       a3=fprim0x*delta-2*(f1x-f0x)
5191       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5192       return
5193       end
5194 C-----------------------------------------------------------------------------
5195 #ifdef CRYST_TOR
5196 C-----------------------------------------------------------------------------
5197       subroutine etor(etors,edihcnstr)
5198       implicit real*8 (a-h,o-z)
5199       include 'DIMENSIONS'
5200       include 'COMMON.VAR'
5201       include 'COMMON.GEO'
5202       include 'COMMON.LOCAL'
5203       include 'COMMON.TORSION'
5204       include 'COMMON.INTERACT'
5205       include 'COMMON.DERIV'
5206       include 'COMMON.CHAIN'
5207       include 'COMMON.NAMES'
5208       include 'COMMON.IOUNITS'
5209       include 'COMMON.FFIELD'
5210       include 'COMMON.TORCNSTR'
5211       include 'COMMON.CONTROL'
5212       logical lprn
5213 C Set lprn=.true. for debugging
5214       lprn=.false.
5215 c      lprn=.true.
5216       etors=0.0D0
5217       do i=iphi_start,iphi_end
5218       etors_ii=0.0D0
5219         itori=itortyp(itype(i-2))
5220         itori1=itortyp(itype(i-1))
5221         phii=phi(i)
5222         gloci=0.0D0
5223 C Proline-Proline pair is a special case...
5224         if (itori.eq.3 .and. itori1.eq.3) then
5225           if (phii.gt.-dwapi3) then
5226             cosphi=dcos(3*phii)
5227             fac=1.0D0/(1.0D0-cosphi)
5228             etorsi=v1(1,3,3)*fac
5229             etorsi=etorsi+etorsi
5230             etors=etors+etorsi-v1(1,3,3)
5231             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5232             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5233           endif
5234           do j=1,3
5235             v1ij=v1(j+1,itori,itori1)
5236             v2ij=v2(j+1,itori,itori1)
5237             cosphi=dcos(j*phii)
5238             sinphi=dsin(j*phii)
5239             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5240             if (energy_dec) etors_ii=etors_ii+
5241      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5242             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5243           enddo
5244         else
5245           do j=1,nterm_old
5246             v1ij=v1(j,itori,itori1)
5247             v2ij=v2(j,itori,itori1)
5248             cosphi=dcos(j*phii)
5249             sinphi=dsin(j*phii)
5250             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5251             if (energy_dec) etors_ii=etors_ii+
5252      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5253             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5254           enddo
5255         endif
5256         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5257              'etor',i,etors_ii
5258         if (lprn)
5259      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5260      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5261      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5262         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5263 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5264       enddo
5265 ! 6/20/98 - dihedral angle constraints
5266       edihcnstr=0.0d0
5267       do i=1,ndih_constr
5268         itori=idih_constr(i)
5269         phii=phi(itori)
5270         difi=phii-phi0(i)
5271         if (difi.gt.drange(i)) then
5272           difi=difi-drange(i)
5273           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5274           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5275         else if (difi.lt.-drange(i)) then
5276           difi=difi+drange(i)
5277           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5278           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5279         endif
5280 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5281 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5282       enddo
5283 !      write (iout,*) 'edihcnstr',edihcnstr
5284       return
5285       end
5286 c------------------------------------------------------------------------------
5287       subroutine etor_d(etors_d)
5288       etors_d=0.0d0
5289       return
5290       end
5291 c----------------------------------------------------------------------------
5292 #else
5293       subroutine etor(etors,edihcnstr)
5294       implicit real*8 (a-h,o-z)
5295       include 'DIMENSIONS'
5296       include 'COMMON.VAR'
5297       include 'COMMON.GEO'
5298       include 'COMMON.LOCAL'
5299       include 'COMMON.TORSION'
5300       include 'COMMON.INTERACT'
5301       include 'COMMON.DERIV'
5302       include 'COMMON.CHAIN'
5303       include 'COMMON.NAMES'
5304       include 'COMMON.IOUNITS'
5305       include 'COMMON.FFIELD'
5306       include 'COMMON.TORCNSTR'
5307       include 'COMMON.CONTROL'
5308       logical lprn
5309 C Set lprn=.true. for debugging
5310       lprn=.false.
5311 c     lprn=.true.
5312       etors=0.0D0
5313       do i=iphi_start,iphi_end
5314       etors_ii=0.0D0
5315         itori=itortyp(itype(i-2))
5316         itori1=itortyp(itype(i-1))
5317         phii=phi(i)
5318         gloci=0.0D0
5319 C Regular cosine and sine terms
5320         do j=1,nterm(itori,itori1)
5321           v1ij=v1(j,itori,itori1)
5322           v2ij=v2(j,itori,itori1)
5323           cosphi=dcos(j*phii)
5324           sinphi=dsin(j*phii)
5325           etors=etors+v1ij*cosphi+v2ij*sinphi
5326           if (energy_dec) etors_ii=etors_ii+
5327      &                v1ij*cosphi+v2ij*sinphi
5328           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5329         enddo
5330 C Lorentz terms
5331 C                         v1
5332 C  E = SUM ----------------------------------- - v1
5333 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5334 C
5335         cosphi=dcos(0.5d0*phii)
5336         sinphi=dsin(0.5d0*phii)
5337         do j=1,nlor(itori,itori1)
5338           vl1ij=vlor1(j,itori,itori1)
5339           vl2ij=vlor2(j,itori,itori1)
5340           vl3ij=vlor3(j,itori,itori1)
5341           pom=vl2ij*cosphi+vl3ij*sinphi
5342           pom1=1.0d0/(pom*pom+1.0d0)
5343           etors=etors+vl1ij*pom1
5344           if (energy_dec) etors_ii=etors_ii+
5345      &                vl1ij*pom1
5346           pom=-pom*pom1*pom1
5347           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5348         enddo
5349 C Subtract the constant term
5350         etors=etors-v0(itori,itori1)
5351           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5352      &         'etor',i,etors_ii-v0(itori,itori1)
5353         if (lprn)
5354      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5355      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5356      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5357         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5358 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5359       enddo
5360 ! 6/20/98 - dihedral angle constraints
5361       edihcnstr=0.0d0
5362 c      do i=1,ndih_constr
5363       do i=idihconstr_start,idihconstr_end
5364         itori=idih_constr(i)
5365         phii=phi(itori)
5366         difi=pinorm(phii-phi0(i))
5367         if (difi.gt.drange(i)) then
5368           difi=difi-drange(i)
5369           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5370           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5371         else if (difi.lt.-drange(i)) then
5372           difi=difi+drange(i)
5373           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5374           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5375         else
5376           difi=0.0
5377         endif
5378 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5379 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5380 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5381       enddo
5382 cd       write (iout,*) 'edihcnstr',edihcnstr
5383       return
5384       end
5385 c----------------------------------------------------------------------------
5386       subroutine etor_d(etors_d)
5387 C 6/23/01 Compute double torsional energy
5388       implicit real*8 (a-h,o-z)
5389       include 'DIMENSIONS'
5390       include 'COMMON.VAR'
5391       include 'COMMON.GEO'
5392       include 'COMMON.LOCAL'
5393       include 'COMMON.TORSION'
5394       include 'COMMON.INTERACT'
5395       include 'COMMON.DERIV'
5396       include 'COMMON.CHAIN'
5397       include 'COMMON.NAMES'
5398       include 'COMMON.IOUNITS'
5399       include 'COMMON.FFIELD'
5400       include 'COMMON.TORCNSTR'
5401       logical lprn
5402 C Set lprn=.true. for debugging
5403       lprn=.false.
5404 c     lprn=.true.
5405       etors_d=0.0D0
5406       do i=iphid_start,iphid_end
5407         itori=itortyp(itype(i-2))
5408         itori1=itortyp(itype(i-1))
5409         itori2=itortyp(itype(i))
5410         phii=phi(i)
5411         phii1=phi(i+1)
5412         gloci1=0.0D0
5413         gloci2=0.0D0
5414 C Regular cosine and sine terms
5415         do j=1,ntermd_1(itori,itori1,itori2)
5416           v1cij=v1c(1,j,itori,itori1,itori2)
5417           v1sij=v1s(1,j,itori,itori1,itori2)
5418           v2cij=v1c(2,j,itori,itori1,itori2)
5419           v2sij=v1s(2,j,itori,itori1,itori2)
5420           cosphi1=dcos(j*phii)
5421           sinphi1=dsin(j*phii)
5422           cosphi2=dcos(j*phii1)
5423           sinphi2=dsin(j*phii1)
5424           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5425      &     v2cij*cosphi2+v2sij*sinphi2
5426           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5427           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5428         enddo
5429         do k=2,ntermd_2(itori,itori1,itori2)
5430           do l=1,k-1
5431             v1cdij = v2c(k,l,itori,itori1,itori2)
5432             v2cdij = v2c(l,k,itori,itori1,itori2)
5433             v1sdij = v2s(k,l,itori,itori1,itori2)
5434             v2sdij = v2s(l,k,itori,itori1,itori2)
5435             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5436             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5437             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5438             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5439             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5440      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5441             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5442      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5443             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5444      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5445           enddo
5446         enddo
5447         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5448         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5449       enddo
5450       return
5451       end
5452 #endif
5453 c------------------------------------------------------------------------------
5454       subroutine eback_sc_corr(esccor)
5455 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5456 c        conformational states; temporarily implemented as differences
5457 c        between UNRES torsional potentials (dependent on three types of
5458 c        residues) and the torsional potentials dependent on all 20 types
5459 c        of residues computed from AM1  energy surfaces of terminally-blocked
5460 c        amino-acid residues.
5461       implicit real*8 (a-h,o-z)
5462       include 'DIMENSIONS'
5463       include 'COMMON.VAR'
5464       include 'COMMON.GEO'
5465       include 'COMMON.LOCAL'
5466       include 'COMMON.TORSION'
5467       include 'COMMON.SCCOR'
5468       include 'COMMON.INTERACT'
5469       include 'COMMON.DERIV'
5470       include 'COMMON.CHAIN'
5471       include 'COMMON.NAMES'
5472       include 'COMMON.IOUNITS'
5473       include 'COMMON.FFIELD'
5474       include 'COMMON.CONTROL'
5475       logical lprn
5476 C Set lprn=.true. for debugging
5477       lprn=.false.
5478 c      lprn=.true.
5479 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5480       esccor=0.0D0
5481       do i=iphi_start,iphi_end
5482         esccor_ii=0.0D0
5483         itori=itype(i-2)
5484         itori1=itype(i-1)
5485         phii=phi(i)
5486         gloci=0.0D0
5487         do j=1,nterm_sccor
5488           v1ij=v1sccor(j,itori,itori1)
5489           v2ij=v2sccor(j,itori,itori1)
5490           cosphi=dcos(j*phii)
5491           sinphi=dsin(j*phii)
5492           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5493           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5494         enddo
5495         if (lprn)
5496      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5497      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5498      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5499         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5500       enddo
5501       return
5502       end
5503 c----------------------------------------------------------------------------
5504       subroutine multibody(ecorr)
5505 C This subroutine calculates multi-body contributions to energy following
5506 C the idea of Skolnick et al. If side chains I and J make a contact and
5507 C at the same time side chains I+1 and J+1 make a contact, an extra
5508 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5509       implicit real*8 (a-h,o-z)
5510       include 'DIMENSIONS'
5511       include 'COMMON.IOUNITS'
5512       include 'COMMON.DERIV'
5513       include 'COMMON.INTERACT'
5514       include 'COMMON.CONTACTS'
5515       double precision gx(3),gx1(3)
5516       logical lprn
5517
5518 C Set lprn=.true. for debugging
5519       lprn=.false.
5520
5521       if (lprn) then
5522         write (iout,'(a)') 'Contact function values:'
5523         do i=nnt,nct-2
5524           write (iout,'(i2,20(1x,i2,f10.5))')
5525      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5526         enddo
5527       endif
5528       ecorr=0.0D0
5529       do i=nnt,nct
5530         do j=1,3
5531           gradcorr(j,i)=0.0D0
5532           gradxorr(j,i)=0.0D0
5533         enddo
5534       enddo
5535       do i=nnt,nct-2
5536
5537         DO ISHIFT = 3,4
5538
5539         i1=i+ishift
5540         num_conti=num_cont(i)
5541         num_conti1=num_cont(i1)
5542         do jj=1,num_conti
5543           j=jcont(jj,i)
5544           do kk=1,num_conti1
5545             j1=jcont(kk,i1)
5546             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5547 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5548 cd   &                   ' ishift=',ishift
5549 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5550 C The system gains extra energy.
5551               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5552             endif   ! j1==j+-ishift
5553           enddo     ! kk
5554         enddo       ! jj
5555
5556         ENDDO ! ISHIFT
5557
5558       enddo         ! i
5559       return
5560       end
5561 c------------------------------------------------------------------------------
5562       double precision function esccorr(i,j,k,l,jj,kk)
5563       implicit real*8 (a-h,o-z)
5564       include 'DIMENSIONS'
5565       include 'COMMON.IOUNITS'
5566       include 'COMMON.DERIV'
5567       include 'COMMON.INTERACT'
5568       include 'COMMON.CONTACTS'
5569       double precision gx(3),gx1(3)
5570       logical lprn
5571       lprn=.false.
5572       eij=facont(jj,i)
5573       ekl=facont(kk,k)
5574 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5575 C Calculate the multi-body contribution to energy.
5576 C Calculate multi-body contributions to the gradient.
5577 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5578 cd   & k,l,(gacont(m,kk,k),m=1,3)
5579       do m=1,3
5580         gx(m) =ekl*gacont(m,jj,i)
5581         gx1(m)=eij*gacont(m,kk,k)
5582         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5583         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5584         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5585         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5586       enddo
5587       do m=i,j-1
5588         do ll=1,3
5589           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5590         enddo
5591       enddo
5592       do m=k,l-1
5593         do ll=1,3
5594           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5595         enddo
5596       enddo
5597       esccorr=-eij*ekl
5598       return
5599       end
5600 c------------------------------------------------------------------------------
5601 #ifdef MPI
5602       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5603       implicit real*8 (a-h,o-z)
5604       include 'DIMENSIONS'
5605       integer dimen1,dimen2,atom,indx
5606       double precision buffer(dimen1,dimen2)
5607       double precision zapas
5608       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5609      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5610      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5611      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5612       num_kont=num_cont_hb(atom)
5613       do i=1,num_kont
5614         do k=1,8
5615           do j=1,3
5616             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5617           enddo ! j
5618         enddo ! k
5619         buffer(i,indx+25)=facont_hb(i,atom)
5620         buffer(i,indx+26)=ees0p(i,atom)
5621         buffer(i,indx+27)=ees0m(i,atom)
5622         buffer(i,indx+28)=d_cont(i,atom)
5623         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
5624       enddo ! i
5625       buffer(1,indx+30)=dfloat(num_kont)
5626       return
5627       end
5628 c------------------------------------------------------------------------------
5629       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5630       implicit real*8 (a-h,o-z)
5631       include 'DIMENSIONS'
5632       integer dimen1,dimen2,atom,indx
5633       double precision buffer(dimen1,dimen2)
5634       double precision zapas
5635       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5636      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5637      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5638      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5639       num_kont=buffer(1,indx+30)
5640       num_kont_old=num_cont_hb(atom)
5641       num_cont_hb(atom)=num_kont+num_kont_old
5642       do i=1,num_kont
5643         ii=i+num_kont_old
5644         do k=1,8
5645           do j=1,3
5646             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5647           enddo ! j
5648         enddo ! k
5649         facont_hb(ii,atom)=buffer(i,indx+25)
5650         ees0p(ii,atom)=buffer(i,indx+26)
5651         ees0m(ii,atom)=buffer(i,indx+27)
5652         d_cont(i,atom)=buffer(i,indx+28)
5653         jcont_hb(ii,atom)=buffer(i,indx+29)
5654       enddo ! i
5655       return
5656       end
5657 c------------------------------------------------------------------------------
5658 #endif
5659       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5660 C This subroutine calculates multi-body contributions to hydrogen-bonding
5661       implicit real*8 (a-h,o-z)
5662       include 'DIMENSIONS'
5663       include 'COMMON.IOUNITS'
5664 #ifdef MPI
5665       include "mpif.h"
5666       parameter (max_cont=maxconts)
5667       parameter (max_dim=2*(8*3+6))
5668       parameter (msglen1=max_cont*max_dim)
5669       parameter (msglen2=2*msglen1)
5670       integer source,CorrelType,CorrelID,Error
5671       double precision buffer(max_cont,max_dim)
5672       integer status(MPI_STATUS_SIZE)
5673 #endif
5674       include 'COMMON.SETUP'
5675       include 'COMMON.FFIELD'
5676       include 'COMMON.DERIV'
5677       include 'COMMON.INTERACT'
5678       include 'COMMON.CONTACTS'
5679       include 'COMMON.CONTROL'
5680       double precision gx(3),gx1(3),time00
5681       logical lprn,ldone
5682
5683 C Set lprn=.true. for debugging
5684       lprn=.false.
5685 #ifdef MPI
5686       n_corr=0
5687       n_corr1=0
5688       if (nfgtasks.le.1) goto 30
5689       if (lprn) then
5690         write (iout,'(a)') 'Contact function values:'
5691         do i=nnt,nct-2
5692           write (iout,'(2i3,50(1x,i2,f5.2))')
5693      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5694      &    j=1,num_cont_hb(i))
5695         enddo
5696       endif
5697 C Caution! Following code assumes that electrostatic interactions concerning
5698 C a given atom are split among at most two processors!
5699       CorrelType=477
5700       CorrelID=fg_rank+1
5701       ldone=.false.
5702       do i=1,max_cont
5703         do j=1,max_dim
5704           buffer(i,j)=0.0D0
5705         enddo
5706       enddo
5707       mm=mod(fg_rank,2)
5708 c      write (*,*) 'MyRank',MyRank,' mm',mm
5709       if (mm) 20,20,10
5710    10 continue
5711 c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5712       if (fg_rank.gt.0) then
5713 C Send correlation contributions to the preceding processor
5714         msglen=msglen1
5715         nn=num_cont_hb(iatel_s)
5716         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5717 c        write (*,*) 'The BUFFER array:'
5718 c        do i=1,nn
5719 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5720 c        enddo
5721         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5722           msglen=msglen2
5723           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5724 C Clear the contacts of the atom passed to the neighboring processor
5725         nn=num_cont_hb(iatel_s+1)
5726 c        do i=1,nn
5727 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5728 c        enddo
5729             num_cont_hb(iatel_s)=0
5730         endif
5731 cd      write (iout,*) 'Processor ',fg_rank,MyRank,
5732 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5733 cd   & ' msglen=',msglen
5734 c        write (*,*) 'Processor ',fg_rank,MyRank,
5735 c     & ' is sending correlation contribution to processor',fg_rank-1,
5736 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5737         time00=MPI_Wtime()
5738         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5739      &    CorrelType,FG_COMM,IERROR)
5740         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5741 cd      write (iout,*) 'Processor ',fg_rank,
5742 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5743 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5744 c        write (*,*) 'Processor ',fg_rank,
5745 c     & ' has sent correlation contribution to processor',fg_rank-1,
5746 c     & ' msglen=',msglen,' CorrelID=',CorrelID
5747 c        msglen=msglen1
5748       endif ! (fg_rank.gt.0)
5749       if (ldone) goto 30
5750       ldone=.true.
5751    20 continue
5752 c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5753       if (fg_rank.lt.nfgtasks-1) then
5754 C Receive correlation contributions from the next processor
5755         msglen=msglen1
5756         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5757 cd      write (iout,*) 'Processor',fg_rank,
5758 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5759 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5760 c        write (*,*) 'Processor',fg_rank,
5761 c     &' is receiving correlation contribution from processor',fg_rank+1,
5762 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5763         time00=MPI_Wtime()
5764         nbytes=-1
5765         do while (nbytes.le.0)
5766           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5767           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5768         enddo
5769 c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
5770         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5771      &    fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5772         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5773 c        write (*,*) 'Processor',fg_rank,
5774 c     &' has received correlation contribution from processor',fg_rank+1,
5775 c     & ' msglen=',msglen,' nbytes=',nbytes
5776 c        write (*,*) 'The received BUFFER array:'
5777 c        do i=1,max_cont
5778 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
5779 c        enddo
5780         if (msglen.eq.msglen1) then
5781           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5782         else if (msglen.eq.msglen2)  then
5783           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5784           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5785         else
5786           write (iout,*)
5787      & 'ERROR!!!! message length changed while processing correlations.'
5788           write (*,*)
5789      & 'ERROR!!!! message length changed while processing correlations.'
5790           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5791         endif ! msglen.eq.msglen1
5792       endif ! fg_rank.lt.nfgtasks-1
5793       if (ldone) goto 30
5794       ldone=.true.
5795       goto 10
5796    30 continue
5797 #endif
5798       if (lprn) then
5799         write (iout,'(a)') 'Contact function values:'
5800         do i=nnt,nct-2
5801           write (iout,'(2i3,50(1x,i2,f5.2))')
5802      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5803      &    j=1,num_cont_hb(i))
5804         enddo
5805       endif
5806       ecorr=0.0D0
5807 C Remove the loop below after debugging !!!
5808       do i=nnt,nct
5809         do j=1,3
5810           gradcorr(j,i)=0.0D0
5811           gradxorr(j,i)=0.0D0
5812         enddo
5813       enddo
5814 C Calculate the local-electrostatic correlation terms
5815       do i=iatel_s,iatel_e+1
5816         i1=i+1
5817         num_conti=num_cont_hb(i)
5818         num_conti1=num_cont_hb(i+1)
5819         do jj=1,num_conti
5820           j=jcont_hb(jj,i)
5821           do kk=1,num_conti1
5822             j1=jcont_hb(kk,i1)
5823 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5824 c     &         ' jj=',jj,' kk=',kk
5825             if (j1.eq.j+1 .or. j1.eq.j-1) then
5826 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5827 C The system gains extra energy.
5828               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5829               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5830      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5831               n_corr=n_corr+1
5832             else if (j1.eq.j) then
5833 C Contacts I-J and I-(J+1) occur simultaneously.
5834 C The system loses extra energy.
5835 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5836             endif
5837           enddo ! kk
5838           do kk=1,num_conti
5839             j1=jcont_hb(kk,i)
5840 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5841 c    &         ' jj=',jj,' kk=',kk
5842             if (j1.eq.j+1) then
5843 C Contacts I-J and (I+1)-J occur simultaneously.
5844 C The system loses extra energy.
5845 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5846             endif ! j1==j+1
5847           enddo ! kk
5848         enddo ! jj
5849       enddo ! i
5850       return
5851       end
5852 c------------------------------------------------------------------------------
5853       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5854      &  n_corr1)
5855 C This subroutine calculates multi-body contributions to hydrogen-bonding
5856       implicit real*8 (a-h,o-z)
5857       include 'DIMENSIONS'
5858       include 'COMMON.IOUNITS'
5859 #ifdef MPI
5860       include 'mpif.h'
5861       parameter (max_cont=maxconts)
5862       parameter (max_dim=2*(8*3+6))
5863 c      parameter (msglen1=max_cont*max_dim*4)
5864       parameter (msglen1=max_cont*max_dim/2)
5865       parameter (msglen2=2*msglen1)
5866       integer source,CorrelType,CorrelID,Error
5867       double precision buffer(max_cont,max_dim)
5868       integer status(MPI_STATUS_SIZE)
5869 #endif
5870       include 'COMMON.SETUP'
5871       include 'COMMON.FFIELD'
5872       include 'COMMON.DERIV'
5873       include 'COMMON.INTERACT'
5874       include 'COMMON.CONTACTS'
5875       include 'COMMON.CONTROL'
5876       double precision gx(3),gx1(3)
5877       logical lprn,ldone
5878 C Set lprn=.true. for debugging
5879       lprn=.false.
5880       eturn6=0.0d0
5881 #ifdef MPI
5882       n_corr=0
5883       n_corr1=0
5884       if (fgProcs.le.1) goto 30
5885       if (lprn) then
5886         write (iout,'(a)') 'Contact function values:'
5887         do i=nnt,nct-2
5888           write (iout,'(2i3,50(1x,i2,f5.2))')
5889      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5890      &    j=1,num_cont_hb(i))
5891         enddo
5892       endif
5893 C Caution! Following code assumes that electrostatic interactions concerning
5894 C a given atom are split among at most two processors!
5895       CorrelType=477
5896       CorrelID=MyID+1
5897       ldone=.false.
5898       do i=1,max_cont
5899         do j=1,max_dim
5900           buffer(i,j)=0.0D0
5901         enddo
5902       enddo
5903       mm=mod(MyRank,2)
5904 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5905       if (mm) 20,20,10
5906    10 continue
5907 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5908       if (MyRank.gt.0) then
5909 C Send correlation contributions to the preceding processor
5910         msglen=msglen1
5911         nn=num_cont_hb(iatel_s)
5912         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5913 cd      write (iout,*) 'The BUFFER array:'
5914 cd      do i=1,nn
5915 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5916 cd      enddo
5917         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5918           msglen=msglen2
5919             call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5920 C Clear the contacts of the atom passed to the neighboring processor
5921         nn=num_cont_hb(iatel_s+1)
5922 cd      do i=1,nn
5923 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5924 cd      enddo
5925             num_cont_hb(iatel_s)=0
5926         endif
5927 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5928 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5929 cd   & ' msglen=',msglen
5930 cd      write (*,*) 'Processor ',MyID,MyRank,
5931 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5932 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5933         time00=MPI_Wtime()
5934         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5935      &     CorrelType,FG_COMM,IERROR)
5936         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5937 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5938 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5939 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5940 cd      write (*,*) 'Processor ',fg_rank,
5941 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5942 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5943         msglen=msglen1
5944       endif ! (MyRank.gt.0)
5945       if (ldone) goto 30
5946       ldone=.true.
5947    20 continue
5948 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5949       if (fg_rank.lt.nfgtasks-1) then
5950 C Receive correlation contributions from the next processor
5951         msglen=msglen1
5952         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5953 cd      write (iout,*) 'Processor',fg_rank,
5954 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5955 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5956 cd      write (*,*) 'Processor',fg_rank,
5957 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5958 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5959         time00=MPI_Wtime()
5960         nbytes=-1
5961         do while (nbytes.le.0)
5962           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5963           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5964         enddo
5965 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5966         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5967      &    fg_rank+1,CorrelType,status,IERROR)
5968         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5969 cd      write (iout,*) 'Processor',fg_rank,
5970 cd   & ' has received correlation contribution from processor',fg_rank+1,
5971 cd   & ' msglen=',msglen,' nbytes=',nbytes
5972 cd      write (iout,*) 'The received BUFFER array:'
5973 cd      do i=1,max_cont
5974 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5975 cd      enddo
5976         if (msglen.eq.msglen1) then
5977           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5978         else if (msglen.eq.msglen2)  then
5979           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5980           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5981         else
5982           write (iout,*)
5983      & 'ERROR!!!! message length changed while processing correlations.'
5984           write (*,*)
5985      & 'ERROR!!!! message length changed while processing correlations.'
5986           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5987         endif ! msglen.eq.msglen1
5988       endif ! fg_rank.lt.nfgtasks-1
5989       if (ldone) goto 30
5990       ldone=.true.
5991       goto 10
5992    30 continue
5993 #endif
5994       if (lprn) then
5995         write (iout,'(a)') 'Contact function values:'
5996         do i=nnt,nct-2
5997           write (iout,'(2i3,50(1x,i2,f5.2))')
5998      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5999      &    j=1,num_cont_hb(i))
6000         enddo
6001       endif
6002       ecorr=0.0D0
6003       ecorr5=0.0d0
6004       ecorr6=0.0d0
6005 C Remove the loop below after debugging !!!
6006       do i=nnt,nct
6007         do j=1,3
6008           gradcorr(j,i)=0.0D0
6009           gradxorr(j,i)=0.0D0
6010         enddo
6011       enddo
6012 C Calculate the dipole-dipole interaction energies
6013       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6014       do i=iatel_s,iatel_e+1
6015         num_conti=num_cont_hb(i)
6016         do jj=1,num_conti
6017           j=jcont_hb(jj,i)
6018 #ifdef MOMENT
6019           call dipole(i,j,jj)
6020 #endif
6021         enddo
6022       enddo
6023       endif
6024 C Calculate the local-electrostatic correlation terms
6025       do i=iatel_s,iatel_e+1
6026         i1=i+1
6027         num_conti=num_cont_hb(i)
6028         num_conti1=num_cont_hb(i+1)
6029         do jj=1,num_conti
6030           j=jcont_hb(jj,i)
6031           do kk=1,num_conti1
6032             j1=jcont_hb(kk,i1)
6033 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6034 c     &         ' jj=',jj,' kk=',kk
6035             if (j1.eq.j+1 .or. j1.eq.j-1) then
6036 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6037 C The system gains extra energy.
6038               n_corr=n_corr+1
6039               sqd1=dsqrt(d_cont(jj,i))
6040               sqd2=dsqrt(d_cont(kk,i1))
6041               sred_geom = sqd1*sqd2
6042               IF (sred_geom.lt.cutoff_corr) THEN
6043                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6044      &            ekont,fprimcont)
6045 cd               write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6046 cd     &         ' jj=',jj,' kk=',kk
6047                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6048                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6049                 do l=1,3
6050                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6051                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6052                 enddo
6053                 n_corr1=n_corr1+1
6054 cd               write (iout,*) 'sred_geom=',sred_geom,
6055 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6056                 call calc_eello(i,j,i+1,j1,jj,kk)
6057                 if (wcorr4.gt.0.0d0)
6058      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6059                   if (energy_dec.and.wcorr4.gt.0.0d0)
6060      1                 write (iout,'(a6,2i5,0pf7.3)')
6061      2                'ecorr4',i,j,eello4(i,j,i+1,j1,jj,kk)
6062                 if (wcorr5.gt.0.0d0)
6063      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6064                   if (energy_dec.and.wcorr5.gt.0.0d0)
6065      1                 write (iout,'(a6,2i5,0pf7.3)')
6066      2                'ecorr5',i,j,eello5(i,j,i+1,j1,jj,kk)
6067 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6068 cd                write(2,*)'ijkl',i,j,i+1,j1
6069                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6070      &               .or. wturn6.eq.0.0d0))then
6071 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6072                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6073                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6074      1                'ecorr6',i,j,eello6(i,j,i+1,j1,jj,kk)
6075 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6076 cd     &            'ecorr6=',ecorr6
6077 cd                write (iout,'(4e15.5)') sred_geom,
6078 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6079 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6080 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6081                 else if (wturn6.gt.0.0d0
6082      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6083 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6084                   eturn6=eturn6+eello_turn6(i,jj,kk)
6085                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6086      1                 'eturn6',i,j,eello_turn6(i,jj,kk)
6087 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6088                 endif
6089               ENDIF
6090 1111          continue
6091             else if (j1.eq.j) then
6092 C Contacts I-J and I-(J+1) occur simultaneously.
6093 C The system loses extra energy.
6094 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6095             endif
6096           enddo ! kk
6097           do kk=1,num_conti
6098             j1=jcont_hb(kk,i)
6099 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6100 c    &         ' jj=',jj,' kk=',kk
6101             if (j1.eq.j+1) then
6102 C Contacts I-J and (I+1)-J occur simultaneously.
6103 C The system loses extra energy.
6104 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6105             endif ! j1==j+1
6106           enddo ! kk
6107         enddo ! jj
6108       enddo ! i
6109       return
6110       end
6111 c------------------------------------------------------------------------------
6112       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6113       implicit real*8 (a-h,o-z)
6114       include 'DIMENSIONS'
6115       include 'COMMON.IOUNITS'
6116       include 'COMMON.DERIV'
6117       include 'COMMON.INTERACT'
6118       include 'COMMON.CONTACTS'
6119       double precision gx(3),gx1(3)
6120       logical lprn
6121       lprn=.false.
6122       eij=facont_hb(jj,i)
6123       ekl=facont_hb(kk,k)
6124       ees0pij=ees0p(jj,i)
6125       ees0pkl=ees0p(kk,k)
6126       ees0mij=ees0m(jj,i)
6127       ees0mkl=ees0m(kk,k)
6128       ekont=eij*ekl
6129       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6130 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6131 C Following 4 lines for diagnostics.
6132 cd    ees0pkl=0.0D0
6133 cd    ees0pij=1.0D0
6134 cd    ees0mkl=0.0D0
6135 cd    ees0mij=1.0D0
6136 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6137 c    &   ' and',k,l
6138 c     write (iout,*)'Contacts have occurred for peptide groups',
6139 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6140 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6141 C Calculate the multi-body contribution to energy.
6142       ecorr=ecorr+ekont*ees
6143 C Calculate multi-body contributions to the gradient.
6144       do ll=1,3
6145         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6146         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6147      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6148      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6149         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6150      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6151      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6152         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6153         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6154      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6155      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6156         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6157      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6158      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6159       enddo
6160       do m=i+1,j-1
6161         do ll=1,3
6162           gradcorr(ll,m)=gradcorr(ll,m)+
6163      &     ees*ekl*gacont_hbr(ll,jj,i)-
6164      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6165      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6166         enddo
6167       enddo
6168       do m=k+1,l-1
6169         do ll=1,3
6170           gradcorr(ll,m)=gradcorr(ll,m)+
6171      &     ees*eij*gacont_hbr(ll,kk,k)-
6172      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6173      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6174         enddo
6175       enddo
6176       ehbcorr=ekont*ees
6177       return
6178       end
6179 #ifdef MOMENT
6180 C---------------------------------------------------------------------------
6181       subroutine dipole(i,j,jj)
6182       implicit real*8 (a-h,o-z)
6183       include 'DIMENSIONS'
6184       include 'COMMON.IOUNITS'
6185       include 'COMMON.CHAIN'
6186       include 'COMMON.FFIELD'
6187       include 'COMMON.DERIV'
6188       include 'COMMON.INTERACT'
6189       include 'COMMON.CONTACTS'
6190       include 'COMMON.TORSION'
6191       include 'COMMON.VAR'
6192       include 'COMMON.GEO'
6193       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6194      &  auxmat(2,2)
6195       iti1 = itortyp(itype(i+1))
6196       if (j.lt.nres-1) then
6197         itj1 = itortyp(itype(j+1))
6198       else
6199         itj1=ntortyp+1
6200       endif
6201       do iii=1,2
6202         dipi(iii,1)=Ub2(iii,i)
6203         dipderi(iii)=Ub2der(iii,i)
6204         dipi(iii,2)=b1(iii,iti1)
6205         dipj(iii,1)=Ub2(iii,j)
6206         dipderj(iii)=Ub2der(iii,j)
6207         dipj(iii,2)=b1(iii,itj1)
6208       enddo
6209       kkk=0
6210       do iii=1,2
6211         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6212         do jjj=1,2
6213           kkk=kkk+1
6214           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6215         enddo
6216       enddo
6217       do kkk=1,5
6218         do lll=1,3
6219           mmm=0
6220           do iii=1,2
6221             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6222      &        auxvec(1))
6223             do jjj=1,2
6224               mmm=mmm+1
6225               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6226             enddo
6227           enddo
6228         enddo
6229       enddo
6230       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6231       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6232       do iii=1,2
6233         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6234       enddo
6235       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6236       do iii=1,2
6237         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6238       enddo
6239       return
6240       end
6241 #endif
6242 C---------------------------------------------------------------------------
6243       subroutine calc_eello(i,j,k,l,jj,kk)
6244 C
6245 C This subroutine computes matrices and vectors needed to calculate
6246 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6247 C
6248       implicit real*8 (a-h,o-z)
6249       include 'DIMENSIONS'
6250       include 'COMMON.IOUNITS'
6251       include 'COMMON.CHAIN'
6252       include 'COMMON.DERIV'
6253       include 'COMMON.INTERACT'
6254       include 'COMMON.CONTACTS'
6255       include 'COMMON.TORSION'
6256       include 'COMMON.VAR'
6257       include 'COMMON.GEO'
6258       include 'COMMON.FFIELD'
6259       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6260      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6261       logical lprn
6262       common /kutas/ lprn
6263 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6264 cd     & ' jj=',jj,' kk=',kk
6265 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6266       do iii=1,2
6267         do jjj=1,2
6268           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6269           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6270         enddo
6271       enddo
6272       call transpose2(aa1(1,1),aa1t(1,1))
6273       call transpose2(aa2(1,1),aa2t(1,1))
6274       do kkk=1,5
6275         do lll=1,3
6276           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6277      &      aa1tder(1,1,lll,kkk))
6278           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6279      &      aa2tder(1,1,lll,kkk))
6280         enddo
6281       enddo
6282       if (l.eq.j+1) then
6283 C parallel orientation of the two CA-CA-CA frames.
6284         if (i.gt.1) then
6285           iti=itortyp(itype(i))
6286         else
6287           iti=ntortyp+1
6288         endif
6289         itk1=itortyp(itype(k+1))
6290         itj=itortyp(itype(j))
6291         if (l.lt.nres-1) then
6292           itl1=itortyp(itype(l+1))
6293         else
6294           itl1=ntortyp+1
6295         endif
6296 C A1 kernel(j+1) A2T
6297 cd        do iii=1,2
6298 cd          write (iout,'(3f10.5,5x,3f10.5)')
6299 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6300 cd        enddo
6301         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6302      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6303      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6304 C Following matrices are needed only for 6-th order cumulants
6305         IF (wcorr6.gt.0.0d0) THEN
6306         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6307      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6308      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6309         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6310      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6311      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6312      &   ADtEAderx(1,1,1,1,1,1))
6313         lprn=.false.
6314         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6315      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6316      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6317      &   ADtEA1derx(1,1,1,1,1,1))
6318         ENDIF
6319 C End 6-th order cumulants
6320 cd        lprn=.false.
6321 cd        if (lprn) then
6322 cd        write (2,*) 'In calc_eello6'
6323 cd        do iii=1,2
6324 cd          write (2,*) 'iii=',iii
6325 cd          do kkk=1,5
6326 cd            write (2,*) 'kkk=',kkk
6327 cd            do jjj=1,2
6328 cd              write (2,'(3(2f10.5),5x)')
6329 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6330 cd            enddo
6331 cd          enddo
6332 cd        enddo
6333 cd        endif
6334         call transpose2(EUgder(1,1,k),auxmat(1,1))
6335         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6336         call transpose2(EUg(1,1,k),auxmat(1,1))
6337         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6338         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6339         do iii=1,2
6340           do kkk=1,5
6341             do lll=1,3
6342               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6343      &          EAEAderx(1,1,lll,kkk,iii,1))
6344             enddo
6345           enddo
6346         enddo
6347 C A1T kernel(i+1) A2
6348         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6349      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6350      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6351 C Following matrices are needed only for 6-th order cumulants
6352         IF (wcorr6.gt.0.0d0) THEN
6353         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6354      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6355      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6356         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6357      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6358      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6359      &   ADtEAderx(1,1,1,1,1,2))
6360         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6361      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6362      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6363      &   ADtEA1derx(1,1,1,1,1,2))
6364         ENDIF
6365 C End 6-th order cumulants
6366         call transpose2(EUgder(1,1,l),auxmat(1,1))
6367         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6368         call transpose2(EUg(1,1,l),auxmat(1,1))
6369         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6370         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6371         do iii=1,2
6372           do kkk=1,5
6373             do lll=1,3
6374               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6375      &          EAEAderx(1,1,lll,kkk,iii,2))
6376             enddo
6377           enddo
6378         enddo
6379 C AEAb1 and AEAb2
6380 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6381 C They are needed only when the fifth- or the sixth-order cumulants are
6382 C indluded.
6383         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6384         call transpose2(AEA(1,1,1),auxmat(1,1))
6385         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6386         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6387         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6388         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6389         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6390         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6391         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6392         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6393         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6394         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6395         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6396         call transpose2(AEA(1,1,2),auxmat(1,1))
6397         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6398         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6399         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6400         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6401         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6402         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6403         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6404         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6405         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6406         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6407         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6408 C Calculate the Cartesian derivatives of the vectors.
6409         do iii=1,2
6410           do kkk=1,5
6411             do lll=1,3
6412               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6413               call matvec2(auxmat(1,1),b1(1,iti),
6414      &          AEAb1derx(1,lll,kkk,iii,1,1))
6415               call matvec2(auxmat(1,1),Ub2(1,i),
6416      &          AEAb2derx(1,lll,kkk,iii,1,1))
6417               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6418      &          AEAb1derx(1,lll,kkk,iii,2,1))
6419               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6420      &          AEAb2derx(1,lll,kkk,iii,2,1))
6421               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6422               call matvec2(auxmat(1,1),b1(1,itj),
6423      &          AEAb1derx(1,lll,kkk,iii,1,2))
6424               call matvec2(auxmat(1,1),Ub2(1,j),
6425      &          AEAb2derx(1,lll,kkk,iii,1,2))
6426               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6427      &          AEAb1derx(1,lll,kkk,iii,2,2))
6428               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6429      &          AEAb2derx(1,lll,kkk,iii,2,2))
6430             enddo
6431           enddo
6432         enddo
6433         ENDIF
6434 C End vectors
6435       else
6436 C Antiparallel orientation of the two CA-CA-CA frames.
6437         if (i.gt.1) then
6438           iti=itortyp(itype(i))
6439         else
6440           iti=ntortyp+1
6441         endif
6442         itk1=itortyp(itype(k+1))
6443         itl=itortyp(itype(l))
6444         itj=itortyp(itype(j))
6445         if (j.lt.nres-1) then
6446           itj1=itortyp(itype(j+1))
6447         else
6448           itj1=ntortyp+1
6449         endif
6450 C A2 kernel(j-1)T A1T
6451         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6452      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6453      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6454 C Following matrices are needed only for 6-th order cumulants
6455         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6456      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6457         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6458      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6459      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6460         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6461      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6462      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6463      &   ADtEAderx(1,1,1,1,1,1))
6464         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6465      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6466      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6467      &   ADtEA1derx(1,1,1,1,1,1))
6468         ENDIF
6469 C End 6-th order cumulants
6470         call transpose2(EUgder(1,1,k),auxmat(1,1))
6471         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6472         call transpose2(EUg(1,1,k),auxmat(1,1))
6473         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6474         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6475         do iii=1,2
6476           do kkk=1,5
6477             do lll=1,3
6478               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6479      &          EAEAderx(1,1,lll,kkk,iii,1))
6480             enddo
6481           enddo
6482         enddo
6483 C A2T kernel(i+1)T A1
6484         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6485      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6486      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6487 C Following matrices are needed only for 6-th order cumulants
6488         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6489      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6490         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6491      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6492      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6493         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6494      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6495      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6496      &   ADtEAderx(1,1,1,1,1,2))
6497         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6498      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6499      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6500      &   ADtEA1derx(1,1,1,1,1,2))
6501         ENDIF
6502 C End 6-th order cumulants
6503         call transpose2(EUgder(1,1,j),auxmat(1,1))
6504         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6505         call transpose2(EUg(1,1,j),auxmat(1,1))
6506         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6507         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6508         do iii=1,2
6509           do kkk=1,5
6510             do lll=1,3
6511               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6512      &          EAEAderx(1,1,lll,kkk,iii,2))
6513             enddo
6514           enddo
6515         enddo
6516 C AEAb1 and AEAb2
6517 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6518 C They are needed only when the fifth- or the sixth-order cumulants are
6519 C indluded.
6520         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6521      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6522         call transpose2(AEA(1,1,1),auxmat(1,1))
6523         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6524         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6525         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6526         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6527         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6528         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6529         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6530         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6531         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6532         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6533         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6534         call transpose2(AEA(1,1,2),auxmat(1,1))
6535         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6536         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6537         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6538         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6539         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6540         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6541         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6542         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6543         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6544         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6545         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6546 C Calculate the Cartesian derivatives of the vectors.
6547         do iii=1,2
6548           do kkk=1,5
6549             do lll=1,3
6550               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6551               call matvec2(auxmat(1,1),b1(1,iti),
6552      &          AEAb1derx(1,lll,kkk,iii,1,1))
6553               call matvec2(auxmat(1,1),Ub2(1,i),
6554      &          AEAb2derx(1,lll,kkk,iii,1,1))
6555               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6556      &          AEAb1derx(1,lll,kkk,iii,2,1))
6557               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6558      &          AEAb2derx(1,lll,kkk,iii,2,1))
6559               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6560               call matvec2(auxmat(1,1),b1(1,itl),
6561      &          AEAb1derx(1,lll,kkk,iii,1,2))
6562               call matvec2(auxmat(1,1),Ub2(1,l),
6563      &          AEAb2derx(1,lll,kkk,iii,1,2))
6564               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6565      &          AEAb1derx(1,lll,kkk,iii,2,2))
6566               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6567      &          AEAb2derx(1,lll,kkk,iii,2,2))
6568             enddo
6569           enddo
6570         enddo
6571         ENDIF
6572 C End vectors
6573       endif
6574       return
6575       end
6576 C---------------------------------------------------------------------------
6577       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6578      &  KK,KKderg,AKA,AKAderg,AKAderx)
6579       implicit none
6580       integer nderg
6581       logical transp
6582       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6583      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6584      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6585       integer iii,kkk,lll
6586       integer jjj,mmm
6587       logical lprn
6588       common /kutas/ lprn
6589       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6590       do iii=1,nderg
6591         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6592      &    AKAderg(1,1,iii))
6593       enddo
6594 cd      if (lprn) write (2,*) 'In kernel'
6595       do kkk=1,5
6596 cd        if (lprn) write (2,*) 'kkk=',kkk
6597         do lll=1,3
6598           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6599      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6600 cd          if (lprn) then
6601 cd            write (2,*) 'lll=',lll
6602 cd            write (2,*) 'iii=1'
6603 cd            do jjj=1,2
6604 cd              write (2,'(3(2f10.5),5x)')
6605 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6606 cd            enddo
6607 cd          endif
6608           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6609      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6610 cd          if (lprn) then
6611 cd            write (2,*) 'lll=',lll
6612 cd            write (2,*) 'iii=2'
6613 cd            do jjj=1,2
6614 cd              write (2,'(3(2f10.5),5x)')
6615 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6616 cd            enddo
6617 cd          endif
6618         enddo
6619       enddo
6620       return
6621       end
6622 C---------------------------------------------------------------------------
6623       double precision function eello4(i,j,k,l,jj,kk)
6624       implicit real*8 (a-h,o-z)
6625       include 'DIMENSIONS'
6626       include 'COMMON.IOUNITS'
6627       include 'COMMON.CHAIN'
6628       include 'COMMON.DERIV'
6629       include 'COMMON.INTERACT'
6630       include 'COMMON.CONTACTS'
6631       include 'COMMON.TORSION'
6632       include 'COMMON.VAR'
6633       include 'COMMON.GEO'
6634       double precision pizda(2,2),ggg1(3),ggg2(3)
6635 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6636 cd        eello4=0.0d0
6637 cd        return
6638 cd      endif
6639 cd      print *,'eello4:',i,j,k,l,jj,kk
6640 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6641 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6642 cold      eij=facont_hb(jj,i)
6643 cold      ekl=facont_hb(kk,k)
6644 cold      ekont=eij*ekl
6645       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6646 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6647       gcorr_loc(k-1)=gcorr_loc(k-1)
6648      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6649       if (l.eq.j+1) then
6650         gcorr_loc(l-1)=gcorr_loc(l-1)
6651      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6652       else
6653         gcorr_loc(j-1)=gcorr_loc(j-1)
6654      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6655       endif
6656       do iii=1,2
6657         do kkk=1,5
6658           do lll=1,3
6659             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6660      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6661 cd            derx(lll,kkk,iii)=0.0d0
6662           enddo
6663         enddo
6664       enddo
6665 cd      gcorr_loc(l-1)=0.0d0
6666 cd      gcorr_loc(j-1)=0.0d0
6667 cd      gcorr_loc(k-1)=0.0d0
6668 cd      eel4=1.0d0
6669 cd      write (iout,*)'Contacts have occurred for peptide groups',
6670 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6671 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6672       if (j.lt.nres-1) then
6673         j1=j+1
6674         j2=j-1
6675       else
6676         j1=j-1
6677         j2=j-2
6678       endif
6679       if (l.lt.nres-1) then
6680         l1=l+1
6681         l2=l-1
6682       else
6683         l1=l-1
6684         l2=l-2
6685       endif
6686       do ll=1,3
6687 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6688         ggg1(ll)=eel4*g_contij(ll,1)
6689         ggg2(ll)=eel4*g_contij(ll,2)
6690         ghalf=0.5d0*ggg1(ll)
6691 cd        ghalf=0.0d0
6692         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6693         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6694         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6695         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6696 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6697         ghalf=0.5d0*ggg2(ll)
6698 cd        ghalf=0.0d0
6699         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6700         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6701         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6702         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6703       enddo
6704 cd      goto 1112
6705       do m=i+1,j-1
6706         do ll=1,3
6707 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6708           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6709         enddo
6710       enddo
6711       do m=k+1,l-1
6712         do ll=1,3
6713 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6714           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6715         enddo
6716       enddo
6717 1112  continue
6718       do m=i+2,j2
6719         do ll=1,3
6720           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6721         enddo
6722       enddo
6723       do m=k+2,l2
6724         do ll=1,3
6725           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6726         enddo
6727       enddo
6728 cd      do iii=1,nres-3
6729 cd        write (2,*) iii,gcorr_loc(iii)
6730 cd      enddo
6731       eello4=ekont*eel4
6732 cd      write (2,*) 'ekont',ekont
6733 cd      write (iout,*) 'eello4',ekont*eel4
6734       return
6735       end
6736 C---------------------------------------------------------------------------
6737       double precision function eello5(i,j,k,l,jj,kk)
6738       implicit real*8 (a-h,o-z)
6739       include 'DIMENSIONS'
6740       include 'COMMON.IOUNITS'
6741       include 'COMMON.CHAIN'
6742       include 'COMMON.DERIV'
6743       include 'COMMON.INTERACT'
6744       include 'COMMON.CONTACTS'
6745       include 'COMMON.TORSION'
6746       include 'COMMON.VAR'
6747       include 'COMMON.GEO'
6748       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6749       double precision ggg1(3),ggg2(3)
6750 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6751 C                                                                              C
6752 C                            Parallel chains                                   C
6753 C                                                                              C
6754 C          o             o                   o             o                   C
6755 C         /l\           / \             \   / \           / \   /              C
6756 C        /   \         /   \             \ /   \         /   \ /               C
6757 C       j| o |l1       | 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                            Antiparallel chains                               C
6766 C                                                                              C
6767 C          o             o                   o             o                   C
6768 C         /j\           / \             \   / \           / \   /              C
6769 C        /   \         /   \             \ /   \         /   \ /               C
6770 C      j1| o |l        | o |              o| o |         | o |o                C
6771 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6772 C      \i/   \         /   \ /             /   \         /   \                 C
6773 C       o     k1            o                                                  C
6774 C         (I)          (II)                (III)          (IV)                 C
6775 C                                                                              C
6776 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6777 C                                                                              C
6778 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6779 C                                                                              C
6780 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6781 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6782 cd        eello5=0.0d0
6783 cd        return
6784 cd      endif
6785 cd      write (iout,*)
6786 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6787 cd     &   ' and',k,l
6788       itk=itortyp(itype(k))
6789       itl=itortyp(itype(l))
6790       itj=itortyp(itype(j))
6791       eello5_1=0.0d0
6792       eello5_2=0.0d0
6793       eello5_3=0.0d0
6794       eello5_4=0.0d0
6795 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6796 cd     &   eel5_3_num,eel5_4_num)
6797       do iii=1,2
6798         do kkk=1,5
6799           do lll=1,3
6800             derx(lll,kkk,iii)=0.0d0
6801           enddo
6802         enddo
6803       enddo
6804 cd      eij=facont_hb(jj,i)
6805 cd      ekl=facont_hb(kk,k)
6806 cd      ekont=eij*ekl
6807 cd      write (iout,*)'Contacts have occurred for peptide groups',
6808 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6809 cd      goto 1111
6810 C Contribution from the graph I.
6811 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6812 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6813       call transpose2(EUg(1,1,k),auxmat(1,1))
6814       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6815       vv(1)=pizda(1,1)-pizda(2,2)
6816       vv(2)=pizda(1,2)+pizda(2,1)
6817       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6818      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6819 C Explicit gradient in virtual-dihedral angles.
6820       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6821      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6822      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6823       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6824       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6825       vv(1)=pizda(1,1)-pizda(2,2)
6826       vv(2)=pizda(1,2)+pizda(2,1)
6827       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6828      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6829      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6830       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6831       vv(1)=pizda(1,1)-pizda(2,2)
6832       vv(2)=pizda(1,2)+pizda(2,1)
6833       if (l.eq.j+1) then
6834         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6835      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6836      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6837       else
6838         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6839      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6840      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6841       endif
6842 C Cartesian gradient
6843       do iii=1,2
6844         do kkk=1,5
6845           do lll=1,3
6846             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6847      &        pizda(1,1))
6848             vv(1)=pizda(1,1)-pizda(2,2)
6849             vv(2)=pizda(1,2)+pizda(2,1)
6850             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6851      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6852      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6853           enddo
6854         enddo
6855       enddo
6856 c      goto 1112
6857 c1111  continue
6858 C Contribution from graph II
6859       call transpose2(EE(1,1,itk),auxmat(1,1))
6860       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6861       vv(1)=pizda(1,1)+pizda(2,2)
6862       vv(2)=pizda(2,1)-pizda(1,2)
6863       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6864      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6865 C Explicit gradient in virtual-dihedral angles.
6866       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6867      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6868       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6869       vv(1)=pizda(1,1)+pizda(2,2)
6870       vv(2)=pizda(2,1)-pizda(1,2)
6871       if (l.eq.j+1) then
6872         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6873      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6874      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6875       else
6876         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6877      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6878      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6879       endif
6880 C Cartesian gradient
6881       do iii=1,2
6882         do kkk=1,5
6883           do lll=1,3
6884             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6885      &        pizda(1,1))
6886             vv(1)=pizda(1,1)+pizda(2,2)
6887             vv(2)=pizda(2,1)-pizda(1,2)
6888             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6889      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6890      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6891           enddo
6892         enddo
6893       enddo
6894 cd      goto 1112
6895 cd1111  continue
6896       if (l.eq.j+1) then
6897 cd        goto 1110
6898 C Parallel orientation
6899 C Contribution from graph III
6900         call transpose2(EUg(1,1,l),auxmat(1,1))
6901         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6902         vv(1)=pizda(1,1)-pizda(2,2)
6903         vv(2)=pizda(1,2)+pizda(2,1)
6904         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6905      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6906 C Explicit gradient in virtual-dihedral angles.
6907         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6908      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6909      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6910         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6911         vv(1)=pizda(1,1)-pizda(2,2)
6912         vv(2)=pizda(1,2)+pizda(2,1)
6913         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6914      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6915      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6916         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6917         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6918         vv(1)=pizda(1,1)-pizda(2,2)
6919         vv(2)=pizda(1,2)+pizda(2,1)
6920         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6921      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6922      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6923 C Cartesian gradient
6924         do iii=1,2
6925           do kkk=1,5
6926             do lll=1,3
6927               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6928      &          pizda(1,1))
6929               vv(1)=pizda(1,1)-pizda(2,2)
6930               vv(2)=pizda(1,2)+pizda(2,1)
6931               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6932      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6933      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6934             enddo
6935           enddo
6936         enddo
6937 cd        goto 1112
6938 C Contribution from graph IV
6939 cd1110    continue
6940         call transpose2(EE(1,1,itl),auxmat(1,1))
6941         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6942         vv(1)=pizda(1,1)+pizda(2,2)
6943         vv(2)=pizda(2,1)-pizda(1,2)
6944         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6945      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6946 C Explicit gradient in virtual-dihedral angles.
6947         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6948      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6949         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6950         vv(1)=pizda(1,1)+pizda(2,2)
6951         vv(2)=pizda(2,1)-pizda(1,2)
6952         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6953      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6954      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6955 C Cartesian gradient
6956         do iii=1,2
6957           do kkk=1,5
6958             do lll=1,3
6959               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6960      &          pizda(1,1))
6961               vv(1)=pizda(1,1)+pizda(2,2)
6962               vv(2)=pizda(2,1)-pizda(1,2)
6963               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6964      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6965      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6966             enddo
6967           enddo
6968         enddo
6969       else
6970 C Antiparallel orientation
6971 C Contribution from graph III
6972 c        goto 1110
6973         call transpose2(EUg(1,1,j),auxmat(1,1))
6974         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6975         vv(1)=pizda(1,1)-pizda(2,2)
6976         vv(2)=pizda(1,2)+pizda(2,1)
6977         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6978      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6979 C Explicit gradient in virtual-dihedral angles.
6980         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6981      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6982      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6983         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6984         vv(1)=pizda(1,1)-pizda(2,2)
6985         vv(2)=pizda(1,2)+pizda(2,1)
6986         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6987      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6988      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6989         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6990         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6991         vv(1)=pizda(1,1)-pizda(2,2)
6992         vv(2)=pizda(1,2)+pizda(2,1)
6993         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6994      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6995      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6996 C Cartesian gradient
6997         do iii=1,2
6998           do kkk=1,5
6999             do lll=1,3
7000               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7001      &          pizda(1,1))
7002               vv(1)=pizda(1,1)-pizda(2,2)
7003               vv(2)=pizda(1,2)+pizda(2,1)
7004               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7005      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7006      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7007             enddo
7008           enddo
7009         enddo
7010 cd        goto 1112
7011 C Contribution from graph IV
7012 1110    continue
7013         call transpose2(EE(1,1,itj),auxmat(1,1))
7014         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7015         vv(1)=pizda(1,1)+pizda(2,2)
7016         vv(2)=pizda(2,1)-pizda(1,2)
7017         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7018      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7019 C Explicit gradient in virtual-dihedral angles.
7020         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7021      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7022         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7023         vv(1)=pizda(1,1)+pizda(2,2)
7024         vv(2)=pizda(2,1)-pizda(1,2)
7025         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7026      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7027      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7028 C Cartesian gradient
7029         do iii=1,2
7030           do kkk=1,5
7031             do lll=1,3
7032               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7033      &          pizda(1,1))
7034               vv(1)=pizda(1,1)+pizda(2,2)
7035               vv(2)=pizda(2,1)-pizda(1,2)
7036               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7037      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7038      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7039             enddo
7040           enddo
7041         enddo
7042       endif
7043 1112  continue
7044       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7045 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7046 cd        write (2,*) 'ijkl',i,j,k,l
7047 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7048 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7049 cd      endif
7050 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7051 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7052 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7053 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7054       if (j.lt.nres-1) then
7055         j1=j+1
7056         j2=j-1
7057       else
7058         j1=j-1
7059         j2=j-2
7060       endif
7061       if (l.lt.nres-1) then
7062         l1=l+1
7063         l2=l-1
7064       else
7065         l1=l-1
7066         l2=l-2
7067       endif
7068 cd      eij=1.0d0
7069 cd      ekl=1.0d0
7070 cd      ekont=1.0d0
7071 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7072       do ll=1,3
7073         ggg1(ll)=eel5*g_contij(ll,1)
7074         ggg2(ll)=eel5*g_contij(ll,2)
7075 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7076         ghalf=0.5d0*ggg1(ll)
7077 cd        ghalf=0.0d0
7078         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7079         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7080         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7081         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7082 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7083         ghalf=0.5d0*ggg2(ll)
7084 cd        ghalf=0.0d0
7085         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7086         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7087         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7088         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7089       enddo
7090 cd      goto 1112
7091       do m=i+1,j-1
7092         do ll=1,3
7093 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7094           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7095         enddo
7096       enddo
7097       do m=k+1,l-1
7098         do ll=1,3
7099 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7100           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7101         enddo
7102       enddo
7103 c1112  continue
7104       do m=i+2,j2
7105         do ll=1,3
7106           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7107         enddo
7108       enddo
7109       do m=k+2,l2
7110         do ll=1,3
7111           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7112         enddo
7113       enddo
7114 cd      do iii=1,nres-3
7115 cd        write (2,*) iii,g_corr5_loc(iii)
7116 cd      enddo
7117       eello5=ekont*eel5
7118 cd      write (2,*) 'ekont',ekont
7119 cd      write (iout,*) 'eello5',ekont*eel5
7120       return
7121       end
7122 c--------------------------------------------------------------------------
7123       double precision function eello6(i,j,k,l,jj,kk)
7124       implicit real*8 (a-h,o-z)
7125       include 'DIMENSIONS'
7126       include 'COMMON.IOUNITS'
7127       include 'COMMON.CHAIN'
7128       include 'COMMON.DERIV'
7129       include 'COMMON.INTERACT'
7130       include 'COMMON.CONTACTS'
7131       include 'COMMON.TORSION'
7132       include 'COMMON.VAR'
7133       include 'COMMON.GEO'
7134       include 'COMMON.FFIELD'
7135       double precision ggg1(3),ggg2(3)
7136 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7137 cd        eello6=0.0d0
7138 cd        return
7139 cd      endif
7140 cd      write (iout,*)
7141 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7142 cd     &   ' and',k,l
7143       eello6_1=0.0d0
7144       eello6_2=0.0d0
7145       eello6_3=0.0d0
7146       eello6_4=0.0d0
7147       eello6_5=0.0d0
7148       eello6_6=0.0d0
7149 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7150 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7151       do iii=1,2
7152         do kkk=1,5
7153           do lll=1,3
7154             derx(lll,kkk,iii)=0.0d0
7155           enddo
7156         enddo
7157       enddo
7158 cd      eij=facont_hb(jj,i)
7159 cd      ekl=facont_hb(kk,k)
7160 cd      ekont=eij*ekl
7161 cd      eij=1.0d0
7162 cd      ekl=1.0d0
7163 cd      ekont=1.0d0
7164       if (l.eq.j+1) then
7165         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7166         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7167         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7168         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7169         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7170         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7171       else
7172         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7173         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7174         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7175         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7176         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7177           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7178         else
7179           eello6_5=0.0d0
7180         endif
7181         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7182       endif
7183 C If turn contributions are considered, they will be handled separately.
7184       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7185 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7186 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7187 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7188 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7189 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7190 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7191 cd      goto 1112
7192       if (j.lt.nres-1) then
7193         j1=j+1
7194         j2=j-1
7195       else
7196         j1=j-1
7197         j2=j-2
7198       endif
7199       if (l.lt.nres-1) then
7200         l1=l+1
7201         l2=l-1
7202       else
7203         l1=l-1
7204         l2=l-2
7205       endif
7206       do ll=1,3
7207         ggg1(ll)=eel6*g_contij(ll,1)
7208         ggg2(ll)=eel6*g_contij(ll,2)
7209 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7210         ghalf=0.5d0*ggg1(ll)
7211 cd        ghalf=0.0d0
7212         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7213         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7214         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7215         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7216         ghalf=0.5d0*ggg2(ll)
7217 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7218 cd        ghalf=0.0d0
7219         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7220         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7221         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7222         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7223       enddo
7224 cd      goto 1112
7225       do m=i+1,j-1
7226         do ll=1,3
7227 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7228           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7229         enddo
7230       enddo
7231       do m=k+1,l-1
7232         do ll=1,3
7233 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7234           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7235         enddo
7236       enddo
7237 1112  continue
7238       do m=i+2,j2
7239         do ll=1,3
7240           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7241         enddo
7242       enddo
7243       do m=k+2,l2
7244         do ll=1,3
7245           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7246         enddo
7247       enddo
7248 cd      do iii=1,nres-3
7249 cd        write (2,*) iii,g_corr6_loc(iii)
7250 cd      enddo
7251       eello6=ekont*eel6
7252 cd      write (2,*) 'ekont',ekont
7253 cd      write (iout,*) 'eello6',ekont*eel6
7254       return
7255       end
7256 c--------------------------------------------------------------------------
7257       double precision function eello6_graph1(i,j,k,l,imat,swap)
7258       implicit real*8 (a-h,o-z)
7259       include 'DIMENSIONS'
7260       include 'COMMON.IOUNITS'
7261       include 'COMMON.CHAIN'
7262       include 'COMMON.DERIV'
7263       include 'COMMON.INTERACT'
7264       include 'COMMON.CONTACTS'
7265       include 'COMMON.TORSION'
7266       include 'COMMON.VAR'
7267       include 'COMMON.GEO'
7268       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7269       logical swap
7270       logical lprn
7271       common /kutas/ lprn
7272 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7273 C
7274 C      Parallel       Antiparallel
7275 C
7276 C          o             o
7277 C         /l\           /j\
7278 C        /   \         /   \
7279 C       /| o |         | o |\
7280 C     \ j|/k\|  /   \  |/k\|l /
7281 C      \ /   \ /     \ /   \ /
7282 C       o     o       o     o
7283 C       i             i
7284 C
7285 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7286       itk=itortyp(itype(k))
7287       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7288       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7289       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7290       call transpose2(EUgC(1,1,k),auxmat(1,1))
7291       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7292       vv1(1)=pizda1(1,1)-pizda1(2,2)
7293       vv1(2)=pizda1(1,2)+pizda1(2,1)
7294       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7295       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7296       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7297       s5=scalar2(vv(1),Dtobr2(1,i))
7298 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7299       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7300       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7301      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7302      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7303      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7304      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7305      & +scalar2(vv(1),Dtobr2der(1,i)))
7306       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7307       vv1(1)=pizda1(1,1)-pizda1(2,2)
7308       vv1(2)=pizda1(1,2)+pizda1(2,1)
7309       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7310       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7311       if (l.eq.j+1) then
7312         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7313      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7314      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7315      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7316      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7317       else
7318         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7319      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7320      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7321      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7322      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7323       endif
7324       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7325       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7326       vv1(1)=pizda1(1,1)-pizda1(2,2)
7327       vv1(2)=pizda1(1,2)+pizda1(2,1)
7328       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7329      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7330      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7331      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7332       do iii=1,2
7333         if (swap) then
7334           ind=3-iii
7335         else
7336           ind=iii
7337         endif
7338         do kkk=1,5
7339           do lll=1,3
7340             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7341             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7342             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7343             call transpose2(EUgC(1,1,k),auxmat(1,1))
7344             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7345      &        pizda1(1,1))
7346             vv1(1)=pizda1(1,1)-pizda1(2,2)
7347             vv1(2)=pizda1(1,2)+pizda1(2,1)
7348             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7349             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7350      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7351             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7352      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7353             s5=scalar2(vv(1),Dtobr2(1,i))
7354             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7355           enddo
7356         enddo
7357       enddo
7358       return
7359       end
7360 c----------------------------------------------------------------------------
7361       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7362       implicit real*8 (a-h,o-z)
7363       include 'DIMENSIONS'
7364       include 'COMMON.IOUNITS'
7365       include 'COMMON.CHAIN'
7366       include 'COMMON.DERIV'
7367       include 'COMMON.INTERACT'
7368       include 'COMMON.CONTACTS'
7369       include 'COMMON.TORSION'
7370       include 'COMMON.VAR'
7371       include 'COMMON.GEO'
7372       logical swap
7373       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7374      & auxvec1(2),auxvec2(1),auxmat1(2,2)
7375       logical lprn
7376       common /kutas/ lprn
7377 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7378 C
7379 C      Parallel       Antiparallel
7380 C
7381 C          o             o
7382 C     \   /l\           /j\   /
7383 C      \ /   \         /   \ /
7384 C       o| o |         | o |o
7385 C     \ j|/k\|      \  |/k\|l
7386 C      \ /   \       \ /   \
7387 C       o             o
7388 C       i             i
7389 C
7390 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7391 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7392 C AL 7/4/01 s1 would occur in the sixth-order moment,
7393 C           but not in a cluster cumulant
7394 #ifdef MOMENT
7395       s1=dip(1,jj,i)*dip(1,kk,k)
7396 #endif
7397       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7398       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7399       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7400       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7401       call transpose2(EUg(1,1,k),auxmat(1,1))
7402       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7403       vv(1)=pizda(1,1)-pizda(2,2)
7404       vv(2)=pizda(1,2)+pizda(2,1)
7405       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7406 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7407 #ifdef MOMENT
7408       eello6_graph2=-(s1+s2+s3+s4)
7409 #else
7410       eello6_graph2=-(s2+s3+s4)
7411 #endif
7412 c      eello6_graph2=-s3
7413 C Derivatives in gamma(i-1)
7414       if (i.gt.1) then
7415 #ifdef MOMENT
7416         s1=dipderg(1,jj,i)*dip(1,kk,k)
7417 #endif
7418         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7419         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7420         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7421         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7422 #ifdef MOMENT
7423         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7424 #else
7425         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7426 #endif
7427 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7428       endif
7429 C Derivatives in gamma(k-1)
7430 #ifdef MOMENT
7431       s1=dip(1,jj,i)*dipderg(1,kk,k)
7432 #endif
7433       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7434       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7435       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7436       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7437       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7438       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7439       vv(1)=pizda(1,1)-pizda(2,2)
7440       vv(2)=pizda(1,2)+pizda(2,1)
7441       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7442 #ifdef MOMENT
7443       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7444 #else
7445       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7446 #endif
7447 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7448 C Derivatives in gamma(j-1) or gamma(l-1)
7449       if (j.gt.1) then
7450 #ifdef MOMENT
7451         s1=dipderg(3,jj,i)*dip(1,kk,k)
7452 #endif
7453         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7454         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7455         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7456         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7457         vv(1)=pizda(1,1)-pizda(2,2)
7458         vv(2)=pizda(1,2)+pizda(2,1)
7459         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7460 #ifdef MOMENT
7461         if (swap) then
7462           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7463         else
7464           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7465         endif
7466 #endif
7467         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7468 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7469       endif
7470 C Derivatives in gamma(l-1) or gamma(j-1)
7471       if (l.gt.1) then
7472 #ifdef MOMENT
7473         s1=dip(1,jj,i)*dipderg(3,kk,k)
7474 #endif
7475         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7476         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7477         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7478         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7479         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7480         vv(1)=pizda(1,1)-pizda(2,2)
7481         vv(2)=pizda(1,2)+pizda(2,1)
7482         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7483 #ifdef MOMENT
7484         if (swap) then
7485           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7486         else
7487           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7488         endif
7489 #endif
7490         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7491 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7492       endif
7493 C Cartesian derivatives.
7494       if (lprn) then
7495         write (2,*) 'In eello6_graph2'
7496         do iii=1,2
7497           write (2,*) 'iii=',iii
7498           do kkk=1,5
7499             write (2,*) 'kkk=',kkk
7500             do jjj=1,2
7501               write (2,'(3(2f10.5),5x)')
7502      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7503             enddo
7504           enddo
7505         enddo
7506       endif
7507       do iii=1,2
7508         do kkk=1,5
7509           do lll=1,3
7510 #ifdef MOMENT
7511             if (iii.eq.1) then
7512               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7513             else
7514               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7515             endif
7516 #endif
7517             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7518      &        auxvec(1))
7519             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7520             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7521      &        auxvec(1))
7522             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7523             call transpose2(EUg(1,1,k),auxmat(1,1))
7524             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7525      &        pizda(1,1))
7526             vv(1)=pizda(1,1)-pizda(2,2)
7527             vv(2)=pizda(1,2)+pizda(2,1)
7528             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7529 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7530 #ifdef MOMENT
7531             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7532 #else
7533             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7534 #endif
7535             if (swap) then
7536               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7537             else
7538               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7539             endif
7540           enddo
7541         enddo
7542       enddo
7543       return
7544       end
7545 c----------------------------------------------------------------------------
7546       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7547       implicit real*8 (a-h,o-z)
7548       include 'DIMENSIONS'
7549       include 'COMMON.IOUNITS'
7550       include 'COMMON.CHAIN'
7551       include 'COMMON.DERIV'
7552       include 'COMMON.INTERACT'
7553       include 'COMMON.CONTACTS'
7554       include 'COMMON.TORSION'
7555       include 'COMMON.VAR'
7556       include 'COMMON.GEO'
7557       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7558       logical swap
7559 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7560 C
7561 C      Parallel       Antiparallel
7562 C
7563 C          o             o
7564 C         /l\   /   \   /j\
7565 C        /   \ /     \ /   \
7566 C       /| o |o       o| o |\
7567 C       j|/k\|  /      |/k\|l /
7568 C        /   \ /       /   \ /
7569 C       /     o       /     o
7570 C       i             i
7571 C
7572 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7573 C
7574 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7575 C           energy moment and not to the cluster cumulant.
7576       iti=itortyp(itype(i))
7577       if (j.lt.nres-1) then
7578         itj1=itortyp(itype(j+1))
7579       else
7580         itj1=ntortyp+1
7581       endif
7582       itk=itortyp(itype(k))
7583       itk1=itortyp(itype(k+1))
7584       if (l.lt.nres-1) then
7585         itl1=itortyp(itype(l+1))
7586       else
7587         itl1=ntortyp+1
7588       endif
7589 #ifdef MOMENT
7590       s1=dip(4,jj,i)*dip(4,kk,k)
7591 #endif
7592       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7593       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7594       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7595       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7596       call transpose2(EE(1,1,itk),auxmat(1,1))
7597       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7598       vv(1)=pizda(1,1)+pizda(2,2)
7599       vv(2)=pizda(2,1)-pizda(1,2)
7600       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7601 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7602 #ifdef MOMENT
7603       eello6_graph3=-(s1+s2+s3+s4)
7604 #else
7605       eello6_graph3=-(s2+s3+s4)
7606 #endif
7607 c      eello6_graph3=-s4
7608 C Derivatives in gamma(k-1)
7609       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7610       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7611       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7612       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7613 C Derivatives in gamma(l-1)
7614       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7615       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7616       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7617       vv(1)=pizda(1,1)+pizda(2,2)
7618       vv(2)=pizda(2,1)-pizda(1,2)
7619       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7620       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7621 C Cartesian derivatives.
7622       do iii=1,2
7623         do kkk=1,5
7624           do lll=1,3
7625 #ifdef MOMENT
7626             if (iii.eq.1) then
7627               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7628             else
7629               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7630             endif
7631 #endif
7632             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7633      &        auxvec(1))
7634             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7635             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7636      &        auxvec(1))
7637             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7638             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7639      &        pizda(1,1))
7640             vv(1)=pizda(1,1)+pizda(2,2)
7641             vv(2)=pizda(2,1)-pizda(1,2)
7642             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7643 #ifdef MOMENT
7644             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7645 #else
7646             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7647 #endif
7648             if (swap) then
7649               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7650             else
7651               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7652             endif
7653 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7654           enddo
7655         enddo
7656       enddo
7657       return
7658       end
7659 c----------------------------------------------------------------------------
7660       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7661       implicit real*8 (a-h,o-z)
7662       include 'DIMENSIONS'
7663       include 'COMMON.IOUNITS'
7664       include 'COMMON.CHAIN'
7665       include 'COMMON.DERIV'
7666       include 'COMMON.INTERACT'
7667       include 'COMMON.CONTACTS'
7668       include 'COMMON.TORSION'
7669       include 'COMMON.VAR'
7670       include 'COMMON.GEO'
7671       include 'COMMON.FFIELD'
7672       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7673      & auxvec1(2),auxmat1(2,2)
7674       logical swap
7675 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7676 C
7677 C      Parallel       Antiparallel
7678 C
7679 C          o             o
7680 C         /l\   /   \   /j\
7681 C        /   \ /     \ /   \
7682 C       /| o |o       o| o |\
7683 C     \ j|/k\|      \  |/k\|l
7684 C      \ /   \       \ /   \
7685 C       o     \       o     \
7686 C       i             i
7687 C
7688 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7689 C
7690 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7691 C           energy moment and not to the cluster cumulant.
7692 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7693       iti=itortyp(itype(i))
7694       itj=itortyp(itype(j))
7695       if (j.lt.nres-1) then
7696         itj1=itortyp(itype(j+1))
7697       else
7698         itj1=ntortyp+1
7699       endif
7700       itk=itortyp(itype(k))
7701       if (k.lt.nres-1) then
7702         itk1=itortyp(itype(k+1))
7703       else
7704         itk1=ntortyp+1
7705       endif
7706       itl=itortyp(itype(l))
7707       if (l.lt.nres-1) then
7708         itl1=itortyp(itype(l+1))
7709       else
7710         itl1=ntortyp+1
7711       endif
7712 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7713 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7714 cd     & ' itl',itl,' itl1',itl1
7715 #ifdef MOMENT
7716       if (imat.eq.1) then
7717         s1=dip(3,jj,i)*dip(3,kk,k)
7718       else
7719         s1=dip(2,jj,j)*dip(2,kk,l)
7720       endif
7721 #endif
7722       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7723       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7724       if (j.eq.l+1) then
7725         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7726         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7727       else
7728         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7729         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7730       endif
7731       call transpose2(EUg(1,1,k),auxmat(1,1))
7732       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7733       vv(1)=pizda(1,1)-pizda(2,2)
7734       vv(2)=pizda(2,1)+pizda(1,2)
7735       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7736 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7737 #ifdef MOMENT
7738       eello6_graph4=-(s1+s2+s3+s4)
7739 #else
7740       eello6_graph4=-(s2+s3+s4)
7741 #endif
7742 C Derivatives in gamma(i-1)
7743       if (i.gt.1) then
7744 #ifdef MOMENT
7745         if (imat.eq.1) then
7746           s1=dipderg(2,jj,i)*dip(3,kk,k)
7747         else
7748           s1=dipderg(4,jj,j)*dip(2,kk,l)
7749         endif
7750 #endif
7751         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7752         if (j.eq.l+1) then
7753           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7754           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7755         else
7756           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7757           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7758         endif
7759         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7760         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7761 cd          write (2,*) 'turn6 derivatives'
7762 #ifdef MOMENT
7763           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7764 #else
7765           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7766 #endif
7767         else
7768 #ifdef MOMENT
7769           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7770 #else
7771           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7772 #endif
7773         endif
7774       endif
7775 C Derivatives in gamma(k-1)
7776 #ifdef MOMENT
7777       if (imat.eq.1) then
7778         s1=dip(3,jj,i)*dipderg(2,kk,k)
7779       else
7780         s1=dip(2,jj,j)*dipderg(4,kk,l)
7781       endif
7782 #endif
7783       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7784       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7785       if (j.eq.l+1) then
7786         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7787         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7788       else
7789         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7790         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7791       endif
7792       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7793       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7794       vv(1)=pizda(1,1)-pizda(2,2)
7795       vv(2)=pizda(2,1)+pizda(1,2)
7796       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7797       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7798 #ifdef MOMENT
7799         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7800 #else
7801         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7802 #endif
7803       else
7804 #ifdef MOMENT
7805         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7806 #else
7807         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7808 #endif
7809       endif
7810 C Derivatives in gamma(j-1) or gamma(l-1)
7811       if (l.eq.j+1 .and. l.gt.1) then
7812         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7813         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7814         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7815         vv(1)=pizda(1,1)-pizda(2,2)
7816         vv(2)=pizda(2,1)+pizda(1,2)
7817         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7818         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7819       else if (j.gt.1) then
7820         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7821         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7822         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7823         vv(1)=pizda(1,1)-pizda(2,2)
7824         vv(2)=pizda(2,1)+pizda(1,2)
7825         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7826         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7827           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7828         else
7829           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7830         endif
7831       endif
7832 C Cartesian derivatives.
7833       do iii=1,2
7834         do kkk=1,5
7835           do lll=1,3
7836 #ifdef MOMENT
7837             if (iii.eq.1) then
7838               if (imat.eq.1) then
7839                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7840               else
7841                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7842               endif
7843             else
7844               if (imat.eq.1) then
7845                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7846               else
7847                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7848               endif
7849             endif
7850 #endif
7851             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7852      &        auxvec(1))
7853             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7854             if (j.eq.l+1) then
7855               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7856      &          b1(1,itj1),auxvec(1))
7857               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7858             else
7859               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7860      &          b1(1,itl1),auxvec(1))
7861               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7862             endif
7863             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7864      &        pizda(1,1))
7865             vv(1)=pizda(1,1)-pizda(2,2)
7866             vv(2)=pizda(2,1)+pizda(1,2)
7867             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7868             if (swap) then
7869               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7870 #ifdef MOMENT
7871                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7872      &             -(s1+s2+s4)
7873 #else
7874                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7875      &             -(s2+s4)
7876 #endif
7877                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7878               else
7879 #ifdef MOMENT
7880                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7881 #else
7882                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7883 #endif
7884                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7885               endif
7886             else
7887 #ifdef MOMENT
7888               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7889 #else
7890               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7891 #endif
7892               if (l.eq.j+1) then
7893                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7894               else
7895                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7896               endif
7897             endif
7898           enddo
7899         enddo
7900       enddo
7901       return
7902       end
7903 c----------------------------------------------------------------------------
7904       double precision function eello_turn6(i,jj,kk)
7905       implicit real*8 (a-h,o-z)
7906       include 'DIMENSIONS'
7907       include 'COMMON.IOUNITS'
7908       include 'COMMON.CHAIN'
7909       include 'COMMON.DERIV'
7910       include 'COMMON.INTERACT'
7911       include 'COMMON.CONTACTS'
7912       include 'COMMON.TORSION'
7913       include 'COMMON.VAR'
7914       include 'COMMON.GEO'
7915       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7916      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7917      &  ggg1(3),ggg2(3)
7918       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7919      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7920 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7921 C           the respective energy moment and not to the cluster cumulant.
7922       s1=0.0d0
7923       s8=0.0d0
7924       s13=0.0d0
7925 c
7926       eello_turn6=0.0d0
7927       j=i+4
7928       k=i+1
7929       l=i+3
7930       iti=itortyp(itype(i))
7931       itk=itortyp(itype(k))
7932       itk1=itortyp(itype(k+1))
7933       itl=itortyp(itype(l))
7934       itj=itortyp(itype(j))
7935 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7936 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7937 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7938 cd        eello6=0.0d0
7939 cd        return
7940 cd      endif
7941 cd      write (iout,*)
7942 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7943 cd     &   ' and',k,l
7944 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7945       do iii=1,2
7946         do kkk=1,5
7947           do lll=1,3
7948             derx_turn(lll,kkk,iii)=0.0d0
7949           enddo
7950         enddo
7951       enddo
7952 cd      eij=1.0d0
7953 cd      ekl=1.0d0
7954 cd      ekont=1.0d0
7955       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7956 cd      eello6_5=0.0d0
7957 cd      write (2,*) 'eello6_5',eello6_5
7958 #ifdef MOMENT
7959       call transpose2(AEA(1,1,1),auxmat(1,1))
7960       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7961       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7962       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7963 #endif
7964       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7965       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7966       s2 = scalar2(b1(1,itk),vtemp1(1))
7967 #ifdef MOMENT
7968       call transpose2(AEA(1,1,2),atemp(1,1))
7969       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7970       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7971       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7972 #endif
7973       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7974       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7975       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7976 #ifdef MOMENT
7977       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7978       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7979       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7980       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7981       ss13 = scalar2(b1(1,itk),vtemp4(1))
7982       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7983 #endif
7984 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7985 c      s1=0.0d0
7986 c      s2=0.0d0
7987 c      s8=0.0d0
7988 c      s12=0.0d0
7989 c      s13=0.0d0
7990       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7991 C Derivatives in gamma(i+2)
7992       s1d =0.0d0
7993       s8d =0.0d0
7994 #ifdef MOMENT
7995       call transpose2(AEA(1,1,1),auxmatd(1,1))
7996       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7997       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7998       call transpose2(AEAderg(1,1,2),atempd(1,1))
7999       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8000       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8001 #endif
8002       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8003       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8004       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8005 c      s1d=0.0d0
8006 c      s2d=0.0d0
8007 c      s8d=0.0d0
8008 c      s12d=0.0d0
8009 c      s13d=0.0d0
8010       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8011 C Derivatives in gamma(i+3)
8012 #ifdef MOMENT
8013       call transpose2(AEA(1,1,1),auxmatd(1,1))
8014       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8015       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8016       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8017 #endif
8018       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8019       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8020       s2d = scalar2(b1(1,itk),vtemp1d(1))
8021 #ifdef MOMENT
8022       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8023       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8024 #endif
8025       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8026 #ifdef MOMENT
8027       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8028       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8029       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8030 #endif
8031 c      s1d=0.0d0
8032 c      s2d=0.0d0
8033 c      s8d=0.0d0
8034 c      s12d=0.0d0
8035 c      s13d=0.0d0
8036 #ifdef MOMENT
8037       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8038      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8039 #else
8040       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8041      &               -0.5d0*ekont*(s2d+s12d)
8042 #endif
8043 C Derivatives in gamma(i+4)
8044       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8045       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8046       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8047 #ifdef MOMENT
8048       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8049       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8050       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8051 #endif
8052 c      s1d=0.0d0
8053 c      s2d=0.0d0
8054 c      s8d=0.0d0
8055 C      s12d=0.0d0
8056 c      s13d=0.0d0
8057 #ifdef MOMENT
8058       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8059 #else
8060       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8061 #endif
8062 C Derivatives in gamma(i+5)
8063 #ifdef MOMENT
8064       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8065       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8066       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8067 #endif
8068       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8069       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8070       s2d = scalar2(b1(1,itk),vtemp1d(1))
8071 #ifdef MOMENT
8072       call transpose2(AEA(1,1,2),atempd(1,1))
8073       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8074       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8075 #endif
8076       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8077       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8078 #ifdef MOMENT
8079       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8080       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8081       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8082 #endif
8083 c      s1d=0.0d0
8084 c      s2d=0.0d0
8085 c      s8d=0.0d0
8086 c      s12d=0.0d0
8087 c      s13d=0.0d0
8088 #ifdef MOMENT
8089       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8090      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8091 #else
8092       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8093      &               -0.5d0*ekont*(s2d+s12d)
8094 #endif
8095 C Cartesian derivatives
8096       do iii=1,2
8097         do kkk=1,5
8098           do lll=1,3
8099 #ifdef MOMENT
8100             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8101             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8102             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8103 #endif
8104             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8105             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8106      &          vtemp1d(1))
8107             s2d = scalar2(b1(1,itk),vtemp1d(1))
8108 #ifdef MOMENT
8109             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8110             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8111             s8d = -(atempd(1,1)+atempd(2,2))*
8112      &           scalar2(cc(1,1,itl),vtemp2(1))
8113 #endif
8114             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8115      &           auxmatd(1,1))
8116             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8117             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8118 c      s1d=0.0d0
8119 c      s2d=0.0d0
8120 c      s8d=0.0d0
8121 c      s12d=0.0d0
8122 c      s13d=0.0d0
8123 #ifdef MOMENT
8124             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8125      &        - 0.5d0*(s1d+s2d)
8126 #else
8127             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8128      &        - 0.5d0*s2d
8129 #endif
8130 #ifdef MOMENT
8131             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8132      &        - 0.5d0*(s8d+s12d)
8133 #else
8134             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8135      &        - 0.5d0*s12d
8136 #endif
8137           enddo
8138         enddo
8139       enddo
8140 #ifdef MOMENT
8141       do kkk=1,5
8142         do lll=1,3
8143           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8144      &      achuj_tempd(1,1))
8145           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8146           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8147           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8148           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8149           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8150      &      vtemp4d(1))
8151           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8152           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8153           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8154         enddo
8155       enddo
8156 #endif
8157 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8158 cd     &  16*eel_turn6_num
8159 cd      goto 1112
8160       if (j.lt.nres-1) then
8161         j1=j+1
8162         j2=j-1
8163       else
8164         j1=j-1
8165         j2=j-2
8166       endif
8167       if (l.lt.nres-1) then
8168         l1=l+1
8169         l2=l-1
8170       else
8171         l1=l-1
8172         l2=l-2
8173       endif
8174       do ll=1,3
8175         ggg1(ll)=eel_turn6*g_contij(ll,1)
8176         ggg2(ll)=eel_turn6*g_contij(ll,2)
8177         ghalf=0.5d0*ggg1(ll)
8178 cd        ghalf=0.0d0
8179         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8180      &    +ekont*derx_turn(ll,2,1)
8181         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8182         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8183      &    +ekont*derx_turn(ll,4,1)
8184         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8185         ghalf=0.5d0*ggg2(ll)
8186 cd        ghalf=0.0d0
8187         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8188      &    +ekont*derx_turn(ll,2,2)
8189         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8190         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8191      &    +ekont*derx_turn(ll,4,2)
8192         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8193       enddo
8194 cd      goto 1112
8195       do m=i+1,j-1
8196         do ll=1,3
8197           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8198         enddo
8199       enddo
8200       do m=k+1,l-1
8201         do ll=1,3
8202           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8203         enddo
8204       enddo
8205 1112  continue
8206       do m=i+2,j2
8207         do ll=1,3
8208           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8209         enddo
8210       enddo
8211       do m=k+2,l2
8212         do ll=1,3
8213           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8214         enddo
8215       enddo
8216 cd      do iii=1,nres-3
8217 cd        write (2,*) iii,g_corr6_loc(iii)
8218 cd      enddo
8219       eello_turn6=ekont*eel_turn6
8220 cd      write (2,*) 'ekont',ekont
8221 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8222       return
8223       end
8224
8225 C-----------------------------------------------------------------------------
8226       double precision function scalar(u,v)
8227 !DIR$ INLINEALWAYS scalar
8228 #ifndef OSF
8229 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8230 #endif
8231       implicit none
8232       double precision u(3),v(3)
8233 cd      double precision sc
8234 cd      integer i
8235 cd      sc=0.0d0
8236 cd      do i=1,3
8237 cd        sc=sc+u(i)*v(i)
8238 cd      enddo
8239 cd      scalar=sc
8240
8241       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8242       return
8243       end
8244 crc-------------------------------------------------
8245       SUBROUTINE MATVEC2(A1,V1,V2)
8246 !DIR$ INLINEALWAYS MATVEC2
8247 #ifndef OSF
8248 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8249 #endif
8250       implicit real*8 (a-h,o-z)
8251       include 'DIMENSIONS'
8252       DIMENSION A1(2,2),V1(2),V2(2)
8253 c      DO 1 I=1,2
8254 c        VI=0.0
8255 c        DO 3 K=1,2
8256 c    3     VI=VI+A1(I,K)*V1(K)
8257 c        Vaux(I)=VI
8258 c    1 CONTINUE
8259
8260       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8261       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8262
8263       v2(1)=vaux1
8264       v2(2)=vaux2
8265       END
8266 C---------------------------------------
8267       SUBROUTINE MATMAT2(A1,A2,A3)
8268 #ifndef OSF
8269 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8270 #endif
8271       implicit real*8 (a-h,o-z)
8272       include 'DIMENSIONS'
8273       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8274 c      DIMENSION AI3(2,2)
8275 c        DO  J=1,2
8276 c          A3IJ=0.0
8277 c          DO K=1,2
8278 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8279 c          enddo
8280 c          A3(I,J)=A3IJ
8281 c       enddo
8282 c      enddo
8283
8284       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8285       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8286       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8287       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8288
8289       A3(1,1)=AI3_11
8290       A3(2,1)=AI3_21
8291       A3(1,2)=AI3_12
8292       A3(2,2)=AI3_22
8293       END
8294
8295 c-------------------------------------------------------------------------
8296       double precision function scalar2(u,v)
8297 !DIR$ INLINEALWAYS scalar2
8298       implicit none
8299       double precision u(2),v(2)
8300       double precision sc
8301       integer i
8302       scalar2=u(1)*v(1)+u(2)*v(2)
8303       return
8304       end
8305
8306 C-----------------------------------------------------------------------------
8307
8308       subroutine transpose2(a,at)
8309 !DIR$ INLINEALWAYS transpose2
8310 #ifndef OSF
8311 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8312 #endif
8313       implicit none
8314       double precision a(2,2),at(2,2)
8315       at(1,1)=a(1,1)
8316       at(1,2)=a(2,1)
8317       at(2,1)=a(1,2)
8318       at(2,2)=a(2,2)
8319       return
8320       end
8321 c--------------------------------------------------------------------------
8322       subroutine transpose(n,a,at)
8323       implicit none
8324       integer n,i,j
8325       double precision a(n,n),at(n,n)
8326       do i=1,n
8327         do j=1,n
8328           at(j,i)=a(i,j)
8329         enddo
8330       enddo
8331       return
8332       end
8333 C---------------------------------------------------------------------------
8334       subroutine prodmat3(a1,a2,kk,transp,prod)
8335 !DIR$ INLINEALWAYS prodmat3
8336 #ifndef OSF
8337 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8338 #endif
8339       implicit none
8340       integer i,j
8341       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8342       logical transp
8343 crc      double precision auxmat(2,2),prod_(2,2)
8344
8345       if (transp) then
8346 crc        call transpose2(kk(1,1),auxmat(1,1))
8347 crc        call matmat2(a1(1,1),auxmat(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(1,2))*a2(1,1)
8351      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8352            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8353      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8354            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8355      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8356            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8357      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8358
8359       else
8360 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8361 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8362
8363            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8364      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8365            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8366      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8367            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8368      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8369            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8370      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8371
8372       endif
8373 c      call transpose2(a2(1,1),a2t(1,1))
8374
8375 crc      print *,transp
8376 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8377 crc      print *,((prod(i,j),i=1,2),j=1,2)
8378
8379       return
8380       end
8381