source/unres/src_MD-M-SAXS-homology/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          if (loc_qlike) then
 244            call Econstr_back_qlike
 245          else
 246            call Econstr_back
 247          endif
 248       else
 249          Uconst=0.0d0
 250          Uconst_back=0.0d0
 251       endif
 252 c      print *,"Processor",myrank," computed Uconstr"
 253 c
 254 C Sum the energies
 255 C
 256       energia(1)=evdw
 257 #ifdef SCP14
 258       energia(2)=evdw2-evdw2_14
 259       energia(18)=evdw2_14
 260 #else
 261       energia(2)=evdw2
 262       energia(18)=0.0d0
 263 #endif
 264 #ifdef SPLITELE
 265       energia(3)=ees
 266       energia(16)=evdw1
 267 #else
 268       energia(3)=ees+evdw1
 269       energia(16)=0.0d0
 270 #endif
 271       energia(4)=ecorr
 272       energia(5)=ecorr5
 273       energia(6)=ecorr6
 274       energia(7)=eel_loc
 275       energia(8)=eello_turn3
 276       energia(9)=eello_turn4
 277       energia(10)=eturn6
 278       energia(11)=ebe
 279       energia(12)=escloc
 280       energia(13)=etors
 281       energia(14)=etors_d
 282       energia(15)=ehpb
 283       energia(19)=edihcnstr
 284       energia(17)=estr
 285       energia(20)=Uconst+Uconst_back
 286       energia(21)=esccor
 287 c      print *," Processor",myrank," calls SUM_ENERGY"
 288       call sum_energy(energia,.true.)
 289 c      print *," Processor",myrank," left SUM_ENERGY"
 290       return
 291       end
 292 c-------------------------------------------------------------------------------
 293       subroutine sum_energy(energia,reduce)
 294       implicit real*8 (a-h,o-z)
 295       include 'DIMENSIONS'
 296 #ifndef ISNAN
 297       external proc_proc
 298 #ifdef WINPGI
 299 cMS$ATTRIBUTES C ::  proc_proc
 300 #endif
 301 #endif
 302 #ifdef MPI
 303       include "mpif.h"
 304 #endif
 305       include 'COMMON.SETUP'
 306       include 'COMMON.IOUNITS'
 307       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 308       include 'COMMON.FFIELD'
 309       include 'COMMON.DERIV'
 310       include 'COMMON.INTERACT'
 311       include 'COMMON.SBRIDGE'
 312       include 'COMMON.CHAIN'
 313       include 'COMMON.VAR'
 314       include 'COMMON.CONTROL'
 315       include 'COMMON.TIME1'
 316       logical reduce
 317 #ifdef MPI
 318       if (nfgtasks.gt.1 .and. reduce) then
 319 #ifdef DEBUG
 320         write (iout,*) "energies before REDUCE"
 321         call enerprint(energia)
 322         call flush(iout)
 323 #endif
 324         do i=0,n_ene
 325           enebuff(i)=energia(i)
 326         enddo
 327         time00=MPI_Wtime()
 328         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 329      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 330 #ifdef DEBUG
 331         write (iout,*) "energies after REDUCE"
 332         call enerprint(energia)
 333         call flush(iout)
 334 #endif
 335         time_Reduce=time_Reduce+MPI_Wtime()-time00
 336       endif
 337       if (fg_rank.eq.0) then
 338 #endif
 339       evdw=energia(1)
 340 #ifdef SCP14
 341       evdw2=energia(2)+energia(18)
 342       evdw2_14=energia(18)
 343 #else
 344       evdw2=energia(2)
 345 #endif
 346 #ifdef SPLITELE
 347       ees=energia(3)
 348       evdw1=energia(16)
 349 #else
 350       ees=energia(3)
 351       evdw1=0.0d0
 352 #endif
 353       ecorr=energia(4)
 354       ecorr5=energia(5)
 355       ecorr6=energia(6)
 356       eel_loc=energia(7)
 357       eello_turn3=energia(8)
 358       eello_turn4=energia(9)
 359       eturn6=energia(10)
 360       ebe=energia(11)
 361       escloc=energia(12)
 362       etors=energia(13)
 363       etors_d=energia(14)
 364       ehpb=energia(15)
 365       edihcnstr=energia(19)
 366       estr=energia(17)
 367       Uconst=energia(20)
 368       esccor=energia(21)
 369 #ifdef SPLITELE
 370       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 371      & +wang*ebe+wtor*etors+wscloc*escloc
 372      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 373      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 374      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 375      & +wbond*estr+Uconst+wsccor*esccor
 376 #else
 377       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 378      & +wang*ebe+wtor*etors+wscloc*escloc
 379      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 380      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 381      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 382      & +wbond*estr+Uconst+wsccor*esccor
 383 #endif
 384       energia(0)=etot
 385 c detecting NaNQ
 386 #ifdef ISNAN
 387 #ifdef AIX
 388       if (isnan(etot).ne.0) energia(0)=1.0d+99
 389 #else
 390       if (isnan(etot)) energia(0)=1.0d+99
 391 #endif
 392 #else
 393       i=0
 394 #ifdef WINPGI
 395       idumm=proc_proc(etot,i)
 396 #else
 397       call proc_proc(etot,i)
 398 #endif
 399       if(i.eq.1)energia(0)=1.0d+99
 400 #endif
 401 #ifdef MPI
 402       endif
 403 #endif
 404       return
 405       end
 406 c-------------------------------------------------------------------------------
 407       subroutine sum_gradient
 408       implicit real*8 (a-h,o-z)
 409       include 'DIMENSIONS'
 410 #ifndef ISNAN
 411       external proc_proc
 412 #ifdef WINPGI
 413 cMS$ATTRIBUTES C ::  proc_proc
 414 #endif
 415 #endif
 416 #ifdef MPI
 417       include 'mpif.h'
 418       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 419      &  glocbuf(4*maxres)
 420 #endif
 421       include 'COMMON.SETUP'
 422       include 'COMMON.IOUNITS'
 423       include 'COMMON.FFIELD'
 424       include 'COMMON.DERIV'
 425       include 'COMMON.INTERACT'
 426       include 'COMMON.SBRIDGE'
 427       include 'COMMON.CHAIN'
 428       include 'COMMON.VAR'
 429       include 'COMMON.CONTROL'
 430       include 'COMMON.TIME1'
 431       include 'COMMON.MAXGRAD'
 432 C
 433 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 434 C            in virtual-bond-vector coordinates
 435 C
 436 #ifdef TIMING
 437       time01=MPI_Wtime()
 438 #endif
 439 #ifdef DEBUG
 440       write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 441       do i=1,nres-1
 442         write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 443      &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 444       enddo
 445       write (iout,*) "gcorr4_turn, gel_loc_turn4"
 446       do i=1,nres-1
 447         write (iout,'(i5,3f10.5,2x,f10.5)')
 448      &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 449       enddo
 450 #endif
 451       do i=nnt,nres-1
 452         do k=1,3
 453           gvdwc(k,i)=0.0d0
 454           gvdwc_scp(k,i)=0.0d0
 455         enddo
 456         do j=i+1,nres
 457           do k=1,3
 458             gvdwc(k,i)=gvdwc(k,i)+gvdwc(k,j)
 459             gvdwc_scp(k,i)=gvdwc_scp(k,i)+gvdwc_scp(k,j)
 460           enddo
 461         enddo
 462       enddo
 463       do i=nnt,nct-1
 464         do k=1,3
 465           gelc(k,i)=gelc(k,i)+0.5d0*gelc_long(k,i)
 466           gvdwpp(k,i)=0.5d0*gvdwpp(k,i)
 467           gvdwc_scp(k,i)=gvdwc_scp(k,i)+0.5d0*gvdwc_scpp(k,i)
 468         enddo
 469         do j=i+1,nct-1
 470           do k=1,3
 471             gelc(k,i)=gelc(k,i)+gelc_long(k,j)
 472             gvdwpp(k,i)=gvdwpp(k,i)+gvdwpp(k,j)
 473             gvdwc_scp(k,i)=gvdwc_scp(k,i)+gvdwc_scpp(k,j)
 474           enddo
 475         enddo
 476       enddo
 477       do i=nnt,nct-1
 478         do k=1,3
 479           gel_loc(k,i)=gel_loc(k,i)+0.5d0*gel_loc_long(k,i)
 480         enddo
 481         do j=i+1,nres-1
 482           do k=1,3
 483             gel_loc(k,i)=gel_loc(k,i)+gel_loc_long(k,j)
 484           enddo
 485         enddo
 486       enddo
 487       do k=1,3
 488         gvdwc_scp(k,nres)=0.0d0
 489         gvdwc(k,nres)=0.0d0
 490         gel_loc(k,nres)=0.0d0
 491       enddo
 492 C
 493 C Sum up the components of the Cartesian gradient.
 494 C
 495 #ifdef SPLITELE
 496       do i=1,nct
 497         do j=1,3
 498           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 499      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 500      &                wbond*gradb(j,i)+
 501      &                wstrain*ghpbc(j,i)+
 502      &                wcorr*gradcorr(j,i)+
 503      &                wel_loc*gel_loc(j,i)+
 504      &                wturn3*gcorr3_turn(j,i)+
 505      &                wturn4*gcorr4_turn(j,i)+
 506      &                wcorr5*gradcorr5(j,i)+
 507      &                wcorr6*gradcorr6(j,i)+
 508      &                wturn6*gcorr6_turn(j,i)+
 509      &                wsccor*gsccorc(j,i)
 510      &               +wscloc*gscloc(j,i)
 511           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 512      &                  wbond*gradbx(j,i)+
 513      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 514      &                  wsccor*gsccorx(j,i)
 515      &                 +wscloc*gsclocx(j,i)
 516         enddo
 517       enddo
 518 #else
 519       do i=1,nct
 520         do j=1,3
 521           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 522      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 523      &                wbond*gradb(j,i)+
 524      &                wcorr*gradcorr(j,i)+
 525      &                wel_loc*gel_loc(j,i)+
 526      &                wturn3*gcorr3_turn(j,i)+
 527      &                wturn4*gcorr4_turn(j,i)+
 528      &                wcorr5*gradcorr5(j,i)+
 529      &                wcorr6*gradcorr6(j,i)+
 530      &                wturn6*gcorr6_turn(j,i)+
 531      &                wsccor*gsccorc(j,i)
 532      &               +wscloc*gscloc(j,i)
 533           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 534      &                  wbond*gradbx(j,i)+
 535      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 536      &                  wsccor*gsccorx(j,i)
 537      &                 +wscloc*gsclocx(j,i)
 538         enddo
 539       enddo
 540 #endif
 541 #ifdef DEBUG
 542       write (iout,*) "gloc before adding corr"
 543       do i=1,4*nres
 544         write (iout,*) i,gloc(i,icg)
 545       enddo
 546 #endif
 547       do i=1,nres-3
 548         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 549      &   +wcorr5*g_corr5_loc(i)
 550      &   +wcorr6*g_corr6_loc(i)
 551      &   +wturn4*gel_loc_turn4(i)
 552      &   +wturn3*gel_loc_turn3(i)
 553      &   +wturn6*gel_loc_turn6(i)
 554      &   +wel_loc*gel_loc_loc(i)
 555      &   +wsccor*gsccor_loc(i)
 556       enddo
 557 #ifdef DEBUG
 558       write (iout,*) "gloc after adding corr"
 559       do i=1,4*nres
 560         write (iout,*) i,gloc(i,icg)
 561       enddo
 562 #endif
 563 #ifdef MPI
 564       if (nfgtasks.gt.1) then
 565         do j=1,3
 566           do i=1,nres
 567             gradbufc(j,i)=gradc(j,i,icg)
 568             gradbufx(j,i)=gradx(j,i,icg)
 569           enddo
 570         enddo
 571         do i=1,4*nres
 572           glocbuf(i)=gloc(i,icg)
 573         enddo
 574 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 575         if (fg_rank.eq.0) call MPI_Bcast(1,1,MPI_INTEGER,
 576      &      king,FG_COMM,IERROR)
 577         time00=MPI_Wtime()
 578         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 579      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 580         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 581      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 582         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 583      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 584         time_reduce=time_reduce+MPI_Wtime()-time00
 585 #ifdef DEBUG
 586       write (iout,*) "gloc after reduce"
 587       do i=1,4*nres
 588         write (iout,*) i,gloc(i,icg)
 589       enddo
 590 #endif
 591       endif
 592 #endif
 593       if (gnorm_check) then
 594 c
 595 c Compute the maximum elements of the gradient
 596 c
 597       gvdwc_max=0.0d0
 598       gvdwc_scp_max=0.0d0
 599       gelc_max=0.0d0
 600       gvdwpp_max=0.0d0
 601       gradb_max=0.0d0
 602       ghpbc_max=0.0d0
 603       gradcorr_max=0.0d0
 604       gel_loc_max=0.0d0
 605       gcorr3_turn_max=0.0d0
 606       gcorr4_turn_max=0.0d0
 607       gradcorr5_max=0.0d0
 608       gradcorr6_max=0.0d0
 609       gcorr6_turn_max=0.0d0
 610       gsccorc_max=0.0d0
 611       gscloc_max=0.0d0
 612       gvdwx_max=0.0d0
 613       gradx_scp_max=0.0d0
 614       ghpbx_max=0.0d0
 615       gradxorr_max=0.0d0
 616       gsccorx_max=0.0d0
 617       gsclocx_max=0.0d0
 618       do i=1,nct
 619         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 620         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 621         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 622         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 623      &   gvdwc_scp_max=gvdwc_scp_norm
 624         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 625         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 626         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 627         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 628         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 629         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 630         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 631         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 632         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 633         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 634         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 635         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 636         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 637      &    gcorr3_turn(1,i)))
 638         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 639      &    gcorr3_turn_max=gcorr3_turn_norm
 640         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 641      &    gcorr4_turn(1,i)))
 642         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 643      &    gcorr4_turn_max=gcorr4_turn_norm
 644         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 645         if (gradcorr5_norm.gt.gradcorr5_max)
 646      &    gradcorr5_max=gradcorr5_norm
 647         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 648         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 649         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 650      &    gcorr6_turn(1,i)))
 651         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 652      &    gcorr6_turn_max=gcorr6_turn_norm
 653         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 654         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 655         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 656         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 657         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 658         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 659         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 660         if (gradx_scp_norm.gt.gradx_scp_max)
 661      &    gradx_scp_max=gradx_scp_norm
 662         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 663         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 664         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 665         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 666         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 667         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 668         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 669         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 670       enddo
 671       if (gradout) then
 672 #ifdef AIX
 673         open(istat,file=statname,position="append")
 674 #else
 675         open(istat,file=statname,access="append")
 676 #endif
 677         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 678      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 679      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 680      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 681      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 682      &     gsccorx_max,gsclocx_max
 683         close(istat)
 684         if (gvdwc_max.gt.1.0d4) then
 685           write (iout,*) "gvdwc gvdwx gradb gradbx"
 686           do i=nnt,nct
 687             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 688      &        gradb(j,i),gradbx(j,i),j=1,3)
 689           enddo
 690           call pdbout(0.0d0,'cipiszcze',iout)
 691           call flush(iout)
 692         endif
 693       endif
 694       endif
 695 #ifdef DEBUG
 696       write (iout,*) "gradc gradx gloc"
 697       do i=1,nres
 698         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 699      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 700       enddo
 701 #endif
 702 #ifdef TIMING
 703       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 704 #endif
 705       return
 706       end
 707 c-------------------------------------------------------------------------------
 708       subroutine rescale_weights(t_bath)
 709       implicit real*8 (a-h,o-z)
 710       include 'DIMENSIONS'
 711       include 'COMMON.IOUNITS'
 712       include 'COMMON.FFIELD'
 713       include 'COMMON.SBRIDGE'
 714       double precision kfac /2.4d0/
 715       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 716 c      facT=temp0/t_bath
 717 c      facT=2*temp0/(t_bath+temp0)
 718       if (rescale_mode.eq.0) then
 719         facT=1.0d0
 720         facT2=1.0d0
 721         facT3=1.0d0
 722         facT4=1.0d0
 723         facT5=1.0d0
 724       else if (rescale_mode.eq.1) then
 725         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 726         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 727         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 728         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 729         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 730       else if (rescale_mode.eq.2) then
 731         x=t_bath/temp0
 732         x2=x*x
 733         x3=x2*x
 734         x4=x3*x
 735         x5=x4*x
 736         facT=licznik/dlog(dexp(x)+dexp(-x))
 737         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 738         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 739         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 740         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 741       else
 742         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 743         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 744 #ifdef MPI
 745        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 746 #endif
 747        stop 555
 748       endif
 749       welec=weights(3)*fact
 750       wcorr=weights(4)*fact3
 751       wcorr5=weights(5)*fact4
 752       wcorr6=weights(6)*fact5
 753       wel_loc=weights(7)*fact2
 754       wturn3=weights(8)*fact2
 755       wturn4=weights(9)*fact3
 756       wturn6=weights(10)*fact5
 757       wtor=weights(13)*fact
 758       wtor_d=weights(14)*fact2
 759       wsccor=weights(21)*fact
 760
 761       return
 762       end
 763 C------------------------------------------------------------------------
 764       subroutine enerprint(energia)
 765       implicit real*8 (a-h,o-z)
 766       include 'DIMENSIONS'
 767       include 'COMMON.IOUNITS'
 768       include 'COMMON.FFIELD'
 769       include 'COMMON.SBRIDGE'
 770       include 'COMMON.MD'
 771       double precision energia(0:n_ene)
 772       etot=energia(0)
 773       evdw=energia(1)
 774       evdw2=energia(2)
 775 #ifdef SCP14
 776       evdw2=energia(2)+energia(18)
 777 #else
 778       evdw2=energia(2)
 779 #endif
 780       ees=energia(3)
 781 #ifdef SPLITELE
 782       evdw1=energia(16)
 783 #endif
 784       ecorr=energia(4)
 785       ecorr5=energia(5)
 786       ecorr6=energia(6)
 787       eel_loc=energia(7)
 788       eello_turn3=energia(8)
 789       eello_turn4=energia(9)
 790       eello_turn6=energia(10)
 791       ebe=energia(11)
 792       escloc=energia(12)
 793       etors=energia(13)
 794       etors_d=energia(14)
 795       ehpb=energia(15)
 796       edihcnstr=energia(19)
 797       estr=energia(17)
 798       Uconst=energia(20)
 799       esccor=energia(21)
 800 #ifdef SPLITELE
 801       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 802      &  estr,wbond,ebe,wang,
 803      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 804      &  ecorr,wcorr,
 805      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 806      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 807      &  edihcnstr,ebr*nss,
 808      &  Uconst,etot
 809    10 format (/'Virtual-chain energies:'//
 810      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 811      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 812      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 813      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 814      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 815      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 816      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 817      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 818      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 819      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 820      & ' (SS bridges & dist. cnstr.)'/
 821      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 822      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 823      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 824      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 825      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 826      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 827      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 828      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 829      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 830      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 831      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 832      & 'ETOT=  ',1pE16.6,' (total)')
 833 #else
 834       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 835      &  estr,wbond,ebe,wang,
 836      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 837      &  ecorr,wcorr,
 838      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 839      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 840      &  ebr*nss,Uconst,etot
 841    10 format (/'Virtual-chain energies:'//
 842      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 843      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 844      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 845      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 846      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 847      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 848      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 849      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 850      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 851      & ' (SS bridges & dist. cnstr.)'/
 852      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 853      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 854      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 855      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 856      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 857      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 858      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 859      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 860      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 861      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 862      & 'UCONST=',1pE16.6,' (Constraint energy)'/
 863      & 'ETOT=  ',1pE16.6,' (total)')
 864 #endif
 865       return
 866       end
 867 C-----------------------------------------------------------------------
 868       subroutine elj(evdw)
 869 C
 870 C This subroutine calculates the interaction energy of nonbonded side chains
 871 C assuming the LJ potential of interaction.
 872 C
 873       implicit real*8 (a-h,o-z)
 874       include 'DIMENSIONS'
 875       parameter (accur=1.0d-10)
 876       include 'COMMON.GEO'
 877       include 'COMMON.VAR'
 878       include 'COMMON.LOCAL'
 879       include 'COMMON.CHAIN'
 880       include 'COMMON.DERIV'
 881       include 'COMMON.INTERACT'
 882       include 'COMMON.TORSION'
 883       include 'COMMON.SBRIDGE'
 884       include 'COMMON.NAMES'
 885       include 'COMMON.IOUNITS'
 886       include 'COMMON.CONTACTS'
 887       dimension gg(3)
 888 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 889       evdw=0.0D0
 890       do i=iatsc_s,iatsc_e
 891         itypi=itype(i)
 892         itypi1=itype(i+1)
 893         xi=c(1,nres+i)
 894         yi=c(2,nres+i)
 895         zi=c(3,nres+i)
 896 C Change 12/1/95
 897         num_conti=0
 898 C
 899 C Calculate SC interaction energy.
 900 C
 901         do iint=1,nint_gr(i)
 902 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 903 cd   &                  'iend=',iend(i,iint)
 904           do j=istart(i,iint),iend(i,iint)
 905             itypj=itype(j)
 906             xj=c(1,nres+j)-xi
 907             yj=c(2,nres+j)-yi
 908             zj=c(3,nres+j)-zi
 909 C Change 12/1/95 to calculate four-body interactions
 910             rij=xj*xj+yj*yj+zj*zj
 911             rrij=1.0D0/rij
 912 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 913             eps0ij=eps(itypi,itypj)
 914             fac=rrij**expon2
 915             e1=fac*fac*aa(itypi,itypj)
 916             e2=fac*bb(itypi,itypj)
 917             evdwij=e1+e2
 918 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 919 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 920 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 921 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 922 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 923 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 924             evdw=evdw+evdwij
 925 C
 926 C Calculate the components of the gradient in DC and X
 927 C
 928             fac=-rrij*(e1+evdwij)
 929             gg(1)=xj*fac
 930             gg(2)=yj*fac
 931             gg(3)=zj*fac
 932             do k=1,3
 933               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 934               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 935               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 936               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 937             enddo
 938 cgrad            do k=i,j-1
 939 cgrad              do l=1,3
 940 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 941 cgrad              enddo
 942 cgrad            enddo
 943 C
 944 C 12/1/95, revised on 5/20/97
 945 C
 946 C Calculate the contact function. The ith column of the array JCONT will
 947 C contain the numbers of atoms that make contacts with the atom I (of numbers
 948 C greater than I). The arrays FACONT and GACONT will contain the values of
 949 C the contact function and its derivative.
 950 C
 951 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 952 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 953 C Uncomment next line, if the correlation interactions are contact function only
 954             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 955               rij=dsqrt(rij)
 956               sigij=sigma(itypi,itypj)
 957               r0ij=rs0(itypi,itypj)
 958 C
 959 C Check whether the SC's are not too far to make a contact.
 960 C
 961               rcut=1.5d0*r0ij
 962               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 963 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 964 C
 965               if (fcont.gt.0.0D0) then
 966 C If the SC-SC distance if close to sigma, apply spline.
 967 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 968 cAdam &             fcont1,fprimcont1)
 969 cAdam           fcont1=1.0d0-fcont1
 970 cAdam           if (fcont1.gt.0.0d0) then
 971 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 972 cAdam             fcont=fcont*fcont1
 973 cAdam           endif
 974 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 975 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 976 cga             do k=1,3
 977 cga               gg(k)=gg(k)*eps0ij
 978 cga             enddo
 979 cga             eps0ij=-evdwij*eps0ij
 980 C Uncomment for AL's type of SC correlation interactions.
 981 cadam           eps0ij=-evdwij
 982                 num_conti=num_conti+1
 983                 jcont(num_conti,i)=j
 984                 facont(num_conti,i)=fcont*eps0ij
 985                 fprimcont=eps0ij*fprimcont/rij
 986                 fcont=expon*fcont
 987 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 988 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 989 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 990 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 991                 gacont(1,num_conti,i)=-fprimcont*xj
 992                 gacont(2,num_conti,i)=-fprimcont*yj
 993                 gacont(3,num_conti,i)=-fprimcont*zj
 994 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 995 cd              write (iout,'(2i3,3f10.5)')
 996 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 997               endif
 998             endif
 999           enddo      ! j
1000         enddo        ! iint
1001 C Change 12/1/95
1002         num_cont(i)=num_conti
1003       enddo          ! i
1004       do i=1,nct
1005         do j=1,3
1006           gvdwc(j,i)=expon*gvdwc(j,i)
1007           gvdwx(j,i)=expon*gvdwx(j,i)
1008         enddo
1009       enddo
1010 C******************************************************************************
1011 C
1012 C                              N O T E !!!
1013 C
1014 C To save time, the factor of EXPON has been extracted from ALL components
1015 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1016 C use!
1017 C
1018 C******************************************************************************
1019       return
1020       end
1021 C-----------------------------------------------------------------------------
1022       subroutine eljk(evdw)
1023 C
1024 C This subroutine calculates the interaction energy of nonbonded side chains
1025 C assuming the LJK potential of interaction.
1026 C
1027       implicit real*8 (a-h,o-z)
1028       include 'DIMENSIONS'
1029       include 'COMMON.GEO'
1030       include 'COMMON.VAR'
1031       include 'COMMON.LOCAL'
1032       include 'COMMON.CHAIN'
1033       include 'COMMON.DERIV'
1034       include 'COMMON.INTERACT'
1035       include 'COMMON.IOUNITS'
1036       include 'COMMON.NAMES'
1037       dimension gg(3)
1038       logical scheck
1039 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1040       evdw=0.0D0
1041       do i=iatsc_s,iatsc_e
1042         itypi=itype(i)
1043         itypi1=itype(i+1)
1044         xi=c(1,nres+i)
1045         yi=c(2,nres+i)
1046         zi=c(3,nres+i)
1047 C
1048 C Calculate SC interaction energy.
1049 C
1050         do iint=1,nint_gr(i)
1051           do j=istart(i,iint),iend(i,iint)
1052             itypj=itype(j)
1053             xj=c(1,nres+j)-xi
1054             yj=c(2,nres+j)-yi
1055             zj=c(3,nres+j)-zi
1056             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1057             fac_augm=rrij**expon
1058             e_augm=augm(itypi,itypj)*fac_augm
1059             r_inv_ij=dsqrt(rrij)
1060             rij=1.0D0/r_inv_ij
1061             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1062             fac=r_shift_inv**expon
1063             e1=fac*fac*aa(itypi,itypj)
1064             e2=fac*bb(itypi,itypj)
1065             evdwij=e_augm+e1+e2
1066 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1067 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1068 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1069 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1070 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1071 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1072 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1073             evdw=evdw+evdwij
1074 C
1075 C Calculate the components of the gradient in DC and X
1076 C
1077             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1078             gg(1)=xj*fac
1079             gg(2)=yj*fac
1080             gg(3)=zj*fac
1081             do k=1,3
1082               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1083               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1084               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1085               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1086             enddo
1087 cgrad            do k=i,j-1
1088 cgrad              do l=1,3
1089 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1090 cgrad              enddo
1091 cgrad            enddo
1092           enddo      ! j
1093         enddo        ! iint
1094       enddo          ! i
1095       do i=1,nct
1096         do j=1,3
1097           gvdwc(j,i)=expon*gvdwc(j,i)
1098           gvdwx(j,i)=expon*gvdwx(j,i)
1099         enddo
1100       enddo
1101       return
1102       end
1103 C-----------------------------------------------------------------------------
1104       subroutine ebp(evdw)
1105 C
1106 C This subroutine calculates the interaction energy of nonbonded side chains
1107 C assuming the Berne-Pechukas potential of interaction.
1108 C
1109       implicit real*8 (a-h,o-z)
1110       include 'DIMENSIONS'
1111       include 'COMMON.GEO'
1112       include 'COMMON.VAR'
1113       include 'COMMON.LOCAL'
1114       include 'COMMON.CHAIN'
1115       include 'COMMON.DERIV'
1116       include 'COMMON.NAMES'
1117       include 'COMMON.INTERACT'
1118       include 'COMMON.IOUNITS'
1119       include 'COMMON.CALC'
1120       common /srutu/ icall
1121 c     double precision rrsave(maxdim)
1122       logical lprn
1123       evdw=0.0D0
1124 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1125       evdw=0.0D0
1126 c     if (icall.eq.0) then
1127 c       lprn=.true.
1128 c     else
1129         lprn=.false.
1130 c     endif
1131       ind=0
1132       do i=iatsc_s,iatsc_e
1133         itypi=itype(i)
1134         itypi1=itype(i+1)
1135         xi=c(1,nres+i)
1136         yi=c(2,nres+i)
1137         zi=c(3,nres+i)
1138         dxi=dc_norm(1,nres+i)
1139         dyi=dc_norm(2,nres+i)
1140         dzi=dc_norm(3,nres+i)
1141 c        dsci_inv=dsc_inv(itypi)
1142         dsci_inv=vbld_inv(i+nres)
1143 C
1144 C Calculate SC interaction energy.
1145 C
1146         do iint=1,nint_gr(i)
1147           do j=istart(i,iint),iend(i,iint)
1148             ind=ind+1
1149             itypj=itype(j)
1150 c            dscj_inv=dsc_inv(itypj)
1151             dscj_inv=vbld_inv(j+nres)
1152             chi1=chi(itypi,itypj)
1153             chi2=chi(itypj,itypi)
1154             chi12=chi1*chi2
1155             chip1=chip(itypi)
1156             chip2=chip(itypj)
1157             chip12=chip1*chip2
1158             alf1=alp(itypi)
1159             alf2=alp(itypj)
1160             alf12=0.5D0*(alf1+alf2)
1161 C For diagnostics only!!!
1162 c           chi1=0.0D0
1163 c           chi2=0.0D0
1164 c           chi12=0.0D0
1165 c           chip1=0.0D0
1166 c           chip2=0.0D0
1167 c           chip12=0.0D0
1168 c           alf1=0.0D0
1169 c           alf2=0.0D0
1170 c           alf12=0.0D0
1171             xj=c(1,nres+j)-xi
1172             yj=c(2,nres+j)-yi
1173             zj=c(3,nres+j)-zi
1174             dxj=dc_norm(1,nres+j)
1175             dyj=dc_norm(2,nres+j)
1176             dzj=dc_norm(3,nres+j)
1177             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1178 cd          if (icall.eq.0) then
1179 cd            rrsave(ind)=rrij
1180 cd          else
1181 cd            rrij=rrsave(ind)
1182 cd          endif
1183             rij=dsqrt(rrij)
1184 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1185             call sc_angular
1186 C Calculate whole angle-dependent part of epsilon and contributions
1187 C to its derivatives
1188             fac=(rrij*sigsq)**expon2
1189             e1=fac*fac*aa(itypi,itypj)
1190             e2=fac*bb(itypi,itypj)
1191             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1192             eps2der=evdwij*eps3rt
1193             eps3der=evdwij*eps2rt
1194             evdwij=evdwij*eps2rt*eps3rt
1195             evdw=evdw+evdwij
1196             if (lprn) then
1197             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1198             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1199 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1200 cd     &        restyp(itypi),i,restyp(itypj),j,
1201 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1202 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1203 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1204 cd     &        evdwij
1205             endif
1206 C Calculate gradient components.
1207             e1=e1*eps1*eps2rt**2*eps3rt**2
1208             fac=-expon*(e1+evdwij)
1209             sigder=fac/sigsq
1210             fac=rrij*fac
1211 C Calculate radial part of the gradient
1212             gg(1)=xj*fac
1213             gg(2)=yj*fac
1214             gg(3)=zj*fac
1215 C Calculate the angular part of the gradient and sum add the contributions
1216 C to the appropriate components of the Cartesian gradient.
1217             call sc_grad
1218           enddo      ! j
1219         enddo        ! iint
1220       enddo          ! i
1221 c     stop
1222       return
1223       end
1224 C-----------------------------------------------------------------------------
1225       subroutine egb(evdw)
1226 C
1227 C This subroutine calculates the interaction energy of nonbonded side chains
1228 C assuming the Gay-Berne potential of interaction.
1229 C
1230       implicit real*8 (a-h,o-z)
1231       include 'DIMENSIONS'
1232       include 'COMMON.GEO'
1233       include 'COMMON.VAR'
1234       include 'COMMON.LOCAL'
1235       include 'COMMON.CHAIN'
1236       include 'COMMON.DERIV'
1237       include 'COMMON.NAMES'
1238       include 'COMMON.INTERACT'
1239       include 'COMMON.IOUNITS'
1240       include 'COMMON.CALC'
1241       include 'COMMON.CONTROL'
1242       logical lprn
1243       evdw=0.0D0
1244 ccccc      energy_dec=.false.
1245 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1246       evdw=0.0D0
1247       lprn=.false.
1248 c     if (icall.eq.0) lprn=.false.
1249       ind=0
1250       do i=iatsc_s,iatsc_e
1251         itypi=itype(i)
1252         itypi1=itype(i+1)
1253         xi=c(1,nres+i)
1254         yi=c(2,nres+i)
1255         zi=c(3,nres+i)
1256         dxi=dc_norm(1,nres+i)
1257         dyi=dc_norm(2,nres+i)
1258         dzi=dc_norm(3,nres+i)
1259 c        dsci_inv=dsc_inv(itypi)
1260         dsci_inv=vbld_inv(i+nres)
1261 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1262 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1263 C
1264 C Calculate SC interaction energy.
1265 C
1266         do iint=1,nint_gr(i)
1267           do j=istart(i,iint),iend(i,iint)
1268             ind=ind+1
1269             itypj=itype(j)
1270 c            dscj_inv=dsc_inv(itypj)
1271             dscj_inv=vbld_inv(j+nres)
1272 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1273 c     &       1.0d0/vbld(j+nres)
1274 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1275             sig0ij=sigma(itypi,itypj)
1276             chi1=chi(itypi,itypj)
1277             chi2=chi(itypj,itypi)
1278             chi12=chi1*chi2
1279             chip1=chip(itypi)
1280             chip2=chip(itypj)
1281             chip12=chip1*chip2
1282             alf1=alp(itypi)
1283             alf2=alp(itypj)
1284             alf12=0.5D0*(alf1+alf2)
1285 C For diagnostics only!!!
1286 c           chi1=0.0D0
1287 c           chi2=0.0D0
1288 c           chi12=0.0D0
1289 c           chip1=0.0D0
1290 c           chip2=0.0D0
1291 c           chip12=0.0D0
1292 c           alf1=0.0D0
1293 c           alf2=0.0D0
1294 c           alf12=0.0D0
1295             xj=c(1,nres+j)-xi
1296             yj=c(2,nres+j)-yi
1297             zj=c(3,nres+j)-zi
1298             dxj=dc_norm(1,nres+j)
1299             dyj=dc_norm(2,nres+j)
1300             dzj=dc_norm(3,nres+j)
1301 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1302 c            write (iout,*) "j",j," dc_norm",
1303 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1304             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1305             rij=dsqrt(rrij)
1306 C Calculate angle-dependent terms of energy and contributions to their
1307 C derivatives.
1308             call sc_angular
1309             sigsq=1.0D0/sigsq
1310             sig=sig0ij*dsqrt(sigsq)
1311             rij_shift=1.0D0/rij-sig+sig0ij
1312 c for diagnostics; uncomment
1313 c            rij_shift=1.2*sig0ij
1314 C I hate to put IF's in the loops, but here don't have another choice!!!!
1315             if (rij_shift.le.0.0D0) then
1316               evdw=1.0D20
1317 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1318 cd     &        restyp(itypi),i,restyp(itypj),j,
1319 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1320               return
1321             endif
1322             sigder=-sig*sigsq
1323 c---------------------------------------------------------------
1324             rij_shift=1.0D0/rij_shift
1325             fac=rij_shift**expon
1326             e1=fac*fac*aa(itypi,itypj)
1327             e2=fac*bb(itypi,itypj)
1328             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1329             eps2der=evdwij*eps3rt
1330             eps3der=evdwij*eps2rt
1331 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1332 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1333             evdwij=evdwij*eps2rt*eps3rt
1334             evdw=evdw+evdwij
1335             if (lprn) then
1336             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1337             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1338             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1339      &        restyp(itypi),i,restyp(itypj),j,
1340      &        epsi,sigm,chi1,chi2,chip1,chip2,
1341      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1342      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1343      &        evdwij
1344             endif
1345
1346             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1347      &                        'evdw',i,j,evdwij
1348
1349 C Calculate gradient components.
1350             e1=e1*eps1*eps2rt**2*eps3rt**2
1351             fac=-expon*(e1+evdwij)*rij_shift
1352             sigder=fac*sigder
1353             fac=rij*fac
1354 c            fac=0.0d0
1355 C Calculate the radial part of the gradient
1356             gg(1)=xj*fac
1357             gg(2)=yj*fac
1358             gg(3)=zj*fac
1359 C Calculate angular part of the gradient.
1360             call sc_grad
1361           enddo      ! j
1362         enddo        ! iint
1363       enddo          ! i
1364 c      write (iout,*) "Number of loop steps in EGB:",ind
1365 cccc      energy_dec=.false.
1366       return
1367       end
1368 C-----------------------------------------------------------------------------
1369       subroutine egbv(evdw)
1370 C
1371 C This subroutine calculates the interaction energy of nonbonded side chains
1372 C assuming the Gay-Berne-Vorobjev potential of interaction.
1373 C
1374       implicit real*8 (a-h,o-z)
1375       include 'DIMENSIONS'
1376       include 'COMMON.GEO'
1377       include 'COMMON.VAR'
1378       include 'COMMON.LOCAL'
1379       include 'COMMON.CHAIN'
1380       include 'COMMON.DERIV'
1381       include 'COMMON.NAMES'
1382       include 'COMMON.INTERACT'
1383       include 'COMMON.IOUNITS'
1384       include 'COMMON.CALC'
1385       common /srutu/ icall
1386       logical lprn
1387       evdw=0.0D0
1388 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1389       evdw=0.0D0
1390       lprn=.false.
1391 c     if (icall.eq.0) lprn=.true.
1392       ind=0
1393       do i=iatsc_s,iatsc_e
1394         itypi=itype(i)
1395         itypi1=itype(i+1)
1396         xi=c(1,nres+i)
1397         yi=c(2,nres+i)
1398         zi=c(3,nres+i)
1399         dxi=dc_norm(1,nres+i)
1400         dyi=dc_norm(2,nres+i)
1401         dzi=dc_norm(3,nres+i)
1402 c        dsci_inv=dsc_inv(itypi)
1403         dsci_inv=vbld_inv(i+nres)
1404 C
1405 C Calculate SC interaction energy.
1406 C
1407         do iint=1,nint_gr(i)
1408           do j=istart(i,iint),iend(i,iint)
1409             ind=ind+1
1410             itypj=itype(j)
1411 c            dscj_inv=dsc_inv(itypj)
1412             dscj_inv=vbld_inv(j+nres)
1413             sig0ij=sigma(itypi,itypj)
1414             r0ij=r0(itypi,itypj)
1415             chi1=chi(itypi,itypj)
1416             chi2=chi(itypj,itypi)
1417             chi12=chi1*chi2
1418             chip1=chip(itypi)
1419             chip2=chip(itypj)
1420             chip12=chip1*chip2
1421             alf1=alp(itypi)
1422             alf2=alp(itypj)
1423             alf12=0.5D0*(alf1+alf2)
1424 C For diagnostics only!!!
1425 c           chi1=0.0D0
1426 c           chi2=0.0D0
1427 c           chi12=0.0D0
1428 c           chip1=0.0D0
1429 c           chip2=0.0D0
1430 c           chip12=0.0D0
1431 c           alf1=0.0D0
1432 c           alf2=0.0D0
1433 c           alf12=0.0D0
1434             xj=c(1,nres+j)-xi
1435             yj=c(2,nres+j)-yi
1436             zj=c(3,nres+j)-zi
1437             dxj=dc_norm(1,nres+j)
1438             dyj=dc_norm(2,nres+j)
1439             dzj=dc_norm(3,nres+j)
1440             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1441             rij=dsqrt(rrij)
1442 C Calculate angle-dependent terms of energy and contributions to their
1443 C derivatives.
1444             call sc_angular
1445             sigsq=1.0D0/sigsq
1446             sig=sig0ij*dsqrt(sigsq)
1447             rij_shift=1.0D0/rij-sig+r0ij
1448 C I hate to put IF's in the loops, but here don't have another choice!!!!
1449             if (rij_shift.le.0.0D0) then
1450               evdw=1.0D20
1451               return
1452             endif
1453             sigder=-sig*sigsq
1454 c---------------------------------------------------------------
1455             rij_shift=1.0D0/rij_shift
1456             fac=rij_shift**expon
1457             e1=fac*fac*aa(itypi,itypj)
1458             e2=fac*bb(itypi,itypj)
1459             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1460             eps2der=evdwij*eps3rt
1461             eps3der=evdwij*eps2rt
1462             fac_augm=rrij**expon
1463             e_augm=augm(itypi,itypj)*fac_augm
1464             evdwij=evdwij*eps2rt*eps3rt
1465             evdw=evdw+evdwij+e_augm
1466             if (lprn) then
1467             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1468             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1469             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1470      &        restyp(itypi),i,restyp(itypj),j,
1471      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1472      &        chi1,chi2,chip1,chip2,
1473      &        eps1,eps2rt**2,eps3rt**2,
1474      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1475      &        evdwij+e_augm
1476             endif
1477 C Calculate gradient components.
1478             e1=e1*eps1*eps2rt**2*eps3rt**2
1479             fac=-expon*(e1+evdwij)*rij_shift
1480             sigder=fac*sigder
1481             fac=rij*fac-2*expon*rrij*e_augm
1482 C Calculate the radial part of the gradient
1483             gg(1)=xj*fac
1484             gg(2)=yj*fac
1485             gg(3)=zj*fac
1486 C Calculate angular part of the gradient.
1487             call sc_grad
1488           enddo      ! j
1489         enddo        ! iint
1490       enddo          ! i
1491       end
1492 C-----------------------------------------------------------------------------
1493       subroutine sc_angular
1494 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1495 C om12. Called by ebp, egb, and egbv.
1496       implicit none
1497       include 'COMMON.CALC'
1498       include 'COMMON.IOUNITS'
1499       erij(1)=xj*rij
1500       erij(2)=yj*rij
1501       erij(3)=zj*rij
1502       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1503       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1504       om12=dxi*dxj+dyi*dyj+dzi*dzj
1505       chiom12=chi12*om12
1506 C Calculate eps1(om12) and its derivative in om12
1507       faceps1=1.0D0-om12*chiom12
1508       faceps1_inv=1.0D0/faceps1
1509       eps1=dsqrt(faceps1_inv)
1510 C Following variable is eps1*deps1/dom12
1511       eps1_om12=faceps1_inv*chiom12
1512 c diagnostics only
1513 c      faceps1_inv=om12
1514 c      eps1=om12
1515 c      eps1_om12=1.0d0
1516 c      write (iout,*) "om12",om12," eps1",eps1
1517 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1518 C and om12.
1519       om1om2=om1*om2
1520       chiom1=chi1*om1
1521       chiom2=chi2*om2
1522       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1523       sigsq=1.0D0-facsig*faceps1_inv
1524       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1525       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1526       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1527 c diagnostics only
1528 c      sigsq=1.0d0
1529 c      sigsq_om1=0.0d0
1530 c      sigsq_om2=0.0d0
1531 c      sigsq_om12=0.0d0
1532 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1533 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1534 c     &    " eps1",eps1
1535 C Calculate eps2 and its derivatives in om1, om2, and om12.
1536       chipom1=chip1*om1
1537       chipom2=chip2*om2
1538       chipom12=chip12*om12
1539       facp=1.0D0-om12*chipom12
1540       facp_inv=1.0D0/facp
1541       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1542 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1543 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1544 C Following variable is the square root of eps2
1545       eps2rt=1.0D0-facp1*facp_inv
1546 C Following three variables are the derivatives of the square root of eps
1547 C in om1, om2, and om12.
1548       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1549       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1550       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1551 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1552       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1553 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1554 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1555 c     &  " eps2rt_om12",eps2rt_om12
1556 C Calculate whole angle-dependent part of epsilon and contributions
1557 C to its derivatives
1558       return
1559       end
1560 C----------------------------------------------------------------------------
1561       subroutine sc_grad
1562       implicit real*8 (a-h,o-z)
1563       include 'DIMENSIONS'
1564       include 'COMMON.CHAIN'
1565       include 'COMMON.DERIV'
1566       include 'COMMON.CALC'
1567       include 'COMMON.IOUNITS'
1568       double precision dcosom1(3),dcosom2(3)
1569       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1570       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1571       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1572      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1573 c diagnostics only
1574 c      eom1=0.0d0
1575 c      eom2=0.0d0
1576 c      eom12=evdwij*eps1_om12
1577 c end diagnostics
1578 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1579 c     &  " sigder",sigder
1580 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1581 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1582       do k=1,3
1583         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1584         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1585       enddo
1586       do k=1,3
1587         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1588       enddo
1589 c      write (iout,*) "gg",(gg(k),k=1,3)
1590       do k=1,3
1591         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1592      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1593      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1594         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1595      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1596      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1597 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1598 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1599 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1600 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1601       enddo
1602 C
1603 C Calculate the components of the gradient in DC and X
1604 C
1605 cgrad      do k=i,j-1
1606 cgrad        do l=1,3
1607 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1608 cgrad        enddo
1609 cgrad      enddo
1610       do l=1,3
1611         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1612         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1613       enddo
1614       return
1615       end
1616 C-----------------------------------------------------------------------
1617       subroutine e_softsphere(evdw)
1618 C
1619 C This subroutine calculates the interaction energy of nonbonded side chains
1620 C assuming the LJ potential of interaction.
1621 C
1622       implicit real*8 (a-h,o-z)
1623       include 'DIMENSIONS'
1624       parameter (accur=1.0d-10)
1625       include 'COMMON.GEO'
1626       include 'COMMON.VAR'
1627       include 'COMMON.LOCAL'
1628       include 'COMMON.CHAIN'
1629       include 'COMMON.DERIV'
1630       include 'COMMON.INTERACT'
1631       include 'COMMON.TORSION'
1632       include 'COMMON.SBRIDGE'
1633       include 'COMMON.NAMES'
1634       include 'COMMON.IOUNITS'
1635       include 'COMMON.CONTACTS'
1636       dimension gg(3)
1637 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1638       evdw=0.0D0
1639       do i=iatsc_s,iatsc_e
1640         itypi=itype(i)
1641         itypi1=itype(i+1)
1642         xi=c(1,nres+i)
1643         yi=c(2,nres+i)
1644         zi=c(3,nres+i)
1645 C
1646 C Calculate SC interaction energy.
1647 C
1648         do iint=1,nint_gr(i)
1649 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1650 cd   &                  'iend=',iend(i,iint)
1651           do j=istart(i,iint),iend(i,iint)
1652             itypj=itype(j)
1653             xj=c(1,nres+j)-xi
1654             yj=c(2,nres+j)-yi
1655             zj=c(3,nres+j)-zi
1656             rij=xj*xj+yj*yj+zj*zj
1657 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1658             r0ij=r0(itypi,itypj)
1659             r0ijsq=r0ij*r0ij
1660 c            print *,i,j,r0ij,dsqrt(rij)
1661             if (rij.lt.r0ijsq) then
1662               evdwij=0.25d0*(rij-r0ijsq)**2
1663               fac=rij-r0ijsq
1664             else
1665               evdwij=0.0d0
1666               fac=0.0d0
1667             endif
1668             evdw=evdw+evdwij
1669 C
1670 C Calculate the components of the gradient in DC and X
1671 C
1672             gg(1)=xj*fac
1673             gg(2)=yj*fac
1674             gg(3)=zj*fac
1675             do k=1,3
1676               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1677               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1678               gvdwc(k,i)=gvdwc(l,k)-gg(k)
1679               gvdwc(k,j)=gvdwc(l,k)+gg(k)
1680             enddo
1681 cgrad            do k=i,j-1
1682 cgrad              do l=1,3
1683 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1684 cgrad              enddo
1685 cgrad            enddo
1686           enddo ! j
1687         enddo ! iint
1688       enddo ! i
1689       return
1690       end
1691 C--------------------------------------------------------------------------
1692       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1693      &              eello_turn4)
1694 C
1695 C Soft-sphere potential of p-p interaction
1696 C
1697       implicit real*8 (a-h,o-z)
1698       include 'DIMENSIONS'
1699       include 'COMMON.CONTROL'
1700       include 'COMMON.IOUNITS'
1701       include 'COMMON.GEO'
1702       include 'COMMON.VAR'
1703       include 'COMMON.LOCAL'
1704       include 'COMMON.CHAIN'
1705       include 'COMMON.DERIV'
1706       include 'COMMON.INTERACT'
1707       include 'COMMON.CONTACTS'
1708       include 'COMMON.TORSION'
1709       include 'COMMON.VECTORS'
1710       include 'COMMON.FFIELD'
1711       dimension ggg(3)
1712 cd      write(iout,*) 'In EELEC_soft_sphere'
1713       ees=0.0D0
1714       evdw1=0.0D0
1715       eel_loc=0.0d0
1716       eello_turn3=0.0d0
1717       eello_turn4=0.0d0
1718       ind=0
1719       do i=iatel_s,iatel_e
1720         dxi=dc(1,i)
1721         dyi=dc(2,i)
1722         dzi=dc(3,i)
1723         xmedi=c(1,i)+0.5d0*dxi
1724         ymedi=c(2,i)+0.5d0*dyi
1725         zmedi=c(3,i)+0.5d0*dzi
1726         num_conti=0
1727 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1728         do j=ielstart(i),ielend(i)
1729           ind=ind+1
1730           iteli=itel(i)
1731           itelj=itel(j)
1732           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1733           r0ij=rpp(iteli,itelj)
1734           r0ijsq=r0ij*r0ij
1735           dxj=dc(1,j)
1736           dyj=dc(2,j)
1737           dzj=dc(3,j)
1738           xj=c(1,j)+0.5D0*dxj-xmedi
1739           yj=c(2,j)+0.5D0*dyj-ymedi
1740           zj=c(3,j)+0.5D0*dzj-zmedi
1741           rij=xj*xj+yj*yj+zj*zj
1742           if (rij.lt.r0ijsq) then
1743             evdw1ij=0.25d0*(rij-r0ijsq)**2
1744             fac=rij-r0ijsq
1745           else
1746             evdw1ij=0.0d0
1747             fac=0.0d0
1748           endif
1749           evdw1=evdw1+evdw1ij
1750 C
1751 C Calculate contributions to the Cartesian gradient.
1752 C
1753           ggg(1)=fac*xj
1754           ggg(2)=fac*yj
1755           ggg(3)=fac*zj
1756           do k=1,3
1757             gelc(k,i)=gelc(k,i)-ggg(k)
1758             gelc(k,j)=gelc(k,j)+ggg(k)
1759           enddo
1760 *
1761 * Loop over residues i+1 thru j-1.
1762 *
1763 cgrad          do k=i+1,j-1
1764 cgrad            do l=1,3
1765 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1766 cgrad            enddo
1767 cgrad          enddo
1768         enddo ! j
1769       enddo   ! i
1770       do i=nnt,nct-1
1771         do k=1,3
1772           gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1773         enddo
1774         do j=i+1,nct-1
1775           do k=1,3
1776             gelc(k,i)=gelc(k,i)+gelc(k,j)
1777           enddo
1778         enddo
1779       enddo
1780       return
1781       end
1782 c------------------------------------------------------------------------------
1783       subroutine vec_and_deriv
1784       implicit real*8 (a-h,o-z)
1785       include 'DIMENSIONS'
1786 #ifdef MPI
1787       include 'mpif.h'
1788 #endif
1789       include 'COMMON.IOUNITS'
1790       include 'COMMON.GEO'
1791       include 'COMMON.VAR'
1792       include 'COMMON.LOCAL'
1793       include 'COMMON.CHAIN'
1794       include 'COMMON.VECTORS'
1795       include 'COMMON.SETUP'
1796       include 'COMMON.TIME1'
1797       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1798 C Compute the local reference systems. For reference system (i), the
1799 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1800 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1801 #ifdef PARVEC
1802       do i=ivec_start,ivec_end
1803 #else
1804       do i=1,nres-1
1805 #endif
1806           if (i.eq.nres-1) then
1807 C Case of the last full residue
1808 C Compute the Z-axis
1809             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1810             costh=dcos(pi-theta(nres))
1811             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1812             do k=1,3
1813               uz(k,i)=fac*uz(k,i)
1814             enddo
1815 C Compute the derivatives of uz
1816             uzder(1,1,1)= 0.0d0
1817             uzder(2,1,1)=-dc_norm(3,i-1)
1818             uzder(3,1,1)= dc_norm(2,i-1)
1819             uzder(1,2,1)= dc_norm(3,i-1)
1820             uzder(2,2,1)= 0.0d0
1821             uzder(3,2,1)=-dc_norm(1,i-1)
1822             uzder(1,3,1)=-dc_norm(2,i-1)
1823             uzder(2,3,1)= dc_norm(1,i-1)
1824             uzder(3,3,1)= 0.0d0
1825             uzder(1,1,2)= 0.0d0
1826             uzder(2,1,2)= dc_norm(3,i)
1827             uzder(3,1,2)=-dc_norm(2,i)
1828             uzder(1,2,2)=-dc_norm(3,i)
1829             uzder(2,2,2)= 0.0d0
1830             uzder(3,2,2)= dc_norm(1,i)
1831             uzder(1,3,2)= dc_norm(2,i)
1832             uzder(2,3,2)=-dc_norm(1,i)
1833             uzder(3,3,2)= 0.0d0
1834 C Compute the Y-axis
1835             facy=fac
1836             do k=1,3
1837               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1838             enddo
1839 C Compute the derivatives of uy
1840             do j=1,3
1841               do k=1,3
1842                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1843      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1844                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1845               enddo
1846               uyder(j,j,1)=uyder(j,j,1)-costh
1847               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1848             enddo
1849             do j=1,2
1850               do k=1,3
1851                 do l=1,3
1852                   uygrad(l,k,j,i)=uyder(l,k,j)
1853                   uzgrad(l,k,j,i)=uzder(l,k,j)
1854                 enddo
1855               enddo
1856             enddo
1857             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1858             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1859             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1860             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1861           else
1862 C Other residues
1863 C Compute the Z-axis
1864             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1865             costh=dcos(pi-theta(i+2))
1866             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1867             do k=1,3
1868               uz(k,i)=fac*uz(k,i)
1869             enddo
1870 C Compute the derivatives of uz
1871             uzder(1,1,1)= 0.0d0
1872             uzder(2,1,1)=-dc_norm(3,i+1)
1873             uzder(3,1,1)= dc_norm(2,i+1)
1874             uzder(1,2,1)= dc_norm(3,i+1)
1875             uzder(2,2,1)= 0.0d0
1876             uzder(3,2,1)=-dc_norm(1,i+1)
1877             uzder(1,3,1)=-dc_norm(2,i+1)
1878             uzder(2,3,1)= dc_norm(1,i+1)
1879             uzder(3,3,1)= 0.0d0
1880             uzder(1,1,2)= 0.0d0
1881             uzder(2,1,2)= dc_norm(3,i)
1882             uzder(3,1,2)=-dc_norm(2,i)
1883             uzder(1,2,2)=-dc_norm(3,i)
1884             uzder(2,2,2)= 0.0d0
1885             uzder(3,2,2)= dc_norm(1,i)
1886             uzder(1,3,2)= dc_norm(2,i)
1887             uzder(2,3,2)=-dc_norm(1,i)
1888             uzder(3,3,2)= 0.0d0
1889 C Compute the Y-axis
1890             facy=fac
1891             do k=1,3
1892               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1893             enddo
1894 C Compute the derivatives of uy
1895             do j=1,3
1896               do k=1,3
1897                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1898      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1899                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1900               enddo
1901               uyder(j,j,1)=uyder(j,j,1)-costh
1902               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1903             enddo
1904             do j=1,2
1905               do k=1,3
1906                 do l=1,3
1907                   uygrad(l,k,j,i)=uyder(l,k,j)
1908                   uzgrad(l,k,j,i)=uzder(l,k,j)
1909                 enddo
1910               enddo
1911             enddo
1912             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1913             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1914             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1915             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1916           endif
1917       enddo
1918       do i=1,nres-1
1919         vbld_inv_temp(1)=vbld_inv(i+1)
1920         if (i.lt.nres-1) then
1921           vbld_inv_temp(2)=vbld_inv(i+2)
1922           else
1923           vbld_inv_temp(2)=vbld_inv(i)
1924           endif
1925         do j=1,2
1926           do k=1,3
1927             do l=1,3
1928               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1929               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1930             enddo
1931           enddo
1932         enddo
1933       enddo
1934 #if defined(PARVEC) && defined(MPI)
1935       if (nfgtasks.gt.1) then
1936         time00=MPI_Wtime()
1937 c        print *,"Processor",fg_rank,kolor," ivec_start",ivec_start,
1938 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
1939 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
1940         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank),
1941      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1942      &   FG_COMM,IERR)
1943         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank),
1944      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1945      &   FG_COMM,IERR)
1946         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
1947      &   ivec_count(fg_rank),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
1948      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1949         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
1950      &   ivec_count(fg_rank),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
1951      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1952         time_gather=time_gather+MPI_Wtime()-time00
1953       endif
1954 c      if (fg_rank.eq.0) then
1955 c        write (iout,*) "Arrays UY and UZ"
1956 c        do i=1,nres-1
1957 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1958 c     &     (uz(k,i),k=1,3)
1959 c        enddo
1960 c      endif
1961 #endif
1962       return
1963       end
1964 C-----------------------------------------------------------------------------
1965       subroutine check_vecgrad
1966       implicit real*8 (a-h,o-z)
1967       include 'DIMENSIONS'
1968       include 'COMMON.IOUNITS'
1969       include 'COMMON.GEO'
1970       include 'COMMON.VAR'
1971       include 'COMMON.LOCAL'
1972       include 'COMMON.CHAIN'
1973       include 'COMMON.VECTORS'
1974       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1975       dimension uyt(3,maxres),uzt(3,maxres)
1976       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1977       double precision delta /1.0d-7/
1978       call vec_and_deriv
1979 cd      do i=1,nres
1980 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1981 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1982 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1983 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1984 cd     &     (dc_norm(if90,i),if90=1,3)
1985 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1986 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1987 cd          write(iout,'(a)')
1988 cd      enddo
1989       do i=1,nres
1990         do j=1,2
1991           do k=1,3
1992             do l=1,3
1993               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1994               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1995             enddo
1996           enddo
1997         enddo
1998       enddo
1999       call vec_and_deriv
2000       do i=1,nres
2001         do j=1,3
2002           uyt(j,i)=uy(j,i)
2003           uzt(j,i)=uz(j,i)
2004         enddo
2005       enddo
2006       do i=1,nres
2007 cd        write (iout,*) 'i=',i
2008         do k=1,3
2009           erij(k)=dc_norm(k,i)
2010         enddo
2011         do j=1,3
2012           do k=1,3
2013             dc_norm(k,i)=erij(k)
2014           enddo
2015           dc_norm(j,i)=dc_norm(j,i)+delta
2016 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2017 c          do k=1,3
2018 c            dc_norm(k,i)=dc_norm(k,i)/fac
2019 c          enddo
2020 c          write (iout,*) (dc_norm(k,i),k=1,3)
2021 c          write (iout,*) (erij(k),k=1,3)
2022           call vec_and_deriv
2023           do k=1,3
2024             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2025             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2026             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2027             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2028           enddo
2029 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2030 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2031 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2032         enddo
2033         do k=1,3
2034           dc_norm(k,i)=erij(k)
2035         enddo
2036 cd        do k=1,3
2037 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2038 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2039 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2040 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2041 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2042 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2043 cd          write (iout,'(a)')
2044 cd        enddo
2045       enddo
2046       return
2047       end
2048 C--------------------------------------------------------------------------
2049       subroutine set_matrices
2050       implicit real*8 (a-h,o-z)
2051       include 'DIMENSIONS'
2052 #ifdef MPI
2053       include "mpif.h"
2054       include "COMMON.SETUP"
2055       integer IERR
2056       integer status(MPI_STATUS_SIZE)
2057 #endif
2058       include 'COMMON.IOUNITS'
2059       include 'COMMON.GEO'
2060       include 'COMMON.VAR'
2061       include 'COMMON.LOCAL'
2062       include 'COMMON.CHAIN'
2063       include 'COMMON.DERIV'
2064       include 'COMMON.INTERACT'
2065       include 'COMMON.CONTACTS'
2066       include 'COMMON.TORSION'
2067       include 'COMMON.VECTORS'
2068       include 'COMMON.FFIELD'
2069       double precision auxvec(2),auxmat(2,2)
2070 C
2071 C Compute the virtual-bond-torsional-angle dependent quantities needed
2072 C to calculate the el-loc multibody terms of various order.
2073 C
2074 #ifdef PARMAT
2075       do i=ivec_start+2,ivec_end+2
2076 #else
2077       do i=3,nres+1
2078 #endif
2079         if (i .lt. nres+1) then
2080           sin1=dsin(phi(i))
2081           cos1=dcos(phi(i))
2082           sintab(i-2)=sin1
2083           costab(i-2)=cos1
2084           obrot(1,i-2)=cos1
2085           obrot(2,i-2)=sin1
2086           sin2=dsin(2*phi(i))
2087           cos2=dcos(2*phi(i))
2088           sintab2(i-2)=sin2
2089           costab2(i-2)=cos2
2090           obrot2(1,i-2)=cos2
2091           obrot2(2,i-2)=sin2
2092           Ug(1,1,i-2)=-cos1
2093           Ug(1,2,i-2)=-sin1
2094           Ug(2,1,i-2)=-sin1
2095           Ug(2,2,i-2)= cos1
2096           Ug2(1,1,i-2)=-cos2
2097           Ug2(1,2,i-2)=-sin2
2098           Ug2(2,1,i-2)=-sin2
2099           Ug2(2,2,i-2)= cos2
2100         else
2101           costab(i-2)=1.0d0
2102           sintab(i-2)=0.0d0
2103           obrot(1,i-2)=1.0d0
2104           obrot(2,i-2)=0.0d0
2105           obrot2(1,i-2)=0.0d0
2106           obrot2(2,i-2)=0.0d0
2107           Ug(1,1,i-2)=1.0d0
2108           Ug(1,2,i-2)=0.0d0
2109           Ug(2,1,i-2)=0.0d0
2110           Ug(2,2,i-2)=1.0d0
2111           Ug2(1,1,i-2)=0.0d0
2112           Ug2(1,2,i-2)=0.0d0
2113           Ug2(2,1,i-2)=0.0d0
2114           Ug2(2,2,i-2)=0.0d0
2115         endif
2116         if (i .gt. 3 .and. i .lt. nres+1) then
2117           obrot_der(1,i-2)=-sin1
2118           obrot_der(2,i-2)= cos1
2119           Ugder(1,1,i-2)= sin1
2120           Ugder(1,2,i-2)=-cos1
2121           Ugder(2,1,i-2)=-cos1
2122           Ugder(2,2,i-2)=-sin1
2123           dwacos2=cos2+cos2
2124           dwasin2=sin2+sin2
2125           obrot2_der(1,i-2)=-dwasin2
2126           obrot2_der(2,i-2)= dwacos2
2127           Ug2der(1,1,i-2)= dwasin2
2128           Ug2der(1,2,i-2)=-dwacos2
2129           Ug2der(2,1,i-2)=-dwacos2
2130           Ug2der(2,2,i-2)=-dwasin2
2131         else
2132           obrot_der(1,i-2)=0.0d0
2133           obrot_der(2,i-2)=0.0d0
2134           Ugder(1,1,i-2)=0.0d0
2135           Ugder(1,2,i-2)=0.0d0
2136           Ugder(2,1,i-2)=0.0d0
2137           Ugder(2,2,i-2)=0.0d0
2138           obrot2_der(1,i-2)=0.0d0
2139           obrot2_der(2,i-2)=0.0d0
2140           Ug2der(1,1,i-2)=0.0d0
2141           Ug2der(1,2,i-2)=0.0d0
2142           Ug2der(2,1,i-2)=0.0d0
2143           Ug2der(2,2,i-2)=0.0d0
2144         endif
2145 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2146         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2147           iti = itortyp(itype(i-2))
2148         else
2149           iti=ntortyp+1
2150         endif
2151 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2152         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2153           iti1 = itortyp(itype(i-1))
2154         else
2155           iti1=ntortyp+1
2156         endif
2157 cd        write (iout,*) '*******i',i,' iti1',iti
2158 cd        write (iout,*) 'b1',b1(:,iti)
2159 cd        write (iout,*) 'b2',b2(:,iti)
2160 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2161 c        if (i .gt. iatel_s+2) then
2162         if (i .gt. nnt+2) then
2163           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2164           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2165           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2166      &    then
2167           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2168           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2169           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2170           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2171           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2172           endif
2173         else
2174           do k=1,2
2175             Ub2(k,i-2)=0.0d0
2176             Ctobr(k,i-2)=0.0d0
2177             Dtobr2(k,i-2)=0.0d0
2178             do l=1,2
2179               EUg(l,k,i-2)=0.0d0
2180               CUg(l,k,i-2)=0.0d0
2181               DUg(l,k,i-2)=0.0d0
2182               DtUg2(l,k,i-2)=0.0d0
2183             enddo
2184           enddo
2185         endif
2186         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2187         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2188         do k=1,2
2189           muder(k,i-2)=Ub2der(k,i-2)
2190         enddo
2191 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2192         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2193           iti1 = itortyp(itype(i-1))
2194         else
2195           iti1=ntortyp+1
2196         endif
2197         do k=1,2
2198           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2199         enddo
2200 cd        write (iout,*) 'mu ',mu(:,i-2)
2201 cd        write (iout,*) 'mu1',mu1(:,i-2)
2202 cd        write (iout,*) 'mu2',mu2(:,i-2)
2203         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2204      &  then
2205         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2206         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2207         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2208         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2209         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2210 C Vectors and matrices dependent on a single virtual-bond dihedral.
2211         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2212         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2213         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2214         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2215         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2216         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2217         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2218         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2219         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2220         endif
2221       enddo
2222 C Matrices dependent on two consecutive virtual-bond dihedrals.
2223 C The order of matrices is from left to right.
2224       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2225      &then
2226       do i=ivec_start,ivec_end
2227 c      do i=2,nres-1
2228         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2229         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2230         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2231         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2232         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2233         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2234         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2235         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2236       enddo
2237       endif
2238 #if defined(MPI) && defined(PARMAT)
2239 #ifdef DEBUG
2240 c      if (fg_rank.eq.0) then
2241         write (iout,*) "Arrays UG and UGDER before GATHER"
2242         do i=1,nres-1
2243           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2244      &     ((ug(l,k,i),l=1,2),k=1,2),
2245      &     ((ugder(l,k,i),l=1,2),k=1,2)
2246         enddo
2247         write (iout,*) "Arrays UG2 and UG2DER"
2248         do i=1,nres-1
2249           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2250      &     ((ug2(l,k,i),l=1,2),k=1,2),
2251      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2252         enddo
2253         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2254         do i=1,nres-1
2255           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2256      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2257      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2258         enddo
2259         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2260         do i=1,nres-1
2261           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2262      &     costab(i),sintab(i),costab2(i),sintab2(i)
2263         enddo
2264         write (iout,*) "Array MUDER"
2265         do i=1,nres-1
2266           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2267         enddo
2268 c      endif
2269 #endif
2270       if (nfgtasks.gt.1) then
2271         time00=MPI_Wtime()
2272 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2273 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2274 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2275 #ifdef MATGATHER
2276 c        write (iout,*) "MPI_ROTAT",MPI_ROTAT
2277 c        call MPI_Allgatherv(ug(1,1,ivec_start),ivec_count(fg_rank),
2278 c     &   MPI_MAT1,ug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2279 c     &   FG_COMM,IERR)
2280 c        call MPI_Allgatherv(ugder(1,1,ivec_start),ivec_count(fg_rank),
2281 c     &   MPI_MAT1,ugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2282 c     &   FG_COMM,IERR)
2283 c        call MPI_Allgatherv(ug2(1,1,ivec_start),ivec_count(fg_rank),
2284 c     &   MPI_MAT1,ug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2285 c     &   FG_COMM,IERR)
2286 c        call MPI_Allgatherv(ug2der(1,1,ivec_start),ivec_count(fg_rank),
2287 c     &   MPI_MAT1,ug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2288 c     &   FG_COMM,IERR)
2289 c        call MPI_Allgatherv(obrot(1,ivec_start),ivec_count(fg_rank),
2290 c     &   MPI_MU,obrot(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2291 c     &   FG_COMM,IERR)
2292 c        call MPI_Allgatherv(obrot2(1,ivec_start),ivec_count(fg_rank),
2293 c     &   MPI_MU,obrot2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2294 c     &   FG_COMM,IERR)
2295 c        call MPI_Allgatherv(obrot_der(1,ivec_start),ivec_count(fg_rank),
2296 c     &   MPI_MU,obrot_der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2297 c     &   FG_COMM,IERR)
2298 c        call MPI_Allgatherv(obrot2_der(1,ivec_start),
2299 c     &   ivec_count(fg_rank),
2300 c     &   MPI_MU,obrot2_der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2301 c     &   FG_COMM,IERR)
2302         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank),
2303      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2304      &   FG_COMM,IERR)
2305         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank),
2306      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2307      &   FG_COMM,IERR)
2308         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank),
2309      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2310      &   FG_COMM,IERR)
2311         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank),
2312      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2313      &   FG_COMM,IERR)
2314         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank),
2315      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2316      &   FG_COMM,IERR)
2317         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank),
2318      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2319      &   FG_COMM,IERR)
2320         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank),
2321      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2322      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2323         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank),
2324      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2325      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2326         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank),
2327      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2328      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2329         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank),
2330      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2331      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2332         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2333      &  then
2334         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank),
2335      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2336      &   FG_COMM,IERR)
2337         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank),
2338      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2339      &   FG_COMM,IERR)
2340         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank),
2341      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2342      &   FG_COMM,IERR)
2343         call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank),
2344      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2345      &   FG_COMM,IERR)
2346         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank),
2347      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2348      &   FG_COMM,IERR)
2349         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2350      &   ivec_count(fg_rank),
2351      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2352      &   FG_COMM,IERR)
2353         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank),
2354      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2355      &   FG_COMM,IERR)
2356         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank),
2357      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2358      &   FG_COMM,IERR)
2359         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank),
2360      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2361      &   FG_COMM,IERR)
2362         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank),
2363      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2364      &   FG_COMM,IERR)
2365         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank),
2366      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2367      &   FG_COMM,IERR)
2368         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank),
2369      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2370      &   FG_COMM,IERR)
2371         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank),
2372      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2373      &   FG_COMM,IERR)
2374         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2375      &   ivec_count(fg_rank),
2376      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2377      &   FG_COMM,IERR)
2378         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank),
2379      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2380      &   FG_COMM,IERR)
2381         call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank),
2382      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2383      &   FG_COMM,IERR)
2384         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank),
2385      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2386      &   FG_COMM,IERR)
2387         call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank),
2388      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2389      &   FG_COMM,IERR)
2390         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2391      &   ivec_count(fg_rank),
2392      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2393      &   FG_COMM,IERR)
2394         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2395      &   ivec_count(fg_rank),
2396      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2397      &   FG_COMM,IERR)
2398         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2399      &   ivec_count(fg_rank),
2400      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2401      &   MPI_MAT2,FG_COMM,IERR)
2402         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2403      &   ivec_count(fg_rank),
2404      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2405      &   MPI_MAT2,FG_COMM,IERR)
2406         endif
2407 #else
2408 c Passes matrix info through the ring
2409       isend=fg_rank
2410       irecv=fg_rank-1
2411       if (irecv.lt.0) irecv=nfgtasks-1
2412       iprev=irecv
2413       inext=fg_rank+1
2414       if (inext.ge.nfgtasks) inext=0
2415       do i=1,nfgtasks-1
2416 c        write (iout,*) "isend",isend," irecv",irecv
2417 c        call flush(iout)
2418         lensend=lentyp(isend)
2419         lenrecv=lentyp(irecv)
2420 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2421 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2422 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2423 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2424 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2425 c        write (iout,*) "Gather ROTAT1"
2426 c        call flush(iout)
2427 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2428 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2429 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2430 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2431 c        write (iout,*) "Gather ROTAT2"
2432 c        call flush(iout)
2433         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2434      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2435      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2436      &   iprev,4400+irecv,FG_COMM,status,IERR)
2437 c        write (iout,*) "Gather ROTAT_OLD"
2438 c        call flush(iout)
2439         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2440      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2441      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2442      &   iprev,5500+irecv,FG_COMM,status,IERR)
2443 c        write (iout,*) "Gather PRECOMP11"
2444 c        call flush(iout)
2445         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2446      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2447      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2448      &   iprev,6600+irecv,FG_COMM,status,IERR)
2449 c        write (iout,*) "Gather PRECOMP12"
2450 c        call flush(iout)
2451         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2452      &  then
2453         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2454      &   MPI_ROTAT2(lensend),inext,7700+isend,
2455      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2456      &   iprev,7700+irecv,FG_COMM,status,IERR)
2457 c        write (iout,*) "Gather PRECOMP21"
2458 c        call flush(iout)
2459         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2460      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2461      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2462      &   iprev,8800+irecv,FG_COMM,status,IERR)
2463 c        write (iout,*) "Gather PRECOMP22"
2464 c        call flush(iout)
2465         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2466      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2467      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2468      &   MPI_PRECOMP23(lenrecv),
2469      &   iprev,9900+irecv,FG_COMM,status,IERR)
2470 c        write (iout,*) "Gather PRECOMP23"
2471 c        call flush(iout)
2472         endif
2473         isend=irecv
2474         irecv=irecv-1
2475         if (irecv.lt.0) irecv=nfgtasks-1
2476       enddo
2477 #endif
2478         time_gather=time_gather+MPI_Wtime()-time00
2479       endif
2480 #ifdef DEBUG
2481 c      if (fg_rank.eq.0) then
2482         write (iout,*) "Arrays UG and UGDER"
2483         do i=1,nres-1
2484           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2485      &     ((ug(l,k,i),l=1,2),k=1,2),
2486      &     ((ugder(l,k,i),l=1,2),k=1,2)
2487         enddo
2488         write (iout,*) "Arrays UG2 and UG2DER"
2489         do i=1,nres-1
2490           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2491      &     ((ug2(l,k,i),l=1,2),k=1,2),
2492      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2493         enddo
2494         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2495         do i=1,nres-1
2496           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2497      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2498      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2499         enddo
2500         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2501         do i=1,nres-1
2502           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2503      &     costab(i),sintab(i),costab2(i),sintab2(i)
2504         enddo
2505         write (iout,*) "Array MUDER"
2506         do i=1,nres-1
2507           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2508         enddo
2509 c      endif
2510 #endif
2511 #endif
2512 cd      do i=1,nres
2513 cd        iti = itortyp(itype(i))
2514 cd        write (iout,*) i
2515 cd        do j=1,2
2516 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2517 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2518 cd        enddo
2519 cd      enddo
2520       return
2521       end
2522 C--------------------------------------------------------------------------
2523       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2524 C
2525 C This subroutine calculates the average interaction energy and its gradient
2526 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2527 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2528 C The potential depends both on the distance of peptide-group centers and on
2529 C the orientation of the CA-CA virtual bonds.
2530 C
2531       implicit real*8 (a-h,o-z)
2532       include 'DIMENSIONS'
2533       include 'COMMON.CONTROL'
2534       include 'COMMON.SETUP'
2535       include 'COMMON.IOUNITS'
2536       include 'COMMON.GEO'
2537       include 'COMMON.VAR'
2538       include 'COMMON.LOCAL'
2539       include 'COMMON.CHAIN'
2540       include 'COMMON.DERIV'
2541       include 'COMMON.INTERACT'
2542       include 'COMMON.CONTACTS'
2543       include 'COMMON.TORSION'
2544       include 'COMMON.VECTORS'
2545       include 'COMMON.FFIELD'
2546       include 'COMMON.TIME1'
2547       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2548      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2549       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2550      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2551       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2552      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2553      &    num_conti,j1,j2
2554 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2555 #ifdef MOMENT
2556       double precision scal_el /1.0d0/
2557 #else
2558       double precision scal_el /0.5d0/
2559 #endif
2560 C 12/13/98
2561 C 13-go grudnia roku pamietnego...
2562       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2563      &                   0.0d0,1.0d0,0.0d0,
2564      &                   0.0d0,0.0d0,1.0d0/
2565 cd      write(iout,*) 'In EELEC'
2566 cd      do i=1,nloctyp
2567 cd        write(iout,*) 'Type',i
2568 cd        write(iout,*) 'B1',B1(:,i)
2569 cd        write(iout,*) 'B2',B2(:,i)
2570 cd        write(iout,*) 'CC',CC(:,:,i)
2571 cd        write(iout,*) 'DD',DD(:,:,i)
2572 cd        write(iout,*) 'EE',EE(:,:,i)
2573 cd      enddo
2574 cd      call check_vecgrad
2575 cd      stop
2576       if (icheckgrad.eq.1) then
2577         do i=1,nres-1
2578           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2579           do k=1,3
2580             dc_norm(k,i)=dc(k,i)*fac
2581           enddo
2582 c          write (iout,*) 'i',i,' fac',fac
2583         enddo
2584       endif
2585       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2586      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2587      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2588 c        call vec_and_deriv
2589         call set_matrices
2590       endif
2591 cd      do i=1,nres-1
2592 cd        write (iout,*) 'i=',i
2593 cd        do k=1,3
2594 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2595 cd        enddo
2596 cd        do k=1,3
2597 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2598 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2599 cd        enddo
2600 cd      enddo
2601       t_eelecij=0.0d0
2602       ees=0.0D0
2603       evdw1=0.0D0
2604       eel_loc=0.0d0
2605       eello_turn3=0.0d0
2606       eello_turn4=0.0d0
2607       ind=0
2608       do i=1,nres
2609         num_cont_hb(i)=0
2610       enddo
2611 cd      print '(a)','Enter EELEC'
2612 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2613       do i=1,nres
2614         gel_loc_loc(i)=0.0d0
2615         gcorr_loc(i)=0.0d0
2616       enddo
2617 c
2618 c
2619 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2620 C
2621 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2622 C
2623       do i=iturn3_start,iturn3_end
2624         dxi=dc(1,i)
2625         dyi=dc(2,i)
2626         dzi=dc(3,i)
2627         dx_normi=dc_norm(1,i)
2628         dy_normi=dc_norm(2,i)
2629         dz_normi=dc_norm(3,i)
2630         xmedi=c(1,i)+0.5d0*dxi
2631         ymedi=c(2,i)+0.5d0*dyi
2632         zmedi=c(3,i)+0.5d0*dzi
2633         num_conti=0
2634         call eelecij(i,i+2,ees,evdw1,eel_loc)
2635         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2636         num_cont_hb(i)=num_conti
2637       enddo
2638       do i=iturn4_start,iturn4_end
2639         dxi=dc(1,i)
2640         dyi=dc(2,i)
2641         dzi=dc(3,i)
2642         dx_normi=dc_norm(1,i)
2643         dy_normi=dc_norm(2,i)
2644         dz_normi=dc_norm(3,i)
2645         xmedi=c(1,i)+0.5d0*dxi
2646         ymedi=c(2,i)+0.5d0*dyi
2647         zmedi=c(3,i)+0.5d0*dzi
2648         num_conti=0
2649         call eelecij(i,i+3,ees,evdw1,eel_loc)
2650         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
2651         num_cont_hb(i)=num_cont_hb(i)+num_conti
2652       enddo   ! i
2653 c
2654 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2655 c
2656       do i=iatel_s,iatel_e
2657         dxi=dc(1,i)
2658         dyi=dc(2,i)
2659         dzi=dc(3,i)
2660         dx_normi=dc_norm(1,i)
2661         dy_normi=dc_norm(2,i)
2662         dz_normi=dc_norm(3,i)
2663         xmedi=c(1,i)+0.5d0*dxi
2664         ymedi=c(2,i)+0.5d0*dyi
2665         zmedi=c(3,i)+0.5d0*dzi
2666         num_conti=0
2667 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2668         do j=ielstart(i),ielend(i)
2669           call eelecij(i,j,ees,evdw1,eel_loc)
2670         enddo ! j
2671         num_cont_hb(i)=num_cont_hb(i)+num_conti
2672       enddo   ! i
2673 c      write (iout,*) "Number of loop steps in EELEC:",ind
2674 cd      do i=1,nres
2675 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2676 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2677 cd      enddo
2678 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2679 ccc      eel_loc=eel_loc+eello_turn3
2680 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2681       return
2682       end
2683 C-------------------------------------------------------------------------------
2684       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2685       implicit real*8 (a-h,o-z)
2686       include 'DIMENSIONS'
2687 #ifdef MPI
2688       include "mpif.h"
2689 #endif
2690       include 'COMMON.CONTROL'
2691       include 'COMMON.IOUNITS'
2692       include 'COMMON.GEO'
2693       include 'COMMON.VAR'
2694       include 'COMMON.LOCAL'
2695       include 'COMMON.CHAIN'
2696       include 'COMMON.DERIV'
2697       include 'COMMON.INTERACT'
2698       include 'COMMON.CONTACTS'
2699       include 'COMMON.TORSION'
2700       include 'COMMON.VECTORS'
2701       include 'COMMON.FFIELD'
2702       include 'COMMON.TIME1'
2703       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2704      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2705       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2706      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2707       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2708      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2709      &    num_conti,j1,j2
2710 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2711 #ifdef MOMENT
2712       double precision scal_el /1.0d0/
2713 #else
2714       double precision scal_el /0.5d0/
2715 #endif
2716 C 12/13/98
2717 C 13-go grudnia roku pamietnego...
2718       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2719      &                   0.0d0,1.0d0,0.0d0,
2720      &                   0.0d0,0.0d0,1.0d0/
2721 c          time00=MPI_Wtime()
2722 cd      write (iout,*) "eelecij",i,j
2723           ind=ind+1
2724           iteli=itel(i)
2725           itelj=itel(j)
2726           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2727           aaa=app(iteli,itelj)
2728           bbb=bpp(iteli,itelj)
2729           ael6i=ael6(iteli,itelj)
2730           ael3i=ael3(iteli,itelj)
2731           dxj=dc(1,j)
2732           dyj=dc(2,j)
2733           dzj=dc(3,j)
2734           dx_normj=dc_norm(1,j)
2735           dy_normj=dc_norm(2,j)
2736           dz_normj=dc_norm(3,j)
2737           xj=c(1,j)+0.5D0*dxj-xmedi
2738           yj=c(2,j)+0.5D0*dyj-ymedi
2739           zj=c(3,j)+0.5D0*dzj-zmedi
2740           rij=xj*xj+yj*yj+zj*zj
2741           rrmij=1.0D0/rij
2742           rij=dsqrt(rij)
2743           rmij=1.0D0/rij
2744           r3ij=rrmij*rmij
2745           r6ij=r3ij*r3ij
2746           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2747           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2748           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2749           fac=cosa-3.0D0*cosb*cosg
2750           ev1=aaa*r6ij*r6ij
2751 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2752           if (j.eq.i+2) ev1=scal_el*ev1
2753           ev2=bbb*r6ij
2754           fac3=ael6i*r6ij
2755           fac4=ael3i*r3ij
2756           evdwij=ev1+ev2
2757           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2758           el2=fac4*fac
2759           eesij=el1+el2
2760 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2761           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2762           ees=ees+eesij
2763           evdw1=evdw1+evdwij
2764 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2765 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2766 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2767 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2768
2769           if (energy_dec) then
2770               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2771               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2772           endif
2773
2774 C
2775 C Calculate contributions to the Cartesian gradient.
2776 C
2777 #ifdef SPLITELE
2778           facvdw=-6*rrmij*(ev1+evdwij)
2779           facel=-3*rrmij*(el1+eesij)
2780           fac1=fac
2781           erij(1)=xj*rmij
2782           erij(2)=yj*rmij
2783           erij(3)=zj*rmij
2784 *
2785 * Radial derivatives. First process both termini of the fragment (i,j)
2786 *
2787           ggg(1)=facel*xj
2788           ggg(2)=facel*yj
2789           ggg(3)=facel*zj
2790 c          do k=1,3
2791 c            ghalf=0.5D0*ggg(k)
2792 c            gelc(k,i)=gelc(k,i)+ghalf
2793 c            gelc(k,j)=gelc(k,j)+ghalf
2794 c          enddo
2795 c 9/28/08 AL Gradient compotents will be summed only at the end
2796           do k=1,3
2797             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2798             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2799           enddo
2800 *
2801 * Loop over residues i+1 thru j-1.
2802 *
2803 cgrad          do k=i+1,j-1
2804 cgrad            do l=1,3
2805 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2806 cgrad            enddo
2807 cgrad          enddo
2808           ggg(1)=facvdw*xj
2809           ggg(2)=facvdw*yj
2810           ggg(3)=facvdw*zj
2811 c          do k=1,3
2812 c            ghalf=0.5D0*ggg(k)
2813 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2814 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2815 c          enddo
2816 c 9/28/08 AL Gradient compotents will be summed only at the end
2817           do k=1,3
2818             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2819             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2820           enddo
2821 *
2822 * Loop over residues i+1 thru j-1.
2823 *
2824 cgrad          do k=i+1,j-1
2825 cgrad            do l=1,3
2826 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2827 cgrad            enddo
2828 cgrad          enddo
2829 #else
2830           facvdw=ev1+evdwij
2831           facel=el1+eesij
2832           fac1=fac
2833           fac=-3*rrmij*(facvdw+facvdw+facel)
2834           erij(1)=xj*rmij
2835           erij(2)=yj*rmij
2836           erij(3)=zj*rmij
2837 *
2838 * Radial derivatives. First process both termini of the fragment (i,j)
2839 *
2840           ggg(1)=fac*xj
2841           ggg(2)=fac*yj
2842           ggg(3)=fac*zj
2843 c          do k=1,3
2844 c            ghalf=0.5D0*ggg(k)
2845 c            gelc(k,i)=gelc(k,i)+ghalf
2846 c            gelc(k,j)=gelc(k,j)+ghalf
2847 c          enddo
2848 c 9/28/08 AL Gradient compotents will be summed only at the end
2849           do k=1,3
2850             gelc_long(k,j)=gelc(k,j)+ggg(k)
2851             gelc_long(k,i)=gelc(k,i)-ggg(k)
2852           enddo
2853 *
2854 * Loop over residues i+1 thru j-1.
2855 *
2856 cgrad          do k=i+1,j-1
2857 cgrad            do l=1,3
2858 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2859 cgrad            enddo
2860 cgrad          enddo
2861 c 9/28/08 AL Gradient compotents will be summed only at the end
2862           ggg(1)=facvdw*xj
2863           ggg(2)=facvdw*yj
2864           ggg(3)=facvdw*zj
2865           do k=1,3
2866             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2867             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2868           enddo
2869 #endif
2870 *
2871 * Angular part
2872 *
2873           ecosa=2.0D0*fac3*fac1+fac4
2874           fac4=-3.0D0*fac4
2875           fac3=-6.0D0*fac3
2876           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2877           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2878           do k=1,3
2879             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2880             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2881           enddo
2882 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2883 cd   &          (dcosg(k),k=1,3)
2884           do k=1,3
2885             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2886           enddo
2887 c          do k=1,3
2888 c            ghalf=0.5D0*ggg(k)
2889 c            gelc(k,i)=gelc(k,i)+ghalf
2890 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2891 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2892 c            gelc(k,j)=gelc(k,j)+ghalf
2893 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2894 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2895 c          enddo
2896 cgrad          do k=i+1,j-1
2897 cgrad            do l=1,3
2898 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2899 cgrad            enddo
2900 cgrad          enddo
2901           do k=1,3
2902             gelc(k,i)=gelc(k,i)
2903      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2904      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2905             gelc(k,j)=gelc(k,j)
2906      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2907      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2908             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2909             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2910           enddo
2911           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2912      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2913      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2914 C
2915 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2916 C   energy of a peptide unit is assumed in the form of a second-order
2917 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2918 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2919 C   are computed for EVERY pair of non-contiguous peptide groups.
2920 C
2921           if (j.lt.nres-1) then
2922             j1=j+1
2923             j2=j-1
2924           else
2925             j1=j-1
2926             j2=j-2
2927           endif
2928           kkk=0
2929           do k=1,2
2930             do l=1,2
2931               kkk=kkk+1
2932               muij(kkk)=mu(k,i)*mu(l,j)
2933             enddo
2934           enddo
2935 cd         write (iout,*) 'EELEC: i',i,' j',j
2936 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2937 cd          write(iout,*) 'muij',muij
2938           ury=scalar(uy(1,i),erij)
2939           urz=scalar(uz(1,i),erij)
2940           vry=scalar(uy(1,j),erij)
2941           vrz=scalar(uz(1,j),erij)
2942           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2943           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2944           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2945           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2946           fac=dsqrt(-ael6i)*r3ij
2947           a22=a22*fac
2948           a23=a23*fac
2949           a32=a32*fac
2950           a33=a33*fac
2951 cd          write (iout,'(4i5,4f10.5)')
2952 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2953 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2954 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2955 cd     &      uy(:,j),uz(:,j)
2956 cd          write (iout,'(4f10.5)')
2957 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2958 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2959 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2960 cd           write (iout,'(9f10.5/)')
2961 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2962 C Derivatives of the elements of A in virtual-bond vectors
2963           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2964           do k=1,3
2965             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2966             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2967             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2968             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2969             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2970             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2971             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2972             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2973             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2974             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2975             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2976             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2977           enddo
2978 C Compute radial contributions to the gradient
2979           facr=-3.0d0*rrmij
2980           a22der=a22*facr
2981           a23der=a23*facr
2982           a32der=a32*facr
2983           a33der=a33*facr
2984           agg(1,1)=a22der*xj
2985           agg(2,1)=a22der*yj
2986           agg(3,1)=a22der*zj
2987           agg(1,2)=a23der*xj
2988           agg(2,2)=a23der*yj
2989           agg(3,2)=a23der*zj
2990           agg(1,3)=a32der*xj
2991           agg(2,3)=a32der*yj
2992           agg(3,3)=a32der*zj
2993           agg(1,4)=a33der*xj
2994           agg(2,4)=a33der*yj
2995           agg(3,4)=a33der*zj
2996 C Add the contributions coming from er
2997           fac3=-3.0d0*fac
2998           do k=1,3
2999             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3000             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3001             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3002             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3003           enddo
3004           do k=1,3
3005 C Derivatives in DC(i)
3006             ghalf1=0.5d0*agg(k,1)
3007             ghalf2=0.5d0*agg(k,2)
3008             ghalf3=0.5d0*agg(k,3)
3009             ghalf4=0.5d0*agg(k,4)
3010             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3011      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3012             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3013      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3014             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3015      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3016             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3017      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3018 C Derivatives in DC(i+1)
3019             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3020      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3021             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3022      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3023             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3024      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3025             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3026      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3027 C Derivatives in DC(j)
3028             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3029      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3030             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3031      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3032             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3033      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3034             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3035      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3036 C Derivatives in DC(j+1) or DC(nres-1)
3037             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3038      &      -3.0d0*vryg(k,3)*ury)
3039             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3040      &      -3.0d0*vrzg(k,3)*ury)
3041             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3042      &      -3.0d0*vryg(k,3)*urz)
3043             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3044      &      -3.0d0*vrzg(k,3)*urz)
3045 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3046 cgrad              do l=1,4
3047 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3048 cgrad              enddo
3049 cgrad            endif
3050           enddo
3051           acipa(1,1)=a22
3052           acipa(1,2)=a23
3053           acipa(2,1)=a32
3054           acipa(2,2)=a33
3055           a22=-a22
3056           a23=-a23
3057           do l=1,2
3058             do k=1,3
3059               agg(k,l)=-agg(k,l)
3060               aggi(k,l)=-aggi(k,l)
3061               aggi1(k,l)=-aggi1(k,l)
3062               aggj(k,l)=-aggj(k,l)
3063               aggj1(k,l)=-aggj1(k,l)
3064             enddo
3065           enddo
3066           if (j.lt.nres-1) then
3067             a22=-a22
3068             a32=-a32
3069             do l=1,3,2
3070               do k=1,3
3071                 agg(k,l)=-agg(k,l)
3072                 aggi(k,l)=-aggi(k,l)
3073                 aggi1(k,l)=-aggi1(k,l)
3074                 aggj(k,l)=-aggj(k,l)
3075                 aggj1(k,l)=-aggj1(k,l)
3076               enddo
3077             enddo
3078           else
3079             a22=-a22
3080             a23=-a23
3081             a32=-a32
3082             a33=-a33
3083             do l=1,4
3084               do k=1,3
3085                 agg(k,l)=-agg(k,l)
3086                 aggi(k,l)=-aggi(k,l)
3087                 aggi1(k,l)=-aggi1(k,l)
3088                 aggj(k,l)=-aggj(k,l)
3089                 aggj1(k,l)=-aggj1(k,l)
3090               enddo
3091             enddo
3092           endif
3093           ENDIF ! WCORR
3094           IF (wel_loc.gt.0.0d0) THEN
3095 C Contribution to the local-electrostatic energy coming from the i-j pair
3096           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3097      &     +a33*muij(4)
3098 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3099
3100           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3101      &            'eelloc',i,j,eel_loc_ij
3102
3103           eel_loc=eel_loc+eel_loc_ij
3104 C Partial derivatives in virtual-bond dihedral angles gamma
3105           if (i.gt.1)
3106      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3107      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3108      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3109           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3110      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3111      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3112 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3113           do l=1,3
3114             ggg(l)=agg(l,1)*muij(1)+
3115      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3116             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3117             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3118 cgrad            ghalf=0.5d0*ggg(l)
3119 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3120 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3121           enddo
3122 cgrad          do k=i+1,j2
3123 cgrad            do l=1,3
3124 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3125 cgrad            enddo
3126 cgrad          enddo
3127 C Remaining derivatives of eello
3128           do l=1,3
3129             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3130      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3131             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3132      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3133             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3134      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3135             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3136      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3137           enddo
3138           ENDIF
3139           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3140             do k=1,4
3141               do l=1,3
3142                 ghalf=0.5d0*agg(l,k)
3143                 aggi(l,k)=aggi(l,k)+ghalf
3144                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3145                 aggj(l,k)=aggj(l,k)+ghalf
3146               enddo
3147             enddo
3148             if (j.eq.nres-1 .and. i.lt.j-2) then
3149               do k=1,4
3150                 do l=1,3
3151                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3152                 enddo
3153               enddo
3154             endif
3155           endif
3156 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3157 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3158           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3159      &       .and. num_conti.le.maxconts) then
3160 c            write (iout,*) i,j," entered corr"
3161 C
3162 C Calculate the contact function. The ith column of the array JCONT will
3163 C contain the numbers of atoms that make contacts with the atom I (of numbers
3164 C greater than I). The arrays FACONT and GACONT will contain the values of
3165 C the contact function and its derivative.
3166 c           r0ij=1.02D0*rpp(iteli,itelj)
3167 c           r0ij=1.11D0*rpp(iteli,itelj)
3168             r0ij=2.20D0*rpp(iteli,itelj)
3169 c           r0ij=1.55D0*rpp(iteli,itelj)
3170             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3171             if (fcont.gt.0.0D0) then
3172               num_conti=num_conti+1
3173               if (num_conti.gt.maxconts) then
3174                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3175      &                         ' will skip next contacts for this conf.'
3176               else
3177                 jcont_hb(num_conti,i)=j
3178                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3179      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3180 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3181 C  terms.
3182                 d_cont(num_conti,i)=rij
3183 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3184 C     --- Electrostatic-interaction matrix ---
3185                 a_chuj(1,1,num_conti,i)=a22
3186                 a_chuj(1,2,num_conti,i)=a23
3187                 a_chuj(2,1,num_conti,i)=a32
3188                 a_chuj(2,2,num_conti,i)=a33
3189 C     --- Gradient of rij
3190                 do kkk=1,3
3191                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3192                 enddo
3193                 kkll=0
3194                 do k=1,2
3195                   do l=1,2
3196                     kkll=kkll+1
3197                     do m=1,3
3198                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3199                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3200                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3201                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3202                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3203                     enddo
3204                   enddo
3205                 enddo
3206                 ENDIF
3207                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3208 C Calculate contact energies
3209                 cosa4=4.0D0*cosa
3210                 wij=cosa-3.0D0*cosb*cosg
3211                 cosbg1=cosb+cosg
3212                 cosbg2=cosb-cosg
3213 c               fac3=dsqrt(-ael6i)/r0ij**3
3214                 fac3=dsqrt(-ael6i)*r3ij
3215 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3216                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3217                 if (ees0tmp.gt.0) then
3218                   ees0pij=dsqrt(ees0tmp)
3219                 else
3220                   ees0pij=0
3221                 endif
3222 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3223                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3224                 if (ees0tmp.gt.0) then
3225                   ees0mij=dsqrt(ees0tmp)
3226                 else
3227                   ees0mij=0
3228                 endif
3229 c               ees0mij=0.0D0
3230                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3231                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3232 C Diagnostics. Comment out or remove after debugging!
3233 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3234 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3235 c               ees0m(num_conti,i)=0.0D0
3236 C End diagnostics.
3237 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3238 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3239 C Angular derivatives of the contact function
3240                 ees0pij1=fac3/ees0pij
3241                 ees0mij1=fac3/ees0mij
3242                 fac3p=-3.0D0*fac3*rrmij
3243                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3244                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3245 c               ees0mij1=0.0D0
3246                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3247                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3248                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3249                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3250                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3251                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3252                 ecosap=ecosa1+ecosa2
3253                 ecosbp=ecosb1+ecosb2
3254                 ecosgp=ecosg1+ecosg2
3255                 ecosam=ecosa1-ecosa2
3256                 ecosbm=ecosb1-ecosb2
3257                 ecosgm=ecosg1-ecosg2
3258 C Diagnostics
3259 c               ecosap=ecosa1
3260 c               ecosbp=ecosb1
3261 c               ecosgp=ecosg1
3262 c               ecosam=0.0D0
3263 c               ecosbm=0.0D0
3264 c               ecosgm=0.0D0
3265 C End diagnostics
3266                 facont_hb(num_conti,i)=fcont
3267                 fprimcont=fprimcont/rij
3268 cd              facont_hb(num_conti,i)=1.0D0
3269 C Following line is for diagnostics.
3270 cd              fprimcont=0.0D0
3271                 do k=1,3
3272                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3273                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3274                 enddo
3275                 do k=1,3
3276                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3277                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3278                 enddo
3279                 gggp(1)=gggp(1)+ees0pijp*xj
3280                 gggp(2)=gggp(2)+ees0pijp*yj
3281                 gggp(3)=gggp(3)+ees0pijp*zj
3282                 gggm(1)=gggm(1)+ees0mijp*xj
3283                 gggm(2)=gggm(2)+ees0mijp*yj
3284                 gggm(3)=gggm(3)+ees0mijp*zj
3285 C Derivatives due to the contact function
3286                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3287                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3288                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3289                 do k=1,3
3290                   ghalfp=0.5D0*gggp(k)
3291                   ghalfm=0.5D0*gggm(k)
3292                   gacontp_hb1(k,num_conti,i)=ghalfp
3293      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3294      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3295                   gacontp_hb2(k,num_conti,i)=ghalfp
3296      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3297      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3298                   gacontp_hb3(k,num_conti,i)=gggp(k)
3299                   gacontm_hb1(k,num_conti,i)=ghalfm
3300      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3301      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3302                   gacontm_hb2(k,num_conti,i)=ghalfm
3303      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3304      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3305                   gacontm_hb3(k,num_conti,i)=gggm(k)
3306                 enddo
3307 C Diagnostics. Comment out or remove after debugging!
3308 cdiag           do k=1,3
3309 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3310 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3311 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3312 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3313 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3314 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3315 cdiag           enddo
3316               ENDIF ! wcorr
3317               endif  ! num_conti.le.maxconts
3318             endif  ! fcont.gt.0
3319           endif    ! j.gt.i+1
3320 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3321       return
3322       end
3323 C-----------------------------------------------------------------------------
3324       subroutine eturn3(i,eello_turn3)
3325 C Third- and fourth-order contributions from turns
3326       implicit real*8 (a-h,o-z)
3327       include 'DIMENSIONS'
3328       include 'COMMON.IOUNITS'
3329       include 'COMMON.GEO'
3330       include 'COMMON.VAR'
3331       include 'COMMON.LOCAL'
3332       include 'COMMON.CHAIN'
3333       include 'COMMON.DERIV'
3334       include 'COMMON.INTERACT'
3335       include 'COMMON.CONTACTS'
3336       include 'COMMON.TORSION'
3337       include 'COMMON.VECTORS'
3338       include 'COMMON.FFIELD'
3339       include 'COMMON.CONTROL'
3340       dimension ggg(3)
3341       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3342      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3343      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3344       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3345      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3346       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3347      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3348      &    num_conti,j1,j2
3349       j=i+2
3350 c      write (iout,*) "eturn3",i,j,j1,j2
3351       a_temp(1,1)=a22
3352       a_temp(1,2)=a23
3353       a_temp(2,1)=a32
3354       a_temp(2,2)=a33
3355 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3356 C
3357 C               Third-order contributions
3358 C
3359 C                 (i+2)o----(i+3)
3360 C                      | |
3361 C                      | |
3362 C                 (i+1)o----i
3363 C
3364 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3365 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3366         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3367         call transpose2(auxmat(1,1),auxmat1(1,1))
3368         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3369         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3370         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3371      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3372 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3373 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3374 cd     &    ' eello_turn3_num',4*eello_turn3_num
3375 C Derivatives in gamma(i)
3376         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3377         call transpose2(auxmat2(1,1),auxmat3(1,1))
3378         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3379         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3380 C Derivatives in gamma(i+1)
3381         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3382         call transpose2(auxmat2(1,1),auxmat3(1,1))
3383         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3384         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3385      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3386 C Cartesian derivatives
3387         do l=1,3
3388 c            ghalf1=0.5d0*agg(l,1)
3389 c            ghalf2=0.5d0*agg(l,2)
3390 c            ghalf3=0.5d0*agg(l,3)
3391 c            ghalf4=0.5d0*agg(l,4)
3392           a_temp(1,1)=aggi(l,1)!+ghalf1
3393           a_temp(1,2)=aggi(l,2)!+ghalf2
3394           a_temp(2,1)=aggi(l,3)!+ghalf3
3395           a_temp(2,2)=aggi(l,4)!+ghalf4
3396           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3397           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3398      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3399           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3400           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3401           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3402           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3403           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3404           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3405      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3406           a_temp(1,1)=aggj(l,1)!+ghalf1
3407           a_temp(1,2)=aggj(l,2)!+ghalf2
3408           a_temp(2,1)=aggj(l,3)!+ghalf3
3409           a_temp(2,2)=aggj(l,4)!+ghalf4
3410           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3411           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3412      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3413           a_temp(1,1)=aggj1(l,1)
3414           a_temp(1,2)=aggj1(l,2)
3415           a_temp(2,1)=aggj1(l,3)
3416           a_temp(2,2)=aggj1(l,4)
3417           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3418           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3419      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3420         enddo
3421       return
3422       end
3423 C-------------------------------------------------------------------------------
3424       subroutine eturn4(i,eello_turn4)
3425 C Third- and fourth-order contributions from turns
3426       implicit real*8 (a-h,o-z)
3427       include 'DIMENSIONS'
3428       include 'COMMON.IOUNITS'
3429       include 'COMMON.GEO'
3430       include 'COMMON.VAR'
3431       include 'COMMON.LOCAL'
3432       include 'COMMON.CHAIN'
3433       include 'COMMON.DERIV'
3434       include 'COMMON.INTERACT'
3435       include 'COMMON.CONTACTS'
3436       include 'COMMON.TORSION'
3437       include 'COMMON.VECTORS'
3438       include 'COMMON.FFIELD'
3439       include 'COMMON.CONTROL'
3440       dimension ggg(3)
3441       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3442      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3443      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3444       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3445      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3446       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3447      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3448      &    num_conti,j1,j2
3449       j=i+3
3450 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3451 C
3452 C               Fourth-order contributions
3453 C
3454 C                 (i+3)o----(i+4)
3455 C                     /  |
3456 C               (i+2)o   |
3457 C                     \  |
3458 C                 (i+1)o----i
3459 C
3460 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3461 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3462 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3463         a_temp(1,1)=a22
3464         a_temp(1,2)=a23
3465         a_temp(2,1)=a32
3466         a_temp(2,2)=a33
3467         iti1=itortyp(itype(i+1))
3468         iti2=itortyp(itype(i+2))
3469         iti3=itortyp(itype(i+3))
3470 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3471         call transpose2(EUg(1,1,i+1),e1t(1,1))
3472         call transpose2(Eug(1,1,i+2),e2t(1,1))
3473         call transpose2(Eug(1,1,i+3),e3t(1,1))
3474         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3475         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3476         s1=scalar2(b1(1,iti2),auxvec(1))
3477         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3478         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3479         s2=scalar2(b1(1,iti1),auxvec(1))
3480         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3481         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3482         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3483         eello_turn4=eello_turn4-(s1+s2+s3)
3484         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3485      &      'eturn4',i,j,-(s1+s2+s3)
3486 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3487 cd     &    ' eello_turn4_num',8*eello_turn4_num
3488 C Derivatives in gamma(i)
3489         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3490         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3491         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3492         s1=scalar2(b1(1,iti2),auxvec(1))
3493         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3494         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3495         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3496 C Derivatives in gamma(i+1)
3497         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3498         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3499         s2=scalar2(b1(1,iti1),auxvec(1))
3500         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3501         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3502         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3503         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3504 C Derivatives in gamma(i+2)
3505         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3506         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3507         s1=scalar2(b1(1,iti2),auxvec(1))
3508         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3509         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3510         s2=scalar2(b1(1,iti1),auxvec(1))
3511         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3512         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3513         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3514         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3515 C Cartesian derivatives
3516 C Derivatives of this turn contributions in DC(i+2)
3517         if (j.lt.nres-1) then
3518           do l=1,3
3519             a_temp(1,1)=agg(l,1)
3520             a_temp(1,2)=agg(l,2)
3521             a_temp(2,1)=agg(l,3)
3522             a_temp(2,2)=agg(l,4)
3523             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3524             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3525             s1=scalar2(b1(1,iti2),auxvec(1))
3526             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3527             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3528             s2=scalar2(b1(1,iti1),auxvec(1))
3529             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3530             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3531             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3532             ggg(l)=-(s1+s2+s3)
3533             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3534           enddo
3535         endif
3536 C Remaining derivatives of this turn contribution
3537         do l=1,3
3538           a_temp(1,1)=aggi(l,1)
3539           a_temp(1,2)=aggi(l,2)
3540           a_temp(2,1)=aggi(l,3)
3541           a_temp(2,2)=aggi(l,4)
3542           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3543           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3544           s1=scalar2(b1(1,iti2),auxvec(1))
3545           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3546           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3547           s2=scalar2(b1(1,iti1),auxvec(1))
3548           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3549           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3550           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3551           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3552           a_temp(1,1)=aggi1(l,1)
3553           a_temp(1,2)=aggi1(l,2)
3554           a_temp(2,1)=aggi1(l,3)
3555           a_temp(2,2)=aggi1(l,4)
3556           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3557           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3558           s1=scalar2(b1(1,iti2),auxvec(1))
3559           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3560           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3561           s2=scalar2(b1(1,iti1),auxvec(1))
3562           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3563           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3564           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3565           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3566           a_temp(1,1)=aggj(l,1)
3567           a_temp(1,2)=aggj(l,2)
3568           a_temp(2,1)=aggj(l,3)
3569           a_temp(2,2)=aggj(l,4)
3570           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3571           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3572           s1=scalar2(b1(1,iti2),auxvec(1))
3573           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3574           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3575           s2=scalar2(b1(1,iti1),auxvec(1))
3576           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3577           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3578           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3579           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3580           a_temp(1,1)=aggj1(l,1)
3581           a_temp(1,2)=aggj1(l,2)
3582           a_temp(2,1)=aggj1(l,3)
3583           a_temp(2,2)=aggj1(l,4)
3584           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3585           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3586           s1=scalar2(b1(1,iti2),auxvec(1))
3587           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3588           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3589           s2=scalar2(b1(1,iti1),auxvec(1))
3590           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3591           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3592           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3593 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3594           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3595         enddo
3596       return
3597       end
3598 C-----------------------------------------------------------------------------
3599       subroutine vecpr(u,v,w)
3600       implicit real*8(a-h,o-z)
3601       dimension u(3),v(3),w(3)
3602       w(1)=u(2)*v(3)-u(3)*v(2)
3603       w(2)=-u(1)*v(3)+u(3)*v(1)
3604       w(3)=u(1)*v(2)-u(2)*v(1)
3605       return
3606       end
3607 C-----------------------------------------------------------------------------
3608       subroutine unormderiv(u,ugrad,unorm,ungrad)
3609 C This subroutine computes the derivatives of a normalized vector u, given
3610 C the derivatives computed without normalization conditions, ugrad. Returns
3611 C ungrad.
3612       implicit none
3613       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3614       double precision vec(3)
3615       double precision scalar
3616       integer i,j
3617 c      write (2,*) 'ugrad',ugrad
3618 c      write (2,*) 'u',u
3619       do i=1,3
3620         vec(i)=scalar(ugrad(1,i),u(1))
3621       enddo
3622 c      write (2,*) 'vec',vec
3623       do i=1,3
3624         do j=1,3
3625           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3626         enddo
3627       enddo
3628 c      write (2,*) 'ungrad',ungrad
3629       return
3630       end
3631 C-----------------------------------------------------------------------------
3632       subroutine escp_soft_sphere(evdw2,evdw2_14)
3633 C
3634 C This subroutine calculates the excluded-volume interaction energy between
3635 C peptide-group centers and side chains and its gradient in virtual-bond and
3636 C side-chain vectors.
3637 C
3638       implicit real*8 (a-h,o-z)
3639       include 'DIMENSIONS'
3640       include 'COMMON.GEO'
3641       include 'COMMON.VAR'
3642       include 'COMMON.LOCAL'
3643       include 'COMMON.CHAIN'
3644       include 'COMMON.DERIV'
3645       include 'COMMON.INTERACT'
3646       include 'COMMON.FFIELD'
3647       include 'COMMON.IOUNITS'
3648       include 'COMMON.CONTROL'
3649       dimension ggg(3)
3650       evdw2=0.0D0
3651       evdw2_14=0.0d0
3652       r0_scp=4.5d0
3653 cd    print '(a)','Enter ESCP'
3654 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3655       do i=iatscp_s,iatscp_e
3656         iteli=itel(i)
3657         xi=0.5D0*(c(1,i)+c(1,i+1))
3658         yi=0.5D0*(c(2,i)+c(2,i+1))
3659         zi=0.5D0*(c(3,i)+c(3,i+1))
3660
3661         do iint=1,nscp_gr(i)
3662
3663         do j=iscpstart(i,iint),iscpend(i,iint)
3664           itypj=itype(j)
3665 C Uncomment following three lines for SC-p interactions
3666 c         xj=c(1,nres+j)-xi
3667 c         yj=c(2,nres+j)-yi
3668 c         zj=c(3,nres+j)-zi
3669 C Uncomment following three lines for Ca-p interactions
3670           xj=c(1,j)-xi
3671           yj=c(2,j)-yi
3672           zj=c(3,j)-zi
3673           rij=xj*xj+yj*yj+zj*zj
3674           r0ij=r0_scp
3675           r0ijsq=r0ij*r0ij
3676           if (rij.lt.r0ijsq) then
3677             evdwij=0.25d0*(rij-r0ijsq)**2
3678             fac=rij-r0ijsq
3679           else
3680             evdwij=0.0d0
3681             fac=0.0d0
3682           endif
3683           evdw2=evdw2+evdwij
3684 C
3685 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3686 C
3687           ggg(1)=xj*fac
3688           ggg(2)=yj*fac
3689           ggg(3)=zj*fac
3690           if (j.lt.i) then
3691 cd          write (iout,*) 'j<i'
3692 C Uncomment following three lines for SC-p interactions
3693 c           do k=1,3
3694 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3695 c           enddo
3696           else
3697 cd          write (iout,*) 'j>i'
3698             do k=1,3
3699               ggg(k)=-ggg(k)
3700 C Uncomment following line for SC-p interactions
3701 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3702             enddo
3703           endif
3704           do k=1,3
3705             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3706           enddo
3707           kstart=min0(i+1,j)
3708           kend=max0(i-1,j-1)
3709 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3710 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3711           do k=kstart,kend
3712             do l=1,3
3713               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3714             enddo
3715           enddo
3716         enddo
3717
3718         enddo ! iint
3719       enddo ! i
3720       return
3721       end
3722 C-----------------------------------------------------------------------------
3723       subroutine escp(evdw2,evdw2_14)
3724 C
3725 C This subroutine calculates the excluded-volume interaction energy between
3726 C peptide-group centers and side chains and its gradient in virtual-bond and
3727 C side-chain vectors.
3728 C
3729       implicit real*8 (a-h,o-z)
3730       include 'DIMENSIONS'
3731       include 'COMMON.GEO'
3732       include 'COMMON.VAR'
3733       include 'COMMON.LOCAL'
3734       include 'COMMON.CHAIN'
3735       include 'COMMON.DERIV'
3736       include 'COMMON.INTERACT'
3737       include 'COMMON.FFIELD'
3738       include 'COMMON.IOUNITS'
3739       include 'COMMON.CONTROL'
3740       dimension ggg(3)
3741       evdw2=0.0D0
3742       evdw2_14=0.0d0
3743 cd    print '(a)','Enter ESCP'
3744 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3745       do i=iatscp_s,iatscp_e
3746         iteli=itel(i)
3747         xi=0.5D0*(c(1,i)+c(1,i+1))
3748         yi=0.5D0*(c(2,i)+c(2,i+1))
3749         zi=0.5D0*(c(3,i)+c(3,i+1))
3750
3751         do iint=1,nscp_gr(i)
3752
3753         do j=iscpstart(i,iint),iscpend(i,iint)
3754           itypj=itype(j)
3755 C Uncomment following three lines for SC-p interactions
3756 c         xj=c(1,nres+j)-xi
3757 c         yj=c(2,nres+j)-yi
3758 c         zj=c(3,nres+j)-zi
3759 C Uncomment following three lines for Ca-p interactions
3760           xj=c(1,j)-xi
3761           yj=c(2,j)-yi
3762           zj=c(3,j)-zi
3763           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3764           fac=rrij**expon2
3765           e1=fac*fac*aad(itypj,iteli)
3766           e2=fac*bad(itypj,iteli)
3767           if (iabs(j-i) .le. 2) then
3768             e1=scal14*e1
3769             e2=scal14*e2
3770             evdw2_14=evdw2_14+e1+e2
3771           endif
3772           evdwij=e1+e2
3773           evdw2=evdw2+evdwij
3774           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3775      &        'evdw2',i,j,evdwij
3776 C
3777 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3778 C
3779           fac=-(evdwij+e1)*rrij
3780           ggg(1)=xj*fac
3781           ggg(2)=yj*fac
3782           ggg(3)=zj*fac
3783 cgrad          if (j.lt.i) then
3784 cd          write (iout,*) 'j<i'
3785 C Uncomment following three lines for SC-p interactions
3786 c           do k=1,3
3787 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3788 c           enddo
3789 cgrad          else
3790 cd          write (iout,*) 'j>i'
3791 cgrad            do k=1,3
3792 cgrad              ggg(k)=-ggg(k)
3793 C Uncomment following line for SC-p interactions
3794 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3795 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3796 cgrad            enddo
3797 cgrad          endif
3798 cgrad          do k=1,3
3799 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3800 cgrad          enddo
3801 cgrad          kstart=min0(i+1,j)
3802 cgrad          kend=max0(i-1,j-1)
3803 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3804 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3805 cgrad          do k=kstart,kend
3806 cgrad            do l=1,3
3807 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3808 cgrad            enddo
3809 cgrad          enddo
3810           do k=1,3
3811             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3812             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3813           enddo
3814         enddo
3815
3816         enddo ! iint
3817       enddo ! i
3818       do i=1,nct
3819         do j=1,3
3820           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3821           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3822           gradx_scp(j,i)=expon*gradx_scp(j,i)
3823         enddo
3824       enddo
3825 C******************************************************************************
3826 C
3827 C                              N O T E !!!
3828 C
3829 C To save time the factor EXPON has been extracted from ALL components
3830 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3831 C use!
3832 C
3833 C******************************************************************************
3834       return
3835       end
3836 C--------------------------------------------------------------------------
3837       subroutine edis(ehpb)
3838 C
3839 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3840 C
3841       implicit real*8 (a-h,o-z)
3842       include 'DIMENSIONS'
3843       include 'COMMON.SBRIDGE'
3844       include 'COMMON.CHAIN'
3845       include 'COMMON.DERIV'
3846       include 'COMMON.VAR'
3847       include 'COMMON.INTERACT'
3848       dimension ggg(3)
3849       ehpb=0.0D0
3850 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3851 cd    print *,'link_start=',link_start,' link_end=',link_end
3852       if (link_end.eq.0) return
3853       do i=link_start,link_end
3854 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3855 C CA-CA distance used in regularization of structure.
3856         ii=ihpb(i)
3857         jj=jhpb(i)
3858 C iii and jjj point to the residues for which the distance is assigned.
3859         if (ii.gt.nres) then
3860           iii=ii-nres
3861           jjj=jj-nres
3862         else
3863           iii=ii
3864           jjj=jj
3865         endif
3866 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3867 C    distance and angle dependent SS bond potential.
3868         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3869           call ssbond_ene(iii,jjj,eij)
3870           ehpb=ehpb+2*eij
3871         else
3872 C Calculate the distance between the two points and its difference from the
3873 C target distance.
3874         dd=dist(ii,jj)
3875         rdis=dd-dhpb(i)
3876 C Get the force constant corresponding to this distance.
3877         waga=forcon(i)
3878 C Calculate the contribution to energy.
3879         ehpb=ehpb+waga*rdis*rdis
3880 C
3881 C Evaluate gradient.
3882 C
3883         fac=waga*rdis/dd
3884 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3885 cd   &   ' waga=',waga,' fac=',fac
3886         do j=1,3
3887           ggg(j)=fac*(c(j,jj)-c(j,ii))
3888         enddo
3889 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3890 C If this is a SC-SC distance, we need to calculate the contributions to the
3891 C Cartesian gradient in the SC vectors (ghpbx).
3892         if (iii.lt.ii) then
3893           do j=1,3
3894             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3895             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3896           enddo
3897         endif
3898         do j=iii,jjj-1
3899           do k=1,3
3900             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3901           enddo
3902         enddo
3903         endif
3904       enddo
3905       ehpb=0.5D0*ehpb
3906       return
3907       end
3908 C--------------------------------------------------------------------------
3909       subroutine ssbond_ene(i,j,eij)
3910 C
3911 C Calculate the distance and angle dependent SS-bond potential energy
3912 C using a free-energy function derived based on RHF/6-31G** ab initio
3913 C calculations of diethyl disulfide.
3914 C
3915 C A. Liwo and U. Kozlowska, 11/24/03
3916 C
3917       implicit real*8 (a-h,o-z)
3918       include 'DIMENSIONS'
3919       include 'COMMON.SBRIDGE'
3920       include 'COMMON.CHAIN'
3921       include 'COMMON.DERIV'
3922       include 'COMMON.LOCAL'
3923       include 'COMMON.INTERACT'
3924       include 'COMMON.VAR'
3925       include 'COMMON.IOUNITS'
3926       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3927       itypi=itype(i)
3928       xi=c(1,nres+i)
3929       yi=c(2,nres+i)
3930       zi=c(3,nres+i)
3931       dxi=dc_norm(1,nres+i)
3932       dyi=dc_norm(2,nres+i)
3933       dzi=dc_norm(3,nres+i)
3934       dsci_inv=dsc_inv(itypi)
3935       itypj=itype(j)
3936       dscj_inv=dsc_inv(itypj)
3937       xj=c(1,nres+j)-xi
3938       yj=c(2,nres+j)-yi
3939       zj=c(3,nres+j)-zi
3940       dxj=dc_norm(1,nres+j)
3941       dyj=dc_norm(2,nres+j)
3942       dzj=dc_norm(3,nres+j)
3943       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3944       rij=dsqrt(rrij)
3945       erij(1)=xj*rij
3946       erij(2)=yj*rij
3947       erij(3)=zj*rij
3948       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3949       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3950       om12=dxi*dxj+dyi*dyj+dzi*dzj
3951       do k=1,3
3952         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3953         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3954       enddo
3955       rij=1.0d0/rij
3956       deltad=rij-d0cm
3957       deltat1=1.0d0-om1
3958       deltat2=1.0d0+om2
3959       deltat12=om2-om1+2.0d0
3960       cosphi=om12-om1*om2
3961       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3962      &  +akct*deltad*deltat12
3963      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3964 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3965 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3966 c     &  " deltat12",deltat12," eij",eij
3967       ed=2*akcm*deltad+akct*deltat12
3968       pom1=akct*deltad
3969       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3970       eom1=-2*akth*deltat1-pom1-om2*pom2
3971       eom2= 2*akth*deltat2+pom1-om1*pom2
3972       eom12=pom2
3973       do k=1,3
3974         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3975       enddo
3976       do k=1,3
3977         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3978      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3979         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3980      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3981       enddo
3982 C
3983 C Calculate the components of the gradient in DC and X
3984 C
3985       do k=i,j-1
3986         do l=1,3
3987           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3988         enddo
3989       enddo
3990       return
3991       end
3992 C--------------------------------------------------------------------------
3993       subroutine ebond(estr)
3994 c
3995 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3996 c
3997       implicit real*8 (a-h,o-z)
3998       include 'DIMENSIONS'
3999       include 'COMMON.LOCAL'
4000       include 'COMMON.GEO'
4001       include 'COMMON.INTERACT'
4002       include 'COMMON.DERIV'
4003       include 'COMMON.VAR'
4004       include 'COMMON.CHAIN'
4005       include 'COMMON.IOUNITS'
4006       include 'COMMON.NAMES'
4007       include 'COMMON.FFIELD'
4008       include 'COMMON.CONTROL'
4009       include 'COMMON.SETUP'
4010       double precision u(3),ud(3)
4011       estr=0.0d0
4012       do i=ibondp_start,ibondp_end
4013         diff = vbld(i)-vbldp0
4014 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4015         estr=estr+diff*diff
4016         do j=1,3
4017           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4018         enddo
4019 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4020       enddo
4021       estr=0.5d0*AKP*estr
4022 c
4023 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4024 c
4025       do i=ibond_start,ibond_end
4026         iti=itype(i)
4027         if (iti.ne.10) then
4028           nbi=nbondterm(iti)
4029           if (nbi.eq.1) then
4030             diff=vbld(i+nres)-vbldsc0(1,iti)
4031 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4032 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4033             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4034             do j=1,3
4035               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4036             enddo
4037           else
4038             do j=1,nbi
4039               diff=vbld(i+nres)-vbldsc0(j,iti)
4040               ud(j)=aksc(j,iti)*diff
4041               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4042             enddo
4043             uprod=u(1)
4044             do j=2,nbi
4045               uprod=uprod*u(j)
4046             enddo
4047             usum=0.0d0
4048             usumsqder=0.0d0
4049             do j=1,nbi
4050               uprod1=1.0d0
4051               uprod2=1.0d0
4052               do k=1,nbi
4053                 if (k.ne.j) then
4054                   uprod1=uprod1*u(k)
4055                   uprod2=uprod2*u(k)*u(k)
4056                 endif
4057               enddo
4058               usum=usum+uprod1
4059               usumsqder=usumsqder+ud(j)*uprod2
4060             enddo
4061             estr=estr+uprod/usum
4062             do j=1,3
4063              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4064             enddo
4065           endif
4066         endif
4067       enddo
4068       return
4069       end
4070 #ifdef CRYST_THETA
4071 C--------------------------------------------------------------------------
4072       subroutine ebend(etheta)
4073 C
4074 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4075 C angles gamma and its derivatives in consecutive thetas and gammas.
4076 C
4077       implicit real*8 (a-h,o-z)
4078       include 'DIMENSIONS'
4079       include 'COMMON.LOCAL'
4080       include 'COMMON.GEO'
4081       include 'COMMON.INTERACT'
4082       include 'COMMON.DERIV'
4083       include 'COMMON.VAR'
4084       include 'COMMON.CHAIN'
4085       include 'COMMON.IOUNITS'
4086       include 'COMMON.NAMES'
4087       include 'COMMON.FFIELD'
4088       include 'COMMON.CONTROL'
4089       common /calcthet/ term1,term2,termm,diffak,ratak,
4090      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4091      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4092       double precision y(2),z(2)
4093       delta=0.02d0*pi
4094 c      time11=dexp(-2*time)
4095 c      time12=1.0d0
4096       etheta=0.0D0
4097 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4098       do i=ithet_start,ithet_end
4099 C Zero the energy function and its derivative at 0 or pi.
4100         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4101         it=itype(i-1)
4102         if (i.gt.3) then
4103 #ifdef OSF
4104           phii=phi(i)
4105           if (phii.ne.phii) phii=150.0
4106 #else
4107           phii=phi(i)
4108 #endif
4109           y(1)=dcos(phii)
4110           y(2)=dsin(phii)
4111         else
4112           y(1)=0.0D0
4113           y(2)=0.0D0
4114         endif
4115         if (i.lt.nres) then
4116 #ifdef OSF
4117           phii1=phi(i+1)
4118           if (phii1.ne.phii1) phii1=150.0
4119           phii1=pinorm(phii1)
4120           z(1)=cos(phii1)
4121 #else
4122           phii1=phi(i+1)
4123           z(1)=dcos(phii1)
4124 #endif
4125           z(2)=dsin(phii1)
4126         else
4127           z(1)=0.0D0
4128           z(2)=0.0D0
4129         endif
4130 C Calculate the "mean" value of theta from the part of the distribution
4131 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4132 C In following comments this theta will be referred to as t_c.
4133         thet_pred_mean=0.0d0
4134         do k=1,2
4135           athetk=athet(k,it)
4136           bthetk=bthet(k,it)
4137           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4138         enddo
4139         dthett=thet_pred_mean*ssd
4140         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4141 C Derivatives of the "mean" values in gamma1 and gamma2.
4142         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4143         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4144         if (theta(i).gt.pi-delta) then
4145           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4146      &         E_tc0)
4147           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4148           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4149           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4150      &        E_theta)
4151           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4152      &        E_tc)
4153         else if (theta(i).lt.delta) then
4154           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4155           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4156           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4157      &        E_theta)
4158           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4159           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4160      &        E_tc)
4161         else
4162           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4163      &        E_theta,E_tc)
4164         endif
4165         etheta=etheta+ethetai
4166         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4167      &      'ebend',i,ethetai
4168         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4169         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4170         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4171       enddo
4172 C Ufff.... We've done all this!!!
4173       return
4174       end
4175 C---------------------------------------------------------------------------
4176       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4177      &     E_tc)
4178       implicit real*8 (a-h,o-z)
4179       include 'DIMENSIONS'
4180       include 'COMMON.LOCAL'
4181       include 'COMMON.IOUNITS'
4182       common /calcthet/ term1,term2,termm,diffak,ratak,
4183      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4184      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4185 C Calculate the contributions to both Gaussian lobes.
4186 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4187 C The "polynomial part" of the "standard deviation" of this part of
4188 C the distribution.
4189         sig=polthet(3,it)
4190         do j=2,0,-1
4191           sig=sig*thet_pred_mean+polthet(j,it)
4192         enddo
4193 C Derivative of the "interior part" of the "standard deviation of the"
4194 C gamma-dependent Gaussian lobe in t_c.
4195         sigtc=3*polthet(3,it)
4196         do j=2,1,-1
4197           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4198         enddo
4199         sigtc=sig*sigtc
4200 C Set the parameters of both Gaussian lobes of the distribution.
4201 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4202         fac=sig*sig+sigc0(it)
4203         sigcsq=fac+fac
4204         sigc=1.0D0/sigcsq
4205 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4206         sigsqtc=-4.0D0*sigcsq*sigtc
4207 c       print *,i,sig,sigtc,sigsqtc
4208 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4209         sigtc=-sigtc/(fac*fac)
4210 C Following variable is sigma(t_c)**(-2)
4211         sigcsq=sigcsq*sigcsq
4212         sig0i=sig0(it)
4213         sig0inv=1.0D0/sig0i**2
4214         delthec=thetai-thet_pred_mean
4215         delthe0=thetai-theta0i
4216         term1=-0.5D0*sigcsq*delthec*delthec
4217         term2=-0.5D0*sig0inv*delthe0*delthe0
4218 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4219 C NaNs in taking the logarithm. We extract the largest exponent which is added
4220 C to the energy (this being the log of the distribution) at the end of energy
4221 C term evaluation for this virtual-bond angle.
4222         if (term1.gt.term2) then
4223           termm=term1
4224           term2=dexp(term2-termm)
4225           term1=1.0d0
4226         else
4227           termm=term2
4228           term1=dexp(term1-termm)
4229           term2=1.0d0
4230         endif
4231 C The ratio between the gamma-independent and gamma-dependent lobes of
4232 C the distribution is a Gaussian function of thet_pred_mean too.
4233         diffak=gthet(2,it)-thet_pred_mean
4234         ratak=diffak/gthet(3,it)**2
4235         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4236 C Let's differentiate it in thet_pred_mean NOW.
4237         aktc=ak*ratak
4238 C Now put together the distribution terms to make complete distribution.
4239         termexp=term1+ak*term2
4240         termpre=sigc+ak*sig0i
4241 C Contribution of the bending energy from this theta is just the -log of
4242 C the sum of the contributions from the two lobes and the pre-exponential
4243 C factor. Simple enough, isn't it?
4244         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4245 C NOW the derivatives!!!
4246 C 6/6/97 Take into account the deformation.
4247         E_theta=(delthec*sigcsq*term1
4248      &       +ak*delthe0*sig0inv*term2)/termexp
4249         E_tc=((sigtc+aktc*sig0i)/termpre
4250      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4251      &       aktc*term2)/termexp)
4252       return
4253       end
4254 c-----------------------------------------------------------------------------
4255       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4256       implicit real*8 (a-h,o-z)
4257       include 'DIMENSIONS'
4258       include 'COMMON.LOCAL'
4259       include 'COMMON.IOUNITS'
4260       common /calcthet/ term1,term2,termm,diffak,ratak,
4261      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4262      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4263       delthec=thetai-thet_pred_mean
4264       delthe0=thetai-theta0i
4265 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4266       t3 = thetai-thet_pred_mean
4267       t6 = t3**2
4268       t9 = term1
4269       t12 = t3*sigcsq
4270       t14 = t12+t6*sigsqtc
4271       t16 = 1.0d0
4272       t21 = thetai-theta0i
4273       t23 = t21**2
4274       t26 = term2
4275       t27 = t21*t26
4276       t32 = termexp
4277       t40 = t32**2
4278       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4279      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4280      & *(-t12*t9-ak*sig0inv*t27)
4281       return
4282       end
4283 #else
4284 C--------------------------------------------------------------------------
4285       subroutine ebend(etheta)
4286 C
4287 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4288 C angles gamma and its derivatives in consecutive thetas and gammas.
4289 C ab initio-derived potentials from
4290 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4291 C
4292       implicit real*8 (a-h,o-z)
4293       include 'DIMENSIONS'
4294       include 'COMMON.LOCAL'
4295       include 'COMMON.GEO'
4296       include 'COMMON.INTERACT'
4297       include 'COMMON.DERIV'
4298       include 'COMMON.VAR'
4299       include 'COMMON.CHAIN'
4300       include 'COMMON.IOUNITS'
4301       include 'COMMON.NAMES'
4302       include 'COMMON.FFIELD'
4303       include 'COMMON.CONTROL'
4304       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4305      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4306      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4307      & sinph1ph2(maxdouble,maxdouble)
4308       logical lprn /.false./, lprn1 /.false./
4309       etheta=0.0D0
4310       do i=ithet_start,ithet_end
4311         dethetai=0.0d0
4312         dephii=0.0d0
4313         dephii1=0.0d0
4314         theti2=0.5d0*theta(i)
4315         ityp2=ithetyp(itype(i-1))
4316         do k=1,nntheterm
4317           coskt(k)=dcos(k*theti2)
4318           sinkt(k)=dsin(k*theti2)
4319         enddo
4320         if (i.gt.3) then
4321 #ifdef OSF
4322           phii=phi(i)
4323           if (phii.ne.phii) phii=150.0
4324 #else
4325           phii=phi(i)
4326 #endif
4327           ityp1=ithetyp(itype(i-2))
4328           do k=1,nsingle
4329             cosph1(k)=dcos(k*phii)
4330             sinph1(k)=dsin(k*phii)
4331           enddo
4332         else
4333           phii=0.0d0
4334           ityp1=nthetyp+1
4335           do k=1,nsingle
4336             cosph1(k)=0.0d0
4337             sinph1(k)=0.0d0
4338           enddo
4339         endif
4340         if (i.lt.nres) then
4341 #ifdef OSF
4342           phii1=phi(i+1)
4343           if (phii1.ne.phii1) phii1=150.0
4344           phii1=pinorm(phii1)
4345 #else
4346           phii1=phi(i+1)
4347 #endif
4348           ityp3=ithetyp(itype(i))
4349           do k=1,nsingle
4350             cosph2(k)=dcos(k*phii1)
4351             sinph2(k)=dsin(k*phii1)
4352           enddo
4353         else
4354           phii1=0.0d0
4355           ityp3=nthetyp+1
4356           do k=1,nsingle
4357             cosph2(k)=0.0d0
4358             sinph2(k)=0.0d0
4359           enddo
4360         endif
4361         ethetai=aa0thet(ityp1,ityp2,ityp3)
4362         do k=1,ndouble
4363           do l=1,k-1
4364             ccl=cosph1(l)*cosph2(k-l)
4365             ssl=sinph1(l)*sinph2(k-l)
4366             scl=sinph1(l)*cosph2(k-l)
4367             csl=cosph1(l)*sinph2(k-l)
4368             cosph1ph2(l,k)=ccl-ssl
4369             cosph1ph2(k,l)=ccl+ssl
4370             sinph1ph2(l,k)=scl+csl
4371             sinph1ph2(k,l)=scl-csl
4372           enddo
4373         enddo
4374         if (lprn) then
4375         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4376      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4377         write (iout,*) "coskt and sinkt"
4378         do k=1,nntheterm
4379           write (iout,*) k,coskt(k),sinkt(k)
4380         enddo
4381         endif
4382         do k=1,ntheterm
4383           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4384           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4385      &      *coskt(k)
4386           if (lprn)
4387      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4388      &     " ethetai",ethetai
4389         enddo
4390         if (lprn) then
4391         write (iout,*) "cosph and sinph"
4392         do k=1,nsingle
4393           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4394         enddo
4395         write (iout,*) "cosph1ph2 and sinph2ph2"
4396         do k=2,ndouble
4397           do l=1,k-1
4398             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4399      &         sinph1ph2(l,k),sinph1ph2(k,l)
4400           enddo
4401         enddo
4402         write(iout,*) "ethetai",ethetai
4403         endif
4404         do m=1,ntheterm2
4405           do k=1,nsingle
4406             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4407      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4408      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4409      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4410             ethetai=ethetai+sinkt(m)*aux
4411             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4412             dephii=dephii+k*sinkt(m)*(
4413      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4414      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4415             dephii1=dephii1+k*sinkt(m)*(
4416      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4417      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4418             if (lprn)
4419      &      write (iout,*) "m",m," k",k," bbthet",
4420      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4421      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4422      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4423      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4424           enddo
4425         enddo
4426         if (lprn)
4427      &  write(iout,*) "ethetai",ethetai
4428         do m=1,ntheterm3
4429           do k=2,ndouble
4430             do l=1,k-1
4431               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4432      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4433      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4434      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4435               ethetai=ethetai+sinkt(m)*aux
4436               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4437               dephii=dephii+l*sinkt(m)*(
4438      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4439      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4440      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4441      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4442               dephii1=dephii1+(k-l)*sinkt(m)*(
4443      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4444      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4445      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4446      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4447               if (lprn) then
4448               write (iout,*) "m",m," k",k," l",l," ffthet",
4449      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4450      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4451      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4452      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4453               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4454      &            cosph1ph2(k,l)*sinkt(m),
4455      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4456               endif
4457             enddo
4458           enddo
4459         enddo
4460 10      continue
4461         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4462      &   i,theta(i)*rad2deg,phii*rad2deg,
4463      &   phii1*rad2deg,ethetai
4464         etheta=etheta+ethetai
4465         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4466         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4467         gloc(nphi+i-2,icg)=wang*dethetai
4468       enddo
4469       return
4470       end
4471 #endif
4472 #ifdef CRYST_SC
4473 c-----------------------------------------------------------------------------
4474       subroutine esc(escloc)
4475 C Calculate the local energy of a side chain and its derivatives in the
4476 C corresponding virtual-bond valence angles THETA and the spherical angles
4477 C ALPHA and OMEGA.
4478       implicit real*8 (a-h,o-z)
4479       include 'DIMENSIONS'
4480       include 'COMMON.GEO'
4481       include 'COMMON.LOCAL'
4482       include 'COMMON.VAR'
4483       include 'COMMON.INTERACT'
4484       include 'COMMON.DERIV'
4485       include 'COMMON.CHAIN'
4486       include 'COMMON.IOUNITS'
4487       include 'COMMON.NAMES'
4488       include 'COMMON.FFIELD'
4489       include 'COMMON.CONTROL'
4490       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4491      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4492       common /sccalc/ time11,time12,time112,theti,it,nlobit
4493       delta=0.02d0*pi
4494       escloc=0.0D0
4495 c     write (iout,'(a)') 'ESC'
4496       do i=loc_start,loc_end
4497         it=itype(i)
4498         if (it.eq.10) goto 1
4499         nlobit=nlob(it)
4500 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4501 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4502         theti=theta(i+1)-pipol
4503         x(1)=dtan(theti)
4504         x(2)=alph(i)
4505         x(3)=omeg(i)
4506
4507         if (x(2).gt.pi-delta) then
4508           xtemp(1)=x(1)
4509           xtemp(2)=pi-delta
4510           xtemp(3)=x(3)
4511           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4512           xtemp(2)=pi
4513           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4514           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4515      &        escloci,dersc(2))
4516           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4517      &        ddersc0(1),dersc(1))
4518           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4519      &        ddersc0(3),dersc(3))
4520           xtemp(2)=pi-delta
4521           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4522           xtemp(2)=pi
4523           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4524           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4525      &            dersc0(2),esclocbi,dersc02)
4526           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4527      &            dersc12,dersc01)
4528           call splinthet(x(2),0.5d0*delta,ss,ssd)
4529           dersc0(1)=dersc01
4530           dersc0(2)=dersc02
4531           dersc0(3)=0.0d0
4532           do k=1,3
4533             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4534           enddo
4535           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4536 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4537 c    &             esclocbi,ss,ssd
4538           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4539 c         escloci=esclocbi
4540 c         write (iout,*) escloci
4541         else if (x(2).lt.delta) then
4542           xtemp(1)=x(1)
4543           xtemp(2)=delta
4544           xtemp(3)=x(3)
4545           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4546           xtemp(2)=0.0d0
4547           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4548           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4549      &        escloci,dersc(2))
4550           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4551      &        ddersc0(1),dersc(1))
4552           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4553      &        ddersc0(3),dersc(3))
4554           xtemp(2)=delta
4555           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4556           xtemp(2)=0.0d0
4557           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4558           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4559      &            dersc0(2),esclocbi,dersc02)
4560           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4561      &            dersc12,dersc01)
4562           dersc0(1)=dersc01
4563           dersc0(2)=dersc02
4564           dersc0(3)=0.0d0
4565           call splinthet(x(2),0.5d0*delta,ss,ssd)
4566           do k=1,3
4567             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4568           enddo
4569           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4570 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4571 c    &             esclocbi,ss,ssd
4572           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4573 c         write (iout,*) escloci
4574         else
4575           call enesc(x,escloci,dersc,ddummy,.false.)
4576         endif
4577
4578         escloc=escloc+escloci
4579         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4580      &     'escloc',i,escloci
4581 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4582
4583         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4584      &   wscloc*dersc(1)
4585         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4586         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4587     1   continue
4588       enddo
4589       return
4590       end
4591 C---------------------------------------------------------------------------
4592       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4593       implicit real*8 (a-h,o-z)
4594       include 'DIMENSIONS'
4595       include 'COMMON.GEO'
4596       include 'COMMON.LOCAL'
4597       include 'COMMON.IOUNITS'
4598       common /sccalc/ time11,time12,time112,theti,it,nlobit
4599       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4600       double precision contr(maxlob,-1:1)
4601       logical mixed
4602 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4603         escloc_i=0.0D0
4604         do j=1,3
4605           dersc(j)=0.0D0
4606           if (mixed) ddersc(j)=0.0d0
4607         enddo
4608         x3=x(3)
4609
4610 C Because of periodicity of the dependence of the SC energy in omega we have
4611 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4612 C To avoid underflows, first compute & store the exponents.
4613
4614         do iii=-1,1
4615
4616           x(3)=x3+iii*dwapi
4617
4618           do j=1,nlobit
4619             do k=1,3
4620               z(k)=x(k)-censc(k,j,it)
4621             enddo
4622             do k=1,3
4623               Axk=0.0D0
4624               do l=1,3
4625                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4626               enddo
4627               Ax(k,j,iii)=Axk
4628             enddo
4629             expfac=0.0D0
4630             do k=1,3
4631               expfac=expfac+Ax(k,j,iii)*z(k)
4632             enddo
4633             contr(j,iii)=expfac
4634           enddo ! j
4635
4636         enddo ! iii
4637
4638         x(3)=x3
4639 C As in the case of ebend, we want to avoid underflows in exponentiation and
4640 C subsequent NaNs and INFs in energy calculation.
4641 C Find the largest exponent
4642         emin=contr(1,-1)
4643         do iii=-1,1
4644           do j=1,nlobit
4645             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4646           enddo
4647         enddo
4648         emin=0.5D0*emin
4649 cd      print *,'it=',it,' emin=',emin
4650
4651 C Compute the contribution to SC energy and derivatives
4652         do iii=-1,1
4653
4654           do j=1,nlobit
4655 #ifdef OSF
4656             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4657             if(adexp.ne.adexp) adexp=1.0
4658             expfac=dexp(adexp)
4659 #else
4660             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4661 #endif
4662 cd          print *,'j=',j,' expfac=',expfac
4663             escloc_i=escloc_i+expfac
4664             do k=1,3
4665               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4666             enddo
4667             if (mixed) then
4668               do k=1,3,2
4669                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4670      &            +gaussc(k,2,j,it))*expfac
4671               enddo
4672             endif
4673           enddo
4674
4675         enddo ! iii
4676
4677         dersc(1)=dersc(1)/cos(theti)**2
4678         ddersc(1)=ddersc(1)/cos(theti)**2
4679         ddersc(3)=ddersc(3)
4680
4681         escloci=-(dlog(escloc_i)-emin)
4682         do j=1,3
4683           dersc(j)=dersc(j)/escloc_i
4684         enddo
4685         if (mixed) then
4686           do j=1,3,2
4687             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4688           enddo
4689         endif
4690       return
4691       end
4692 C------------------------------------------------------------------------------
4693       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4694       implicit real*8 (a-h,o-z)
4695       include 'DIMENSIONS'
4696       include 'COMMON.GEO'
4697       include 'COMMON.LOCAL'
4698       include 'COMMON.IOUNITS'
4699       common /sccalc/ time11,time12,time112,theti,it,nlobit
4700       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4701       double precision contr(maxlob)
4702       logical mixed
4703
4704       escloc_i=0.0D0
4705
4706       do j=1,3
4707         dersc(j)=0.0D0
4708       enddo
4709
4710       do j=1,nlobit
4711         do k=1,2
4712           z(k)=x(k)-censc(k,j,it)
4713         enddo
4714         z(3)=dwapi
4715         do k=1,3
4716           Axk=0.0D0
4717           do l=1,3
4718             Axk=Axk+gaussc(l,k,j,it)*z(l)
4719           enddo
4720           Ax(k,j)=Axk
4721         enddo
4722         expfac=0.0D0
4723         do k=1,3
4724           expfac=expfac+Ax(k,j)*z(k)
4725         enddo
4726         contr(j)=expfac
4727       enddo ! j
4728
4729 C As in the case of ebend, we want to avoid underflows in exponentiation and
4730 C subsequent NaNs and INFs in energy calculation.
4731 C Find the largest exponent
4732       emin=contr(1)
4733       do j=1,nlobit
4734         if (emin.gt.contr(j)) emin=contr(j)
4735       enddo
4736       emin=0.5D0*emin
4737
4738 C Compute the contribution to SC energy and derivatives
4739
4740       dersc12=0.0d0
4741       do j=1,nlobit
4742         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4743         escloc_i=escloc_i+expfac
4744         do k=1,2
4745           dersc(k)=dersc(k)+Ax(k,j)*expfac
4746         enddo
4747         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4748      &            +gaussc(1,2,j,it))*expfac
4749         dersc(3)=0.0d0
4750       enddo
4751
4752       dersc(1)=dersc(1)/cos(theti)**2
4753       dersc12=dersc12/cos(theti)**2
4754       escloci=-(dlog(escloc_i)-emin)
4755       do j=1,2
4756         dersc(j)=dersc(j)/escloc_i
4757       enddo
4758       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4759       return
4760       end
4761 #else
4762 c----------------------------------------------------------------------------------
4763       subroutine esc(escloc)
4764 C Calculate the local energy of a side chain and its derivatives in the
4765 C corresponding virtual-bond valence angles THETA and the spherical angles
4766 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4767 C added by Urszula Kozlowska. 07/11/2007
4768 C
4769       implicit real*8 (a-h,o-z)
4770       include 'DIMENSIONS'
4771       include 'COMMON.GEO'
4772       include 'COMMON.LOCAL'
4773       include 'COMMON.VAR'
4774       include 'COMMON.SCROT'
4775       include 'COMMON.INTERACT'
4776       include 'COMMON.DERIV'
4777       include 'COMMON.CHAIN'
4778       include 'COMMON.IOUNITS'
4779       include 'COMMON.NAMES'
4780       include 'COMMON.FFIELD'
4781       include 'COMMON.CONTROL'
4782       include 'COMMON.VECTORS'
4783       double precision x_prime(3),y_prime(3),z_prime(3)
4784      &    , sumene,dsc_i,dp2_i,x(65),
4785      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4786      &    de_dxx,de_dyy,de_dzz,de_dt
4787       double precision s1_t,s1_6_t,s2_t,s2_6_t
4788       double precision
4789      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4790      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4791      & dt_dCi(3),dt_dCi1(3)
4792       common /sccalc/ time11,time12,time112,theti,it,nlobit
4793       delta=0.02d0*pi
4794       escloc=0.0D0
4795       do i=loc_start,loc_end
4796         costtab(i+1) =dcos(theta(i+1))
4797         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4798         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4799         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4800         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4801         cosfac=dsqrt(cosfac2)
4802         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4803         sinfac=dsqrt(sinfac2)
4804         it=itype(i)
4805         if (it.eq.10) goto 1
4806 c
4807 C  Compute the axes of tghe local cartesian coordinates system; store in
4808 c   x_prime, y_prime and z_prime
4809 c
4810         do j=1,3
4811           x_prime(j) = 0.00
4812           y_prime(j) = 0.00
4813           z_prime(j) = 0.00
4814         enddo
4815 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4816 C     &   dc_norm(3,i+nres)
4817         do j = 1,3
4818           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4819           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4820         enddo
4821         do j = 1,3
4822           z_prime(j) = -uz(j,i-1)
4823         enddo
4824 c       write (2,*) "i",i
4825 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4826 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4827 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4828 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4829 c      & " xy",scalar(x_prime(1),y_prime(1)),
4830 c      & " xz",scalar(x_prime(1),z_prime(1)),
4831 c      & " yy",scalar(y_prime(1),y_prime(1)),
4832 c      & " yz",scalar(y_prime(1),z_prime(1)),
4833 c      & " zz",scalar(z_prime(1),z_prime(1))
4834 c
4835 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4836 C to local coordinate system. Store in xx, yy, zz.
4837 c
4838         xx=0.0d0
4839         yy=0.0d0
4840         zz=0.0d0
4841         do j = 1,3
4842           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4843           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4844           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4845         enddo
4846
4847         xxtab(i)=xx
4848         yytab(i)=yy
4849         zztab(i)=zz
4850 C
4851 C Compute the energy of the ith side cbain
4852 C
4853 c        write (2,*) "xx",xx," yy",yy," zz",zz
4854         it=itype(i)
4855         do j = 1,65
4856           x(j) = sc_parmin(j,it)
4857         enddo
4858 #ifdef CHECK_COORD
4859 Cc diagnostics - remove later
4860         xx1 = dcos(alph(2))
4861         yy1 = dsin(alph(2))*dcos(omeg(2))
4862         zz1 = -dsin(alph(2))*dsin(omeg(2))
4863         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4864      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4865      &    xx1,yy1,zz1
4866 C,"  --- ", xx_w,yy_w,zz_w
4867 c end diagnostics
4868 #endif
4869         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4870      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4871      &   + x(10)*yy*zz
4872         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4873      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4874      & + x(20)*yy*zz
4875         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4876      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4877      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4878      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4879      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4880      &  +x(40)*xx*yy*zz
4881         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4882      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4883      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4884      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4885      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4886      &  +x(60)*xx*yy*zz
4887         dsc_i   = 0.743d0+x(61)
4888         dp2_i   = 1.9d0+x(62)
4889         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4890      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4891         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4892      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4893         s1=(1+x(63))/(0.1d0 + dscp1)
4894         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4895         s2=(1+x(65))/(0.1d0 + dscp2)
4896         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4897         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4898      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4899 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4900 c     &   sumene4,
4901 c     &   dscp1,dscp2,sumene
4902 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4903         escloc = escloc + sumene
4904 c        write (2,*) "i",i," escloc",sumene,escloc
4905 #ifdef DEBUG
4906 C
4907 C This section to check the numerical derivatives of the energy of ith side
4908 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4909 C #define DEBUG in the code to turn it on.
4910 C
4911         write (2,*) "sumene               =",sumene
4912         aincr=1.0d-7
4913         xxsave=xx
4914         xx=xx+aincr
4915         write (2,*) xx,yy,zz
4916         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4917         de_dxx_num=(sumenep-sumene)/aincr
4918         xx=xxsave
4919         write (2,*) "xx+ sumene from enesc=",sumenep
4920         yysave=yy
4921         yy=yy+aincr
4922         write (2,*) xx,yy,zz
4923         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4924         de_dyy_num=(sumenep-sumene)/aincr
4925         yy=yysave
4926         write (2,*) "yy+ sumene from enesc=",sumenep
4927         zzsave=zz
4928         zz=zz+aincr
4929         write (2,*) xx,yy,zz
4930         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4931         de_dzz_num=(sumenep-sumene)/aincr
4932         zz=zzsave
4933         write (2,*) "zz+ sumene from enesc=",sumenep
4934         costsave=cost2tab(i+1)
4935         sintsave=sint2tab(i+1)
4936         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4937         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4938         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4939         de_dt_num=(sumenep-sumene)/aincr
4940         write (2,*) " t+ sumene from enesc=",sumenep
4941         cost2tab(i+1)=costsave
4942         sint2tab(i+1)=sintsave
4943 C End of diagnostics section.
4944 #endif
4945 C
4946 C Compute the gradient of esc
4947 C
4948         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4949         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4950         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4951         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4952         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4953         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4954         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4955         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4956         pom1=(sumene3*sint2tab(i+1)+sumene1)
4957      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4958         pom2=(sumene4*cost2tab(i+1)+sumene2)
4959      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4960         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4961         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4962      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4963      &  +x(40)*yy*zz
4964         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4965         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4966      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4967      &  +x(60)*yy*zz
4968         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4969      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4970      &        +(pom1+pom2)*pom_dx
4971 #ifdef DEBUG
4972         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4973 #endif
4974 C
4975         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4976         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4977      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4978      &  +x(40)*xx*zz
4979         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4980         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4981      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4982      &  +x(59)*zz**2 +x(60)*xx*zz
4983         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4984      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4985      &        +(pom1-pom2)*pom_dy
4986 #ifdef DEBUG
4987         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4988 #endif
4989 C
4990         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4991      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4992      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4993      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4994      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4995      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4996      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4997      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4998 #ifdef DEBUG
4999         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5000 #endif
5001 C
5002         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5003      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5004      &  +pom1*pom_dt1+pom2*pom_dt2
5005 #ifdef DEBUG
5006         write(2,*), "de_dt = ", de_dt,de_dt_num
5007 #endif
5008 c
5009 C
5010        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5011        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5012        cosfac2xx=cosfac2*xx
5013        sinfac2yy=sinfac2*yy
5014        do k = 1,3
5015          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5016      &      vbld_inv(i+1)
5017          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5018      &      vbld_inv(i)
5019          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5020          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5021 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5022 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5023 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5024 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5025          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5026          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5027          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5028          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5029          dZZ_Ci1(k)=0.0d0
5030          dZZ_Ci(k)=0.0d0
5031          do j=1,3
5032            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5033            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5034          enddo
5035
5036          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5037          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5038          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5039 c
5040          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5041          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5042        enddo
5043
5044        do k=1,3
5045          dXX_Ctab(k,i)=dXX_Ci(k)
5046          dXX_C1tab(k,i)=dXX_Ci1(k)
5047          dYY_Ctab(k,i)=dYY_Ci(k)
5048          dYY_C1tab(k,i)=dYY_Ci1(k)
5049          dZZ_Ctab(k,i)=dZZ_Ci(k)
5050          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5051          dXX_XYZtab(k,i)=dXX_XYZ(k)
5052          dYY_XYZtab(k,i)=dYY_XYZ(k)
5053          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5054        enddo
5055
5056        do k = 1,3
5057 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5058 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5059 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5060 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5061 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5062 c     &    dt_dci(k)
5063 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5064 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5065          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5066      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5067          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5068      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5069          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5070      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5071        enddo
5072 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5073 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5074
5075 C to check gradient call subroutine check_grad
5076
5077     1 continue
5078       enddo
5079       return
5080       end
5081 c------------------------------------------------------------------------------
5082       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5083       implicit none
5084       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5085      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5086       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5087      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5088      &   + x(10)*yy*zz
5089       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5090      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5091      & + x(20)*yy*zz
5092       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5093      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5094      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5095      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5096      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5097      &  +x(40)*xx*yy*zz
5098       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5099      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5100      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5101      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5102      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5103      &  +x(60)*xx*yy*zz
5104       dsc_i   = 0.743d0+x(61)
5105       dp2_i   = 1.9d0+x(62)
5106       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5107      &          *(xx*cost2+yy*sint2))
5108       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5109      &          *(xx*cost2-yy*sint2))
5110       s1=(1+x(63))/(0.1d0 + dscp1)
5111       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5112       s2=(1+x(65))/(0.1d0 + dscp2)
5113       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5114       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5115      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5116       enesc=sumene
5117       return
5118       end
5119 #endif
5120 c------------------------------------------------------------------------------
5121       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5122 C
5123 C This procedure calculates two-body contact function g(rij) and its derivative:
5124 C
5125 C           eps0ij                                     !       x < -1
5126 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5127 C            0                                         !       x > 1
5128 C
5129 C where x=(rij-r0ij)/delta
5130 C
5131 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5132 C
5133       implicit none
5134       double precision rij,r0ij,eps0ij,fcont,fprimcont
5135       double precision x,x2,x4,delta
5136 c     delta=0.02D0*r0ij
5137 c      delta=0.2D0*r0ij
5138       x=(rij-r0ij)/delta
5139       if (x.lt.-1.0D0) then
5140         fcont=eps0ij
5141         fprimcont=0.0D0
5142       else if (x.le.1.0D0) then
5143         x2=x*x
5144         x4=x2*x2
5145         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5146         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5147       else
5148         fcont=0.0D0
5149         fprimcont=0.0D0
5150       endif
5151       return
5152       end
5153 c------------------------------------------------------------------------------
5154       subroutine splinthet(theti,delta,ss,ssder)
5155       implicit real*8 (a-h,o-z)
5156       include 'DIMENSIONS'
5157       include 'COMMON.VAR'
5158       include 'COMMON.GEO'
5159       thetup=pi-delta
5160       thetlow=delta
5161       if (theti.gt.pipol) then
5162         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5163       else
5164         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5165         ssder=-ssder
5166       endif
5167       return
5168       end
5169 c------------------------------------------------------------------------------
5170       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5171       implicit none
5172       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5173       double precision ksi,ksi2,ksi3,a1,a2,a3
5174       a1=fprim0*delta/(f1-f0)
5175       a2=3.0d0-2.0d0*a1
5176       a3=a1-2.0d0
5177       ksi=(x-x0)/delta
5178       ksi2=ksi*ksi
5179       ksi3=ksi2*ksi
5180       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5181       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5182       return
5183       end
5184 c------------------------------------------------------------------------------
5185       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5186       implicit none
5187       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5188       double precision ksi,ksi2,ksi3,a1,a2,a3
5189       ksi=(x-x0)/delta
5190       ksi2=ksi*ksi
5191       ksi3=ksi2*ksi
5192       a1=fprim0x*delta
5193       a2=3*(f1x-f0x)-2*fprim0x*delta
5194       a3=fprim0x*delta-2*(f1x-f0x)
5195       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5196       return
5197       end
5198 C-----------------------------------------------------------------------------
5199 #ifdef CRYST_TOR
5200 C-----------------------------------------------------------------------------
5201       subroutine etor(etors,edihcnstr)
5202       implicit real*8 (a-h,o-z)
5203       include 'DIMENSIONS'
5204       include 'COMMON.VAR'
5205       include 'COMMON.GEO'
5206       include 'COMMON.LOCAL'
5207       include 'COMMON.TORSION'
5208       include 'COMMON.INTERACT'
5209       include 'COMMON.DERIV'
5210       include 'COMMON.CHAIN'
5211       include 'COMMON.NAMES'
5212       include 'COMMON.IOUNITS'
5213       include 'COMMON.FFIELD'
5214       include 'COMMON.TORCNSTR'
5215       include 'COMMON.CONTROL'
5216       logical lprn
5217 C Set lprn=.true. for debugging
5218       lprn=.false.
5219 c      lprn=.true.
5220       etors=0.0D0
5221       do i=iphi_start,iphi_end
5222       etors_ii=0.0D0
5223         itori=itortyp(itype(i-2))
5224         itori1=itortyp(itype(i-1))
5225         phii=phi(i)
5226         gloci=0.0D0
5227 C Proline-Proline pair is a special case...
5228         if (itori.eq.3 .and. itori1.eq.3) then
5229           if (phii.gt.-dwapi3) then
5230             cosphi=dcos(3*phii)
5231             fac=1.0D0/(1.0D0-cosphi)
5232             etorsi=v1(1,3,3)*fac
5233             etorsi=etorsi+etorsi
5234             etors=etors+etorsi-v1(1,3,3)
5235             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5236             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5237           endif
5238           do j=1,3
5239             v1ij=v1(j+1,itori,itori1)
5240             v2ij=v2(j+1,itori,itori1)
5241             cosphi=dcos(j*phii)
5242             sinphi=dsin(j*phii)
5243             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5244             if (energy_dec) etors_ii=etors_ii+
5245      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5246             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5247           enddo
5248         else
5249           do j=1,nterm_old
5250             v1ij=v1(j,itori,itori1)
5251             v2ij=v2(j,itori,itori1)
5252             cosphi=dcos(j*phii)
5253             sinphi=dsin(j*phii)
5254             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5255             if (energy_dec) etors_ii=etors_ii+
5256      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5257             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5258           enddo
5259         endif
5260         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5261              'etor',i,etors_ii
5262         if (lprn)
5263      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5264      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5265      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5266         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5267 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5268       enddo
5269 ! 6/20/98 - dihedral angle constraints
5270       edihcnstr=0.0d0
5271       do i=1,ndih_constr
5272         itori=idih_constr(i)
5273         phii=phi(itori)
5274         difi=phii-phi0(i)
5275         if (difi.gt.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         else if (difi.lt.-drange(i)) then
5280           difi=difi+drange(i)
5281           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5282           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5283         endif
5284 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5285 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5286       enddo
5287 !      write (iout,*) 'edihcnstr',edihcnstr
5288       return
5289       end
5290 c------------------------------------------------------------------------------
5291       subroutine etor_d(etors_d)
5292       etors_d=0.0d0
5293       return
5294       end
5295 c----------------------------------------------------------------------------
5296 #else
5297       subroutine etor(etors,edihcnstr)
5298       implicit real*8 (a-h,o-z)
5299       include 'DIMENSIONS'
5300       include 'COMMON.VAR'
5301       include 'COMMON.GEO'
5302       include 'COMMON.LOCAL'
5303       include 'COMMON.TORSION'
5304       include 'COMMON.INTERACT'
5305       include 'COMMON.DERIV'
5306       include 'COMMON.CHAIN'
5307       include 'COMMON.NAMES'
5308       include 'COMMON.IOUNITS'
5309       include 'COMMON.FFIELD'
5310       include 'COMMON.TORCNSTR'
5311       include 'COMMON.CONTROL'
5312       logical lprn
5313 C Set lprn=.true. for debugging
5314       lprn=.false.
5315 c     lprn=.true.
5316       etors=0.0D0
5317       do i=iphi_start,iphi_end
5318       etors_ii=0.0D0
5319         itori=itortyp(itype(i-2))
5320         itori1=itortyp(itype(i-1))
5321         phii=phi(i)
5322         gloci=0.0D0
5323 C Regular cosine and sine terms
5324         do j=1,nterm(itori,itori1)
5325           v1ij=v1(j,itori,itori1)
5326           v2ij=v2(j,itori,itori1)
5327           cosphi=dcos(j*phii)
5328           sinphi=dsin(j*phii)
5329           etors=etors+v1ij*cosphi+v2ij*sinphi
5330           if (energy_dec) etors_ii=etors_ii+
5331      &                v1ij*cosphi+v2ij*sinphi
5332           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5333         enddo
5334 C Lorentz terms
5335 C                         v1
5336 C  E = SUM ----------------------------------- - v1
5337 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5338 C
5339         cosphi=dcos(0.5d0*phii)
5340         sinphi=dsin(0.5d0*phii)
5341         do j=1,nlor(itori,itori1)
5342           vl1ij=vlor1(j,itori,itori1)
5343           vl2ij=vlor2(j,itori,itori1)
5344           vl3ij=vlor3(j,itori,itori1)
5345           pom=vl2ij*cosphi+vl3ij*sinphi
5346           pom1=1.0d0/(pom*pom+1.0d0)
5347           etors=etors+vl1ij*pom1
5348           if (energy_dec) etors_ii=etors_ii+
5349      &                vl1ij*pom1
5350           pom=-pom*pom1*pom1
5351           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5352         enddo
5353 C Subtract the constant term
5354         etors=etors-v0(itori,itori1)
5355           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5356      &         'etor',i,etors_ii-v0(itori,itori1)
5357         if (lprn)
5358      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5359      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5360      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5361         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5362 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5363       enddo
5364 ! 6/20/98 - dihedral angle constraints
5365       edihcnstr=0.0d0
5366 c      do i=1,ndih_constr
5367       do i=idihconstr_start,idihconstr_end
5368         itori=idih_constr(i)
5369         phii=phi(itori)
5370         difi=pinorm(phii-phi0(i))
5371         if (difi.gt.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 if (difi.lt.-drange(i)) then
5376           difi=difi+drange(i)
5377           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5378           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5379         else
5380           difi=0.0
5381         endif
5382 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5383 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5384 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5385       enddo
5386 cd       write (iout,*) 'edihcnstr',edihcnstr
5387       return
5388       end
5389 c----------------------------------------------------------------------------
5390       subroutine etor_d(etors_d)
5391 C 6/23/01 Compute double torsional energy
5392       implicit real*8 (a-h,o-z)
5393       include 'DIMENSIONS'
5394       include 'COMMON.VAR'
5395       include 'COMMON.GEO'
5396       include 'COMMON.LOCAL'
5397       include 'COMMON.TORSION'
5398       include 'COMMON.INTERACT'
5399       include 'COMMON.DERIV'
5400       include 'COMMON.CHAIN'
5401       include 'COMMON.NAMES'
5402       include 'COMMON.IOUNITS'
5403       include 'COMMON.FFIELD'
5404       include 'COMMON.TORCNSTR'
5405       logical lprn
5406 C Set lprn=.true. for debugging
5407       lprn=.false.
5408 c     lprn=.true.
5409       etors_d=0.0D0
5410       do i=iphid_start,iphid_end
5411         itori=itortyp(itype(i-2))
5412         itori1=itortyp(itype(i-1))
5413         itori2=itortyp(itype(i))
5414         phii=phi(i)
5415         phii1=phi(i+1)
5416         gloci1=0.0D0
5417         gloci2=0.0D0
5418 C Regular cosine and sine terms
5419         do j=1,ntermd_1(itori,itori1,itori2)
5420           v1cij=v1c(1,j,itori,itori1,itori2)
5421           v1sij=v1s(1,j,itori,itori1,itori2)
5422           v2cij=v1c(2,j,itori,itori1,itori2)
5423           v2sij=v1s(2,j,itori,itori1,itori2)
5424           cosphi1=dcos(j*phii)
5425           sinphi1=dsin(j*phii)
5426           cosphi2=dcos(j*phii1)
5427           sinphi2=dsin(j*phii1)
5428           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5429      &     v2cij*cosphi2+v2sij*sinphi2
5430           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5431           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5432         enddo
5433         do k=2,ntermd_2(itori,itori1,itori2)
5434           do l=1,k-1
5435             v1cdij = v2c(k,l,itori,itori1,itori2)
5436             v2cdij = v2c(l,k,itori,itori1,itori2)
5437             v1sdij = v2s(k,l,itori,itori1,itori2)
5438             v2sdij = v2s(l,k,itori,itori1,itori2)
5439             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5440             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5441             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5442             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5443             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5444      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5445             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5446      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5447             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5448      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5449           enddo
5450         enddo
5451         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5452         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5453       enddo
5454       return
5455       end
5456 #endif
5457 c------------------------------------------------------------------------------
5458       subroutine eback_sc_corr(esccor)
5459 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5460 c        conformational states; temporarily implemented as differences
5461 c        between UNRES torsional potentials (dependent on three types of
5462 c        residues) and the torsional potentials dependent on all 20 types
5463 c        of residues computed from AM1  energy surfaces of terminally-blocked
5464 c        amino-acid residues.
5465       implicit real*8 (a-h,o-z)
5466       include 'DIMENSIONS'
5467       include 'COMMON.VAR'
5468       include 'COMMON.GEO'
5469       include 'COMMON.LOCAL'
5470       include 'COMMON.TORSION'
5471       include 'COMMON.SCCOR'
5472       include 'COMMON.INTERACT'
5473       include 'COMMON.DERIV'
5474       include 'COMMON.CHAIN'
5475       include 'COMMON.NAMES'
5476       include 'COMMON.IOUNITS'
5477       include 'COMMON.FFIELD'
5478       include 'COMMON.CONTROL'
5479       logical lprn
5480 C Set lprn=.true. for debugging
5481       lprn=.false.
5482 c      lprn=.true.
5483 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5484       esccor=0.0D0
5485       do i=iphi_start,iphi_end
5486         esccor_ii=0.0D0
5487         itori=itype(i-2)
5488         itori1=itype(i-1)
5489         phii=phi(i)
5490         gloci=0.0D0
5491         do j=1,nterm_sccor
5492           v1ij=v1sccor(j,itori,itori1)
5493           v2ij=v2sccor(j,itori,itori1)
5494           cosphi=dcos(j*phii)
5495           sinphi=dsin(j*phii)
5496           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5497           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5498         enddo
5499         if (lprn)
5500      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5501      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5502      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5503         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5504       enddo
5505       return
5506       end
5507 c----------------------------------------------------------------------------
5508       subroutine multibody(ecorr)
5509 C This subroutine calculates multi-body contributions to energy following
5510 C the idea of Skolnick et al. If side chains I and J make a contact and
5511 C at the same time side chains I+1 and J+1 make a contact, an extra
5512 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5513       implicit real*8 (a-h,o-z)
5514       include 'DIMENSIONS'
5515       include 'COMMON.IOUNITS'
5516       include 'COMMON.DERIV'
5517       include 'COMMON.INTERACT'
5518       include 'COMMON.CONTACTS'
5519       double precision gx(3),gx1(3)
5520       logical lprn
5521
5522 C Set lprn=.true. for debugging
5523       lprn=.false.
5524
5525       if (lprn) then
5526         write (iout,'(a)') 'Contact function values:'
5527         do i=nnt,nct-2
5528           write (iout,'(i2,20(1x,i2,f10.5))')
5529      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5530         enddo
5531       endif
5532       ecorr=0.0D0
5533       do i=nnt,nct
5534         do j=1,3
5535           gradcorr(j,i)=0.0D0
5536           gradxorr(j,i)=0.0D0
5537         enddo
5538       enddo
5539       do i=nnt,nct-2
5540
5541         DO ISHIFT = 3,4
5542
5543         i1=i+ishift
5544         num_conti=num_cont(i)
5545         num_conti1=num_cont(i1)
5546         do jj=1,num_conti
5547           j=jcont(jj,i)
5548           do kk=1,num_conti1
5549             j1=jcont(kk,i1)
5550             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5551 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5552 cd   &                   ' ishift=',ishift
5553 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5554 C The system gains extra energy.
5555               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5556             endif   ! j1==j+-ishift
5557           enddo     ! kk
5558         enddo       ! jj
5559
5560         ENDDO ! ISHIFT
5561
5562       enddo         ! i
5563       return
5564       end
5565 c------------------------------------------------------------------------------
5566       double precision function esccorr(i,j,k,l,jj,kk)
5567       implicit real*8 (a-h,o-z)
5568       include 'DIMENSIONS'
5569       include 'COMMON.IOUNITS'
5570       include 'COMMON.DERIV'
5571       include 'COMMON.INTERACT'
5572       include 'COMMON.CONTACTS'
5573       double precision gx(3),gx1(3)
5574       logical lprn
5575       lprn=.false.
5576       eij=facont(jj,i)
5577       ekl=facont(kk,k)
5578 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5579 C Calculate the multi-body contribution to energy.
5580 C Calculate multi-body contributions to the gradient.
5581 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5582 cd   & k,l,(gacont(m,kk,k),m=1,3)
5583       do m=1,3
5584         gx(m) =ekl*gacont(m,jj,i)
5585         gx1(m)=eij*gacont(m,kk,k)
5586         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5587         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5588         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5589         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5590       enddo
5591       do m=i,j-1
5592         do ll=1,3
5593           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5594         enddo
5595       enddo
5596       do m=k,l-1
5597         do ll=1,3
5598           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5599         enddo
5600       enddo
5601       esccorr=-eij*ekl
5602       return
5603       end
5604 c------------------------------------------------------------------------------
5605 #ifdef MPI
5606       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5607       implicit real*8 (a-h,o-z)
5608       include 'DIMENSIONS'
5609       integer dimen1,dimen2,atom,indx
5610       double precision buffer(dimen1,dimen2)
5611       double precision zapas
5612       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5613      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5614      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5615      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5616       num_kont=num_cont_hb(atom)
5617       do i=1,num_kont
5618         do k=1,8
5619           do j=1,3
5620             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5621           enddo ! j
5622         enddo ! k
5623         buffer(i,indx+25)=facont_hb(i,atom)
5624         buffer(i,indx+26)=ees0p(i,atom)
5625         buffer(i,indx+27)=ees0m(i,atom)
5626         buffer(i,indx+28)=d_cont(i,atom)
5627         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
5628       enddo ! i
5629       buffer(1,indx+30)=dfloat(num_kont)
5630       return
5631       end
5632 c------------------------------------------------------------------------------
5633       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5634       implicit real*8 (a-h,o-z)
5635       include 'DIMENSIONS'
5636       integer dimen1,dimen2,atom,indx
5637       double precision buffer(dimen1,dimen2)
5638       double precision zapas
5639       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5640      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5641      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5642      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5643       num_kont=buffer(1,indx+30)
5644       num_kont_old=num_cont_hb(atom)
5645       num_cont_hb(atom)=num_kont+num_kont_old
5646       do i=1,num_kont
5647         ii=i+num_kont_old
5648         do k=1,8
5649           do j=1,3
5650             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5651           enddo ! j
5652         enddo ! k
5653         facont_hb(ii,atom)=buffer(i,indx+25)
5654         ees0p(ii,atom)=buffer(i,indx+26)
5655         ees0m(ii,atom)=buffer(i,indx+27)
5656         d_cont(i,atom)=buffer(i,indx+28)
5657         jcont_hb(ii,atom)=buffer(i,indx+29)
5658       enddo ! i
5659       return
5660       end
5661 c------------------------------------------------------------------------------
5662 #endif
5663       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5664 C This subroutine calculates multi-body contributions to hydrogen-bonding
5665       implicit real*8 (a-h,o-z)
5666       include 'DIMENSIONS'
5667       include 'COMMON.IOUNITS'
5668 #ifdef MPI
5669       include "mpif.h"
5670       parameter (max_cont=maxconts)
5671       parameter (max_dim=2*(8*3+6))
5672       parameter (msglen1=max_cont*max_dim)
5673       parameter (msglen2=2*msglen1)
5674       integer source,CorrelType,CorrelID,Error
5675       double precision buffer(max_cont,max_dim)
5676       integer status(MPI_STATUS_SIZE)
5677 #endif
5678       include 'COMMON.SETUP'
5679       include 'COMMON.FFIELD'
5680       include 'COMMON.DERIV'
5681       include 'COMMON.INTERACT'
5682       include 'COMMON.CONTACTS'
5683       include 'COMMON.CONTROL'
5684       double precision gx(3),gx1(3),time00
5685       logical lprn,ldone
5686
5687 C Set lprn=.true. for debugging
5688       lprn=.false.
5689 #ifdef MPI
5690       n_corr=0
5691       n_corr1=0
5692       if (nfgtasks.le.1) goto 30
5693       if (lprn) then
5694         write (iout,'(a)') 'Contact function values:'
5695         do i=nnt,nct-2
5696           write (iout,'(2i3,50(1x,i2,f5.2))')
5697      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5698      &    j=1,num_cont_hb(i))
5699         enddo
5700       endif
5701 C Caution! Following code assumes that electrostatic interactions concerning
5702 C a given atom are split among at most two processors!
5703       CorrelType=477
5704       CorrelID=fg_rank+1
5705       ldone=.false.
5706       do i=1,max_cont
5707         do j=1,max_dim
5708           buffer(i,j)=0.0D0
5709         enddo
5710       enddo
5711       mm=mod(fg_rank,2)
5712 c      write (*,*) 'MyRank',MyRank,' mm',mm
5713       if (mm) 20,20,10
5714    10 continue
5715 c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5716       if (fg_rank.gt.0) then
5717 C Send correlation contributions to the preceding processor
5718         msglen=msglen1
5719         nn=num_cont_hb(iatel_s)
5720         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5721 c        write (*,*) 'The BUFFER array:'
5722 c        do i=1,nn
5723 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5724 c        enddo
5725         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5726           msglen=msglen2
5727           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5728 C Clear the contacts of the atom passed to the neighboring processor
5729         nn=num_cont_hb(iatel_s+1)
5730 c        do i=1,nn
5731 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5732 c        enddo
5733             num_cont_hb(iatel_s)=0
5734         endif
5735 cd      write (iout,*) 'Processor ',fg_rank,MyRank,
5736 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5737 cd   & ' msglen=',msglen
5738 c        write (*,*) 'Processor ',fg_rank,MyRank,
5739 c     & ' is sending correlation contribution to processor',fg_rank-1,
5740 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5741         time00=MPI_Wtime()
5742         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5743      &    CorrelType,FG_COMM,IERROR)
5744         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5745 cd      write (iout,*) 'Processor ',fg_rank,
5746 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5747 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5748 c        write (*,*) 'Processor ',fg_rank,
5749 c     & ' has sent correlation contribution to processor',fg_rank-1,
5750 c     & ' msglen=',msglen,' CorrelID=',CorrelID
5751 c        msglen=msglen1
5752       endif ! (fg_rank.gt.0)
5753       if (ldone) goto 30
5754       ldone=.true.
5755    20 continue
5756 c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5757       if (fg_rank.lt.nfgtasks-1) then
5758 C Receive correlation contributions from the next processor
5759         msglen=msglen1
5760         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5761 cd      write (iout,*) 'Processor',fg_rank,
5762 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5763 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5764 c        write (*,*) 'Processor',fg_rank,
5765 c     &' is receiving correlation contribution from processor',fg_rank+1,
5766 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5767         time00=MPI_Wtime()
5768         nbytes=-1
5769         do while (nbytes.le.0)
5770           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5771           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5772         enddo
5773 c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
5774         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5775      &    fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5776         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5777 c        write (*,*) 'Processor',fg_rank,
5778 c     &' has received correlation contribution from processor',fg_rank+1,
5779 c     & ' msglen=',msglen,' nbytes=',nbytes
5780 c        write (*,*) 'The received BUFFER array:'
5781 c        do i=1,max_cont
5782 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
5783 c        enddo
5784         if (msglen.eq.msglen1) then
5785           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5786         else if (msglen.eq.msglen2)  then
5787           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5788           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5789         else
5790           write (iout,*)
5791      & 'ERROR!!!! message length changed while processing correlations.'
5792           write (*,*)
5793      & 'ERROR!!!! message length changed while processing correlations.'
5794           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5795         endif ! msglen.eq.msglen1
5796       endif ! fg_rank.lt.nfgtasks-1
5797       if (ldone) goto 30
5798       ldone=.true.
5799       goto 10
5800    30 continue
5801 #endif
5802       if (lprn) then
5803         write (iout,'(a)') 'Contact function values:'
5804         do i=nnt,nct-2
5805           write (iout,'(2i3,50(1x,i2,f5.2))')
5806      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5807      &    j=1,num_cont_hb(i))
5808         enddo
5809       endif
5810       ecorr=0.0D0
5811 C Remove the loop below after debugging !!!
5812       do i=nnt,nct
5813         do j=1,3
5814           gradcorr(j,i)=0.0D0
5815           gradxorr(j,i)=0.0D0
5816         enddo
5817       enddo
5818 C Calculate the local-electrostatic correlation terms
5819       do i=iatel_s,iatel_e+1
5820         i1=i+1
5821         num_conti=num_cont_hb(i)
5822         num_conti1=num_cont_hb(i+1)
5823         do jj=1,num_conti
5824           j=jcont_hb(jj,i)
5825           do kk=1,num_conti1
5826             j1=jcont_hb(kk,i1)
5827 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5828 c     &         ' jj=',jj,' kk=',kk
5829             if (j1.eq.j+1 .or. j1.eq.j-1) then
5830 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5831 C The system gains extra energy.
5832               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5833               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5834      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5835               n_corr=n_corr+1
5836             else if (j1.eq.j) then
5837 C Contacts I-J and I-(J+1) occur simultaneously.
5838 C The system loses extra energy.
5839 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5840             endif
5841           enddo ! kk
5842           do kk=1,num_conti
5843             j1=jcont_hb(kk,i)
5844 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5845 c    &         ' jj=',jj,' kk=',kk
5846             if (j1.eq.j+1) then
5847 C Contacts I-J and (I+1)-J occur simultaneously.
5848 C The system loses extra energy.
5849 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5850             endif ! j1==j+1
5851           enddo ! kk
5852         enddo ! jj
5853       enddo ! i
5854       return
5855       end
5856 c------------------------------------------------------------------------------
5857       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5858      &  n_corr1)
5859 C This subroutine calculates multi-body contributions to hydrogen-bonding
5860       implicit real*8 (a-h,o-z)
5861       include 'DIMENSIONS'
5862       include 'COMMON.IOUNITS'
5863 #ifdef MPI
5864       include 'mpif.h'
5865       parameter (max_cont=maxconts)
5866       parameter (max_dim=2*(8*3+6))
5867 c      parameter (msglen1=max_cont*max_dim*4)
5868       parameter (msglen1=max_cont*max_dim/2)
5869       parameter (msglen2=2*msglen1)
5870       integer source,CorrelType,CorrelID,Error
5871       double precision buffer(max_cont,max_dim)
5872       integer status(MPI_STATUS_SIZE)
5873 #endif
5874       include 'COMMON.SETUP'
5875       include 'COMMON.FFIELD'
5876       include 'COMMON.DERIV'
5877       include 'COMMON.INTERACT'
5878       include 'COMMON.CONTACTS'
5879       include 'COMMON.CONTROL'
5880       double precision gx(3),gx1(3)
5881       logical lprn,ldone
5882 C Set lprn=.true. for debugging
5883       lprn=.false.
5884       eturn6=0.0d0
5885 #ifdef MPI
5886       n_corr=0
5887       n_corr1=0
5888       if (fgProcs.le.1) goto 30
5889       if (lprn) then
5890         write (iout,'(a)') 'Contact function values:'
5891         do i=nnt,nct-2
5892           write (iout,'(2i3,50(1x,i2,f5.2))')
5893      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5894      &    j=1,num_cont_hb(i))
5895         enddo
5896       endif
5897 C Caution! Following code assumes that electrostatic interactions concerning
5898 C a given atom are split among at most two processors!
5899       CorrelType=477
5900       CorrelID=MyID+1
5901       ldone=.false.
5902       do i=1,max_cont
5903         do j=1,max_dim
5904           buffer(i,j)=0.0D0
5905         enddo
5906       enddo
5907       mm=mod(MyRank,2)
5908 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5909       if (mm) 20,20,10
5910    10 continue
5911 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5912       if (MyRank.gt.0) then
5913 C Send correlation contributions to the preceding processor
5914         msglen=msglen1
5915         nn=num_cont_hb(iatel_s)
5916         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5917 cd      write (iout,*) 'The BUFFER array:'
5918 cd      do i=1,nn
5919 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5920 cd      enddo
5921         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5922           msglen=msglen2
5923             call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5924 C Clear the contacts of the atom passed to the neighboring processor
5925         nn=num_cont_hb(iatel_s+1)
5926 cd      do i=1,nn
5927 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5928 cd      enddo
5929             num_cont_hb(iatel_s)=0
5930         endif
5931 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5932 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5933 cd   & ' msglen=',msglen
5934 cd      write (*,*) 'Processor ',MyID,MyRank,
5935 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5936 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5937         time00=MPI_Wtime()
5938         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5939      &     CorrelType,FG_COMM,IERROR)
5940         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5941 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5942 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5943 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5944 cd      write (*,*) 'Processor ',fg_rank,
5945 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5946 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5947         msglen=msglen1
5948       endif ! (MyRank.gt.0)
5949       if (ldone) goto 30
5950       ldone=.true.
5951    20 continue
5952 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5953       if (fg_rank.lt.nfgtasks-1) then
5954 C Receive correlation contributions from the next processor
5955         msglen=msglen1
5956         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5957 cd      write (iout,*) 'Processor',fg_rank,
5958 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5959 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5960 cd      write (*,*) 'Processor',fg_rank,
5961 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5962 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5963         time00=MPI_Wtime()
5964         nbytes=-1
5965         do while (nbytes.le.0)
5966           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5967           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5968         enddo
5969 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5970         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5971      &    fg_rank+1,CorrelType,status,IERROR)
5972         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5973 cd      write (iout,*) 'Processor',fg_rank,
5974 cd   & ' has received correlation contribution from processor',fg_rank+1,
5975 cd   & ' msglen=',msglen,' nbytes=',nbytes
5976 cd      write (iout,*) 'The received BUFFER array:'
5977 cd      do i=1,max_cont
5978 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5979 cd      enddo
5980         if (msglen.eq.msglen1) then
5981           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5982         else if (msglen.eq.msglen2)  then
5983           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5984           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5985         else
5986           write (iout,*)
5987      & 'ERROR!!!! message length changed while processing correlations.'
5988           write (*,*)
5989      & 'ERROR!!!! message length changed while processing correlations.'
5990           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5991         endif ! msglen.eq.msglen1
5992       endif ! fg_rank.lt.nfgtasks-1
5993       if (ldone) goto 30
5994       ldone=.true.
5995       goto 10
5996    30 continue
5997 #endif
5998       if (lprn) then
5999         write (iout,'(a)') 'Contact function values:'
6000         do i=nnt,nct-2
6001           write (iout,'(2i3,50(1x,i2,f5.2))')
6002      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6003      &    j=1,num_cont_hb(i))
6004         enddo
6005       endif
6006       ecorr=0.0D0
6007       ecorr5=0.0d0
6008       ecorr6=0.0d0
6009 C Remove the loop below after debugging !!!
6010       do i=nnt,nct
6011         do j=1,3
6012           gradcorr(j,i)=0.0D0
6013           gradxorr(j,i)=0.0D0
6014         enddo
6015       enddo
6016 C Calculate the dipole-dipole interaction energies
6017       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6018       do i=iatel_s,iatel_e+1
6019         num_conti=num_cont_hb(i)
6020         do jj=1,num_conti
6021           j=jcont_hb(jj,i)
6022 #ifdef MOMENT
6023           call dipole(i,j,jj)
6024 #endif
6025         enddo
6026       enddo
6027       endif
6028 C Calculate the local-electrostatic correlation terms
6029       do i=iatel_s,iatel_e+1
6030         i1=i+1
6031         num_conti=num_cont_hb(i)
6032         num_conti1=num_cont_hb(i+1)
6033         do jj=1,num_conti
6034           j=jcont_hb(jj,i)
6035           do kk=1,num_conti1
6036             j1=jcont_hb(kk,i1)
6037 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6038 c     &         ' jj=',jj,' kk=',kk
6039             if (j1.eq.j+1 .or. j1.eq.j-1) then
6040 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6041 C The system gains extra energy.
6042               n_corr=n_corr+1
6043               sqd1=dsqrt(d_cont(jj,i))
6044               sqd2=dsqrt(d_cont(kk,i1))
6045               sred_geom = sqd1*sqd2
6046               IF (sred_geom.lt.cutoff_corr) THEN
6047                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6048      &            ekont,fprimcont)
6049 cd               write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6050 cd     &         ' jj=',jj,' kk=',kk
6051                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6052                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6053                 do l=1,3
6054                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6055                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6056                 enddo
6057                 n_corr1=n_corr1+1
6058 cd               write (iout,*) 'sred_geom=',sred_geom,
6059 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6060                 call calc_eello(i,j,i+1,j1,jj,kk)
6061                 if (wcorr4.gt.0.0d0)
6062      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6063                   if (energy_dec.and.wcorr4.gt.0.0d0)
6064      1                 write (iout,'(a6,2i5,0pf7.3)')
6065      2                'ecorr4',i,j,eello4(i,j,i+1,j1,jj,kk)
6066                 if (wcorr5.gt.0.0d0)
6067      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6068                   if (energy_dec.and.wcorr5.gt.0.0d0)
6069      1                 write (iout,'(a6,2i5,0pf7.3)')
6070      2                'ecorr5',i,j,eello5(i,j,i+1,j1,jj,kk)
6071 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6072 cd                write(2,*)'ijkl',i,j,i+1,j1
6073                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6074      &               .or. wturn6.eq.0.0d0))then
6075 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6076                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6077                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6078      1                'ecorr6',i,j,eello6(i,j,i+1,j1,jj,kk)
6079 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6080 cd     &            'ecorr6=',ecorr6
6081 cd                write (iout,'(4e15.5)') sred_geom,
6082 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6083 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6084 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6085                 else if (wturn6.gt.0.0d0
6086      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6087 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6088                   eturn6=eturn6+eello_turn6(i,jj,kk)
6089                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6090      1                 'eturn6',i,j,eello_turn6(i,jj,kk)
6091 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6092                 endif
6093               ENDIF
6094 1111          continue
6095             else if (j1.eq.j) then
6096 C Contacts I-J and I-(J+1) occur simultaneously.
6097 C The system loses extra energy.
6098 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6099             endif
6100           enddo ! kk
6101           do kk=1,num_conti
6102             j1=jcont_hb(kk,i)
6103 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6104 c    &         ' jj=',jj,' kk=',kk
6105             if (j1.eq.j+1) then
6106 C Contacts I-J and (I+1)-J occur simultaneously.
6107 C The system loses extra energy.
6108 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6109             endif ! j1==j+1
6110           enddo ! kk
6111         enddo ! jj
6112       enddo ! i
6113       return
6114       end
6115 c------------------------------------------------------------------------------
6116       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6117       implicit real*8 (a-h,o-z)
6118       include 'DIMENSIONS'
6119       include 'COMMON.IOUNITS'
6120       include 'COMMON.DERIV'
6121       include 'COMMON.INTERACT'
6122       include 'COMMON.CONTACTS'
6123       double precision gx(3),gx1(3)
6124       logical lprn
6125       lprn=.false.
6126       eij=facont_hb(jj,i)
6127       ekl=facont_hb(kk,k)
6128       ees0pij=ees0p(jj,i)
6129       ees0pkl=ees0p(kk,k)
6130       ees0mij=ees0m(jj,i)
6131       ees0mkl=ees0m(kk,k)
6132       ekont=eij*ekl
6133       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6134 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6135 C Following 4 lines for diagnostics.
6136 cd    ees0pkl=0.0D0
6137 cd    ees0pij=1.0D0
6138 cd    ees0mkl=0.0D0
6139 cd    ees0mij=1.0D0
6140 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6141 c    &   ' and',k,l
6142 c     write (iout,*)'Contacts have occurred for peptide groups',
6143 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6144 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6145 C Calculate the multi-body contribution to energy.
6146       ecorr=ecorr+ekont*ees
6147 C Calculate multi-body contributions to the gradient.
6148       do ll=1,3
6149         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6150         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6151      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6152      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6153         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6154      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6155      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6156         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6157         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6158      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6159      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6160         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6161      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6162      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6163       enddo
6164       do m=i+1,j-1
6165         do ll=1,3
6166           gradcorr(ll,m)=gradcorr(ll,m)+
6167      &     ees*ekl*gacont_hbr(ll,jj,i)-
6168      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6169      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6170         enddo
6171       enddo
6172       do m=k+1,l-1
6173         do ll=1,3
6174           gradcorr(ll,m)=gradcorr(ll,m)+
6175      &     ees*eij*gacont_hbr(ll,kk,k)-
6176      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6177      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6178         enddo
6179       enddo
6180       ehbcorr=ekont*ees
6181       return
6182       end
6183 #ifdef MOMENT
6184 C---------------------------------------------------------------------------
6185       subroutine dipole(i,j,jj)
6186       implicit real*8 (a-h,o-z)
6187       include 'DIMENSIONS'
6188       include 'COMMON.IOUNITS'
6189       include 'COMMON.CHAIN'
6190       include 'COMMON.FFIELD'
6191       include 'COMMON.DERIV'
6192       include 'COMMON.INTERACT'
6193       include 'COMMON.CONTACTS'
6194       include 'COMMON.TORSION'
6195       include 'COMMON.VAR'
6196       include 'COMMON.GEO'
6197       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6198      &  auxmat(2,2)
6199       iti1 = itortyp(itype(i+1))
6200       if (j.lt.nres-1) then
6201         itj1 = itortyp(itype(j+1))
6202       else
6203         itj1=ntortyp+1
6204       endif
6205       do iii=1,2
6206         dipi(iii,1)=Ub2(iii,i)
6207         dipderi(iii)=Ub2der(iii,i)
6208         dipi(iii,2)=b1(iii,iti1)
6209         dipj(iii,1)=Ub2(iii,j)
6210         dipderj(iii)=Ub2der(iii,j)
6211         dipj(iii,2)=b1(iii,itj1)
6212       enddo
6213       kkk=0
6214       do iii=1,2
6215         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6216         do jjj=1,2
6217           kkk=kkk+1
6218           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6219         enddo
6220       enddo
6221       do kkk=1,5
6222         do lll=1,3
6223           mmm=0
6224           do iii=1,2
6225             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6226      &        auxvec(1))
6227             do jjj=1,2
6228               mmm=mmm+1
6229               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6230             enddo
6231           enddo
6232         enddo
6233       enddo
6234       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6235       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6236       do iii=1,2
6237         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6238       enddo
6239       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6240       do iii=1,2
6241         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6242       enddo
6243       return
6244       end
6245 #endif
6246 C---------------------------------------------------------------------------
6247       subroutine calc_eello(i,j,k,l,jj,kk)
6248 C
6249 C This subroutine computes matrices and vectors needed to calculate
6250 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6251 C
6252       implicit real*8 (a-h,o-z)
6253       include 'DIMENSIONS'
6254       include 'COMMON.IOUNITS'
6255       include 'COMMON.CHAIN'
6256       include 'COMMON.DERIV'
6257       include 'COMMON.INTERACT'
6258       include 'COMMON.CONTACTS'
6259       include 'COMMON.TORSION'
6260       include 'COMMON.VAR'
6261       include 'COMMON.GEO'
6262       include 'COMMON.FFIELD'
6263       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6264      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6265       logical lprn
6266       common /kutas/ lprn
6267 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6268 cd     & ' jj=',jj,' kk=',kk
6269 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6270       do iii=1,2
6271         do jjj=1,2
6272           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6273           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6274         enddo
6275       enddo
6276       call transpose2(aa1(1,1),aa1t(1,1))
6277       call transpose2(aa2(1,1),aa2t(1,1))
6278       do kkk=1,5
6279         do lll=1,3
6280           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6281      &      aa1tder(1,1,lll,kkk))
6282           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6283      &      aa2tder(1,1,lll,kkk))
6284         enddo
6285       enddo
6286       if (l.eq.j+1) then
6287 C parallel orientation of the two CA-CA-CA frames.
6288         if (i.gt.1) then
6289           iti=itortyp(itype(i))
6290         else
6291           iti=ntortyp+1
6292         endif
6293         itk1=itortyp(itype(k+1))
6294         itj=itortyp(itype(j))
6295         if (l.lt.nres-1) then
6296           itl1=itortyp(itype(l+1))
6297         else
6298           itl1=ntortyp+1
6299         endif
6300 C A1 kernel(j+1) A2T
6301 cd        do iii=1,2
6302 cd          write (iout,'(3f10.5,5x,3f10.5)')
6303 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6304 cd        enddo
6305         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6306      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6307      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6308 C Following matrices are needed only for 6-th order cumulants
6309         IF (wcorr6.gt.0.0d0) THEN
6310         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6311      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6312      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6313         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6314      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6315      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6316      &   ADtEAderx(1,1,1,1,1,1))
6317         lprn=.false.
6318         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6319      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6320      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6321      &   ADtEA1derx(1,1,1,1,1,1))
6322         ENDIF
6323 C End 6-th order cumulants
6324 cd        lprn=.false.
6325 cd        if (lprn) then
6326 cd        write (2,*) 'In calc_eello6'
6327 cd        do iii=1,2
6328 cd          write (2,*) 'iii=',iii
6329 cd          do kkk=1,5
6330 cd            write (2,*) 'kkk=',kkk
6331 cd            do jjj=1,2
6332 cd              write (2,'(3(2f10.5),5x)')
6333 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6334 cd            enddo
6335 cd          enddo
6336 cd        enddo
6337 cd        endif
6338         call transpose2(EUgder(1,1,k),auxmat(1,1))
6339         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6340         call transpose2(EUg(1,1,k),auxmat(1,1))
6341         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6342         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6343         do iii=1,2
6344           do kkk=1,5
6345             do lll=1,3
6346               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6347      &          EAEAderx(1,1,lll,kkk,iii,1))
6348             enddo
6349           enddo
6350         enddo
6351 C A1T kernel(i+1) A2
6352         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6353      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6354      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6355 C Following matrices are needed only for 6-th order cumulants
6356         IF (wcorr6.gt.0.0d0) THEN
6357         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6358      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6359      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
6362      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6363      &   ADtEAderx(1,1,1,1,1,2))
6364         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6365      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6366      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6367      &   ADtEA1derx(1,1,1,1,1,2))
6368         ENDIF
6369 C End 6-th order cumulants
6370         call transpose2(EUgder(1,1,l),auxmat(1,1))
6371         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6372         call transpose2(EUg(1,1,l),auxmat(1,1))
6373         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6374         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6375         do iii=1,2
6376           do kkk=1,5
6377             do lll=1,3
6378               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6379      &          EAEAderx(1,1,lll,kkk,iii,2))
6380             enddo
6381           enddo
6382         enddo
6383 C AEAb1 and AEAb2
6384 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6385 C They are needed only when the fifth- or the sixth-order cumulants are
6386 C indluded.
6387         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6388         call transpose2(AEA(1,1,1),auxmat(1,1))
6389         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6390         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6391         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6392         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6393         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6394         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6395         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6396         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6397         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6398         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6399         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6400         call transpose2(AEA(1,1,2),auxmat(1,1))
6401         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6402         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6403         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6404         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6405         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6406         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6407         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6408         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6409         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6410         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6411         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6412 C Calculate the Cartesian derivatives of the vectors.
6413         do iii=1,2
6414           do kkk=1,5
6415             do lll=1,3
6416               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6417               call matvec2(auxmat(1,1),b1(1,iti),
6418      &          AEAb1derx(1,lll,kkk,iii,1,1))
6419               call matvec2(auxmat(1,1),Ub2(1,i),
6420      &          AEAb2derx(1,lll,kkk,iii,1,1))
6421               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6422      &          AEAb1derx(1,lll,kkk,iii,2,1))
6423               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6424      &          AEAb2derx(1,lll,kkk,iii,2,1))
6425               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6426               call matvec2(auxmat(1,1),b1(1,itj),
6427      &          AEAb1derx(1,lll,kkk,iii,1,2))
6428               call matvec2(auxmat(1,1),Ub2(1,j),
6429      &          AEAb2derx(1,lll,kkk,iii,1,2))
6430               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6431      &          AEAb1derx(1,lll,kkk,iii,2,2))
6432               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6433      &          AEAb2derx(1,lll,kkk,iii,2,2))
6434             enddo
6435           enddo
6436         enddo
6437         ENDIF
6438 C End vectors
6439       else
6440 C Antiparallel orientation of the two CA-CA-CA frames.
6441         if (i.gt.1) then
6442           iti=itortyp(itype(i))
6443         else
6444           iti=ntortyp+1
6445         endif
6446         itk1=itortyp(itype(k+1))
6447         itl=itortyp(itype(l))
6448         itj=itortyp(itype(j))
6449         if (j.lt.nres-1) then
6450           itj1=itortyp(itype(j+1))
6451         else
6452           itj1=ntortyp+1
6453         endif
6454 C A2 kernel(j-1)T A1T
6455         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6456      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6457      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6458 C Following matrices are needed only for 6-th order cumulants
6459         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6460      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6461         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6462      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6463      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6464         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6465      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6466      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6467      &   ADtEAderx(1,1,1,1,1,1))
6468         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6469      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6470      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6471      &   ADtEA1derx(1,1,1,1,1,1))
6472         ENDIF
6473 C End 6-th order cumulants
6474         call transpose2(EUgder(1,1,k),auxmat(1,1))
6475         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6476         call transpose2(EUg(1,1,k),auxmat(1,1))
6477         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6478         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6479         do iii=1,2
6480           do kkk=1,5
6481             do lll=1,3
6482               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6483      &          EAEAderx(1,1,lll,kkk,iii,1))
6484             enddo
6485           enddo
6486         enddo
6487 C A2T kernel(i+1)T A1
6488         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6489      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6490      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6491 C Following matrices are needed only for 6-th order cumulants
6492         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6493      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6494         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6495      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6496      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
6499      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6500      &   ADtEAderx(1,1,1,1,1,2))
6501         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6502      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6503      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6504      &   ADtEA1derx(1,1,1,1,1,2))
6505         ENDIF
6506 C End 6-th order cumulants
6507         call transpose2(EUgder(1,1,j),auxmat(1,1))
6508         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6509         call transpose2(EUg(1,1,j),auxmat(1,1))
6510         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6511         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6512         do iii=1,2
6513           do kkk=1,5
6514             do lll=1,3
6515               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6516      &          EAEAderx(1,1,lll,kkk,iii,2))
6517             enddo
6518           enddo
6519         enddo
6520 C AEAb1 and AEAb2
6521 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6522 C They are needed only when the fifth- or the sixth-order cumulants are
6523 C indluded.
6524         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6525      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6526         call transpose2(AEA(1,1,1),auxmat(1,1))
6527         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6528         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6529         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6530         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6531         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6532         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6533         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6534         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6535         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6536         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6537         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6538         call transpose2(AEA(1,1,2),auxmat(1,1))
6539         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6540         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6541         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6542         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6543         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6544         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6545         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6546         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6547         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6548         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6549         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6550 C Calculate the Cartesian derivatives of the vectors.
6551         do iii=1,2
6552           do kkk=1,5
6553             do lll=1,3
6554               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6555               call matvec2(auxmat(1,1),b1(1,iti),
6556      &          AEAb1derx(1,lll,kkk,iii,1,1))
6557               call matvec2(auxmat(1,1),Ub2(1,i),
6558      &          AEAb2derx(1,lll,kkk,iii,1,1))
6559               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6560      &          AEAb1derx(1,lll,kkk,iii,2,1))
6561               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6562      &          AEAb2derx(1,lll,kkk,iii,2,1))
6563               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6564               call matvec2(auxmat(1,1),b1(1,itl),
6565      &          AEAb1derx(1,lll,kkk,iii,1,2))
6566               call matvec2(auxmat(1,1),Ub2(1,l),
6567      &          AEAb2derx(1,lll,kkk,iii,1,2))
6568               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6569      &          AEAb1derx(1,lll,kkk,iii,2,2))
6570               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6571      &          AEAb2derx(1,lll,kkk,iii,2,2))
6572             enddo
6573           enddo
6574         enddo
6575         ENDIF
6576 C End vectors
6577       endif
6578       return
6579       end
6580 C---------------------------------------------------------------------------
6581       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6582      &  KK,KKderg,AKA,AKAderg,AKAderx)
6583       implicit none
6584       integer nderg
6585       logical transp
6586       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6587      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6588      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6589       integer iii,kkk,lll
6590       integer jjj,mmm
6591       logical lprn
6592       common /kutas/ lprn
6593       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6594       do iii=1,nderg
6595         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6596      &    AKAderg(1,1,iii))
6597       enddo
6598 cd      if (lprn) write (2,*) 'In kernel'
6599       do kkk=1,5
6600 cd        if (lprn) write (2,*) 'kkk=',kkk
6601         do lll=1,3
6602           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6603      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6604 cd          if (lprn) then
6605 cd            write (2,*) 'lll=',lll
6606 cd            write (2,*) 'iii=1'
6607 cd            do jjj=1,2
6608 cd              write (2,'(3(2f10.5),5x)')
6609 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6610 cd            enddo
6611 cd          endif
6612           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6613      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6614 cd          if (lprn) then
6615 cd            write (2,*) 'lll=',lll
6616 cd            write (2,*) 'iii=2'
6617 cd            do jjj=1,2
6618 cd              write (2,'(3(2f10.5),5x)')
6619 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6620 cd            enddo
6621 cd          endif
6622         enddo
6623       enddo
6624       return
6625       end
6626 C---------------------------------------------------------------------------
6627       double precision function eello4(i,j,k,l,jj,kk)
6628       implicit real*8 (a-h,o-z)
6629       include 'DIMENSIONS'
6630       include 'COMMON.IOUNITS'
6631       include 'COMMON.CHAIN'
6632       include 'COMMON.DERIV'
6633       include 'COMMON.INTERACT'
6634       include 'COMMON.CONTACTS'
6635       include 'COMMON.TORSION'
6636       include 'COMMON.VAR'
6637       include 'COMMON.GEO'
6638       double precision pizda(2,2),ggg1(3),ggg2(3)
6639 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6640 cd        eello4=0.0d0
6641 cd        return
6642 cd      endif
6643 cd      print *,'eello4:',i,j,k,l,jj,kk
6644 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6645 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6646 cold      eij=facont_hb(jj,i)
6647 cold      ekl=facont_hb(kk,k)
6648 cold      ekont=eij*ekl
6649       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6650 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6651       gcorr_loc(k-1)=gcorr_loc(k-1)
6652      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6653       if (l.eq.j+1) then
6654         gcorr_loc(l-1)=gcorr_loc(l-1)
6655      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6656       else
6657         gcorr_loc(j-1)=gcorr_loc(j-1)
6658      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6659       endif
6660       do iii=1,2
6661         do kkk=1,5
6662           do lll=1,3
6663             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6664      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6665 cd            derx(lll,kkk,iii)=0.0d0
6666           enddo
6667         enddo
6668       enddo
6669 cd      gcorr_loc(l-1)=0.0d0
6670 cd      gcorr_loc(j-1)=0.0d0
6671 cd      gcorr_loc(k-1)=0.0d0
6672 cd      eel4=1.0d0
6673 cd      write (iout,*)'Contacts have occurred for peptide groups',
6674 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6675 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6676       if (j.lt.nres-1) then
6677         j1=j+1
6678         j2=j-1
6679       else
6680         j1=j-1
6681         j2=j-2
6682       endif
6683       if (l.lt.nres-1) then
6684         l1=l+1
6685         l2=l-1
6686       else
6687         l1=l-1
6688         l2=l-2
6689       endif
6690       do ll=1,3
6691 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6692         ggg1(ll)=eel4*g_contij(ll,1)
6693         ggg2(ll)=eel4*g_contij(ll,2)
6694         ghalf=0.5d0*ggg1(ll)
6695 cd        ghalf=0.0d0
6696         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6697         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6698         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6699         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6700 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6701         ghalf=0.5d0*ggg2(ll)
6702 cd        ghalf=0.0d0
6703         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6704         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6705         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6706         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6707       enddo
6708 cd      goto 1112
6709       do m=i+1,j-1
6710         do ll=1,3
6711 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6712           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6713         enddo
6714       enddo
6715       do m=k+1,l-1
6716         do ll=1,3
6717 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6718           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6719         enddo
6720       enddo
6721 1112  continue
6722       do m=i+2,j2
6723         do ll=1,3
6724           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6725         enddo
6726       enddo
6727       do m=k+2,l2
6728         do ll=1,3
6729           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6730         enddo
6731       enddo
6732 cd      do iii=1,nres-3
6733 cd        write (2,*) iii,gcorr_loc(iii)
6734 cd      enddo
6735       eello4=ekont*eel4
6736 cd      write (2,*) 'ekont',ekont
6737 cd      write (iout,*) 'eello4',ekont*eel4
6738       return
6739       end
6740 C---------------------------------------------------------------------------
6741       double precision function eello5(i,j,k,l,jj,kk)
6742       implicit real*8 (a-h,o-z)
6743       include 'DIMENSIONS'
6744       include 'COMMON.IOUNITS'
6745       include 'COMMON.CHAIN'
6746       include 'COMMON.DERIV'
6747       include 'COMMON.INTERACT'
6748       include 'COMMON.CONTACTS'
6749       include 'COMMON.TORSION'
6750       include 'COMMON.VAR'
6751       include 'COMMON.GEO'
6752       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6753       double precision ggg1(3),ggg2(3)
6754 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6755 C                                                                              C
6756 C                            Parallel chains                                   C
6757 C                                                                              C
6758 C          o             o                   o             o                   C
6759 C         /l\           / \             \   / \           / \   /              C
6760 C        /   \         /   \             \ /   \         /   \ /               C
6761 C       j| o |l1       | o |              o| o |         | o |o                C
6762 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6763 C      \i/   \         /   \ /             /   \         /   \                 C
6764 C       o    k1             o                                                  C
6765 C         (I)          (II)                (III)          (IV)                 C
6766 C                                                                              C
6767 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6768 C                                                                              C
6769 C                            Antiparallel chains                               C
6770 C                                                                              C
6771 C          o             o                   o             o                   C
6772 C         /j\           / \             \   / \           / \   /              C
6773 C        /   \         /   \             \ /   \         /   \ /               C
6774 C      j1| o |l        | o |              o| o |         | o |o                C
6775 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6776 C      \i/   \         /   \ /             /   \         /   \                 C
6777 C       o     k1            o                                                  C
6778 C         (I)          (II)                (III)          (IV)                 C
6779 C                                                                              C
6780 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6781 C                                                                              C
6782 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6783 C                                                                              C
6784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6785 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6786 cd        eello5=0.0d0
6787 cd        return
6788 cd      endif
6789 cd      write (iout,*)
6790 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6791 cd     &   ' and',k,l
6792       itk=itortyp(itype(k))
6793       itl=itortyp(itype(l))
6794       itj=itortyp(itype(j))
6795       eello5_1=0.0d0
6796       eello5_2=0.0d0
6797       eello5_3=0.0d0
6798       eello5_4=0.0d0
6799 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6800 cd     &   eel5_3_num,eel5_4_num)
6801       do iii=1,2
6802         do kkk=1,5
6803           do lll=1,3
6804             derx(lll,kkk,iii)=0.0d0
6805           enddo
6806         enddo
6807       enddo
6808 cd      eij=facont_hb(jj,i)
6809 cd      ekl=facont_hb(kk,k)
6810 cd      ekont=eij*ekl
6811 cd      write (iout,*)'Contacts have occurred for peptide groups',
6812 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6813 cd      goto 1111
6814 C Contribution from the graph I.
6815 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6816 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6817       call transpose2(EUg(1,1,k),auxmat(1,1))
6818       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6819       vv(1)=pizda(1,1)-pizda(2,2)
6820       vv(2)=pizda(1,2)+pizda(2,1)
6821       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6822      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6823 C Explicit gradient in virtual-dihedral angles.
6824       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6825      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6826      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6827       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6828       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6829       vv(1)=pizda(1,1)-pizda(2,2)
6830       vv(2)=pizda(1,2)+pizda(2,1)
6831       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6832      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6833      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6834       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6835       vv(1)=pizda(1,1)-pizda(2,2)
6836       vv(2)=pizda(1,2)+pizda(2,1)
6837       if (l.eq.j+1) then
6838         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6839      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6840      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6841       else
6842         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6843      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6844      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6845       endif
6846 C Cartesian gradient
6847       do iii=1,2
6848         do kkk=1,5
6849           do lll=1,3
6850             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6851      &        pizda(1,1))
6852             vv(1)=pizda(1,1)-pizda(2,2)
6853             vv(2)=pizda(1,2)+pizda(2,1)
6854             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6855      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6856      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6857           enddo
6858         enddo
6859       enddo
6860 c      goto 1112
6861 c1111  continue
6862 C Contribution from graph II
6863       call transpose2(EE(1,1,itk),auxmat(1,1))
6864       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6865       vv(1)=pizda(1,1)+pizda(2,2)
6866       vv(2)=pizda(2,1)-pizda(1,2)
6867       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6868      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6869 C Explicit gradient in virtual-dihedral angles.
6870       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6871      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6872       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6873       vv(1)=pizda(1,1)+pizda(2,2)
6874       vv(2)=pizda(2,1)-pizda(1,2)
6875       if (l.eq.j+1) then
6876         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6877      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6878      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6879       else
6880         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6881      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6882      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6883       endif
6884 C Cartesian gradient
6885       do iii=1,2
6886         do kkk=1,5
6887           do lll=1,3
6888             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6889      &        pizda(1,1))
6890             vv(1)=pizda(1,1)+pizda(2,2)
6891             vv(2)=pizda(2,1)-pizda(1,2)
6892             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6893      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6894      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6895           enddo
6896         enddo
6897       enddo
6898 cd      goto 1112
6899 cd1111  continue
6900       if (l.eq.j+1) then
6901 cd        goto 1110
6902 C Parallel orientation
6903 C Contribution from graph III
6904         call transpose2(EUg(1,1,l),auxmat(1,1))
6905         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6906         vv(1)=pizda(1,1)-pizda(2,2)
6907         vv(2)=pizda(1,2)+pizda(2,1)
6908         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6909      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6910 C Explicit gradient in virtual-dihedral angles.
6911         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6912      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6913      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6914         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6915         vv(1)=pizda(1,1)-pizda(2,2)
6916         vv(2)=pizda(1,2)+pizda(2,1)
6917         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6918      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6919      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6920         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6921         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6922         vv(1)=pizda(1,1)-pizda(2,2)
6923         vv(2)=pizda(1,2)+pizda(2,1)
6924         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6925      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6926      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6927 C Cartesian gradient
6928         do iii=1,2
6929           do kkk=1,5
6930             do lll=1,3
6931               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6932      &          pizda(1,1))
6933               vv(1)=pizda(1,1)-pizda(2,2)
6934               vv(2)=pizda(1,2)+pizda(2,1)
6935               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6936      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6937      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6938             enddo
6939           enddo
6940         enddo
6941 cd        goto 1112
6942 C Contribution from graph IV
6943 cd1110    continue
6944         call transpose2(EE(1,1,itl),auxmat(1,1))
6945         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6946         vv(1)=pizda(1,1)+pizda(2,2)
6947         vv(2)=pizda(2,1)-pizda(1,2)
6948         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6949      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6950 C Explicit gradient in virtual-dihedral angles.
6951         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6952      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6953         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6954         vv(1)=pizda(1,1)+pizda(2,2)
6955         vv(2)=pizda(2,1)-pizda(1,2)
6956         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6957      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6958      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6959 C Cartesian gradient
6960         do iii=1,2
6961           do kkk=1,5
6962             do lll=1,3
6963               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6964      &          pizda(1,1))
6965               vv(1)=pizda(1,1)+pizda(2,2)
6966               vv(2)=pizda(2,1)-pizda(1,2)
6967               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6968      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6969      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6970             enddo
6971           enddo
6972         enddo
6973       else
6974 C Antiparallel orientation
6975 C Contribution from graph III
6976 c        goto 1110
6977         call transpose2(EUg(1,1,j),auxmat(1,1))
6978         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6979         vv(1)=pizda(1,1)-pizda(2,2)
6980         vv(2)=pizda(1,2)+pizda(2,1)
6981         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6982      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6983 C Explicit gradient in virtual-dihedral angles.
6984         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6985      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6986      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6987         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6988         vv(1)=pizda(1,1)-pizda(2,2)
6989         vv(2)=pizda(1,2)+pizda(2,1)
6990         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6991      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6992      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6993         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6994         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6995         vv(1)=pizda(1,1)-pizda(2,2)
6996         vv(2)=pizda(1,2)+pizda(2,1)
6997         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6998      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6999      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7000 C Cartesian gradient
7001         do iii=1,2
7002           do kkk=1,5
7003             do lll=1,3
7004               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7005      &          pizda(1,1))
7006               vv(1)=pizda(1,1)-pizda(2,2)
7007               vv(2)=pizda(1,2)+pizda(2,1)
7008               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7009      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7010      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7011             enddo
7012           enddo
7013         enddo
7014 cd        goto 1112
7015 C Contribution from graph IV
7016 1110    continue
7017         call transpose2(EE(1,1,itj),auxmat(1,1))
7018         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7019         vv(1)=pizda(1,1)+pizda(2,2)
7020         vv(2)=pizda(2,1)-pizda(1,2)
7021         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7022      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7023 C Explicit gradient in virtual-dihedral angles.
7024         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7025      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7026         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7027         vv(1)=pizda(1,1)+pizda(2,2)
7028         vv(2)=pizda(2,1)-pizda(1,2)
7029         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7030      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7031      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7032 C Cartesian gradient
7033         do iii=1,2
7034           do kkk=1,5
7035             do lll=1,3
7036               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7037      &          pizda(1,1))
7038               vv(1)=pizda(1,1)+pizda(2,2)
7039               vv(2)=pizda(2,1)-pizda(1,2)
7040               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7041      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7042      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7043             enddo
7044           enddo
7045         enddo
7046       endif
7047 1112  continue
7048       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7049 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7050 cd        write (2,*) 'ijkl',i,j,k,l
7051 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7052 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7053 cd      endif
7054 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7055 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7056 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7057 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7058       if (j.lt.nres-1) then
7059         j1=j+1
7060         j2=j-1
7061       else
7062         j1=j-1
7063         j2=j-2
7064       endif
7065       if (l.lt.nres-1) then
7066         l1=l+1
7067         l2=l-1
7068       else
7069         l1=l-1
7070         l2=l-2
7071       endif
7072 cd      eij=1.0d0
7073 cd      ekl=1.0d0
7074 cd      ekont=1.0d0
7075 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7076       do ll=1,3
7077         ggg1(ll)=eel5*g_contij(ll,1)
7078         ggg2(ll)=eel5*g_contij(ll,2)
7079 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7080         ghalf=0.5d0*ggg1(ll)
7081 cd        ghalf=0.0d0
7082         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7083         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7084         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7085         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7086 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7087         ghalf=0.5d0*ggg2(ll)
7088 cd        ghalf=0.0d0
7089         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7090         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7091         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7092         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7093       enddo
7094 cd      goto 1112
7095       do m=i+1,j-1
7096         do ll=1,3
7097 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7098           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7099         enddo
7100       enddo
7101       do m=k+1,l-1
7102         do ll=1,3
7103 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7104           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7105         enddo
7106       enddo
7107 c1112  continue
7108       do m=i+2,j2
7109         do ll=1,3
7110           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7111         enddo
7112       enddo
7113       do m=k+2,l2
7114         do ll=1,3
7115           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7116         enddo
7117       enddo
7118 cd      do iii=1,nres-3
7119 cd        write (2,*) iii,g_corr5_loc(iii)
7120 cd      enddo
7121       eello5=ekont*eel5
7122 cd      write (2,*) 'ekont',ekont
7123 cd      write (iout,*) 'eello5',ekont*eel5
7124       return
7125       end
7126 c--------------------------------------------------------------------------
7127       double precision function eello6(i,j,k,l,jj,kk)
7128       implicit real*8 (a-h,o-z)
7129       include 'DIMENSIONS'
7130       include 'COMMON.IOUNITS'
7131       include 'COMMON.CHAIN'
7132       include 'COMMON.DERIV'
7133       include 'COMMON.INTERACT'
7134       include 'COMMON.CONTACTS'
7135       include 'COMMON.TORSION'
7136       include 'COMMON.VAR'
7137       include 'COMMON.GEO'
7138       include 'COMMON.FFIELD'
7139       double precision ggg1(3),ggg2(3)
7140 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7141 cd        eello6=0.0d0
7142 cd        return
7143 cd      endif
7144 cd      write (iout,*)
7145 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7146 cd     &   ' and',k,l
7147       eello6_1=0.0d0
7148       eello6_2=0.0d0
7149       eello6_3=0.0d0
7150       eello6_4=0.0d0
7151       eello6_5=0.0d0
7152       eello6_6=0.0d0
7153 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7154 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7155       do iii=1,2
7156         do kkk=1,5
7157           do lll=1,3
7158             derx(lll,kkk,iii)=0.0d0
7159           enddo
7160         enddo
7161       enddo
7162 cd      eij=facont_hb(jj,i)
7163 cd      ekl=facont_hb(kk,k)
7164 cd      ekont=eij*ekl
7165 cd      eij=1.0d0
7166 cd      ekl=1.0d0
7167 cd      ekont=1.0d0
7168       if (l.eq.j+1) then
7169         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7170         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7171         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7172         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7173         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7174         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7175       else
7176         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7177         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7178         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7179         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7180         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7181           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7182         else
7183           eello6_5=0.0d0
7184         endif
7185         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7186       endif
7187 C If turn contributions are considered, they will be handled separately.
7188       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7189 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7190 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7191 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7192 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7193 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7194 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7195 cd      goto 1112
7196       if (j.lt.nres-1) then
7197         j1=j+1
7198         j2=j-1
7199       else
7200         j1=j-1
7201         j2=j-2
7202       endif
7203       if (l.lt.nres-1) then
7204         l1=l+1
7205         l2=l-1
7206       else
7207         l1=l-1
7208         l2=l-2
7209       endif
7210       do ll=1,3
7211         ggg1(ll)=eel6*g_contij(ll,1)
7212         ggg2(ll)=eel6*g_contij(ll,2)
7213 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7214         ghalf=0.5d0*ggg1(ll)
7215 cd        ghalf=0.0d0
7216         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7217         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7218         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7219         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7220         ghalf=0.5d0*ggg2(ll)
7221 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7222 cd        ghalf=0.0d0
7223         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7224         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7225         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7226         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7227       enddo
7228 cd      goto 1112
7229       do m=i+1,j-1
7230         do ll=1,3
7231 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7232           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7233         enddo
7234       enddo
7235       do m=k+1,l-1
7236         do ll=1,3
7237 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7238           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7239         enddo
7240       enddo
7241 1112  continue
7242       do m=i+2,j2
7243         do ll=1,3
7244           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7245         enddo
7246       enddo
7247       do m=k+2,l2
7248         do ll=1,3
7249           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7250         enddo
7251       enddo
7252 cd      do iii=1,nres-3
7253 cd        write (2,*) iii,g_corr6_loc(iii)
7254 cd      enddo
7255       eello6=ekont*eel6
7256 cd      write (2,*) 'ekont',ekont
7257 cd      write (iout,*) 'eello6',ekont*eel6
7258       return
7259       end
7260 c--------------------------------------------------------------------------
7261       double precision function eello6_graph1(i,j,k,l,imat,swap)
7262       implicit real*8 (a-h,o-z)
7263       include 'DIMENSIONS'
7264       include 'COMMON.IOUNITS'
7265       include 'COMMON.CHAIN'
7266       include 'COMMON.DERIV'
7267       include 'COMMON.INTERACT'
7268       include 'COMMON.CONTACTS'
7269       include 'COMMON.TORSION'
7270       include 'COMMON.VAR'
7271       include 'COMMON.GEO'
7272       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7273       logical swap
7274       logical lprn
7275       common /kutas/ lprn
7276 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7277 C
7278 C      Parallel       Antiparallel
7279 C
7280 C          o             o
7281 C         /l\           /j\
7282 C        /   \         /   \
7283 C       /| o |         | o |\
7284 C     \ j|/k\|  /   \  |/k\|l /
7285 C      \ /   \ /     \ /   \ /
7286 C       o     o       o     o
7287 C       i             i
7288 C
7289 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7290       itk=itortyp(itype(k))
7291       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7292       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7293       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7294       call transpose2(EUgC(1,1,k),auxmat(1,1))
7295       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7296       vv1(1)=pizda1(1,1)-pizda1(2,2)
7297       vv1(2)=pizda1(1,2)+pizda1(2,1)
7298       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7299       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7300       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7301       s5=scalar2(vv(1),Dtobr2(1,i))
7302 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7303       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7304       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7305      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7306      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7307      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7308      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7309      & +scalar2(vv(1),Dtobr2der(1,i)))
7310       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7311       vv1(1)=pizda1(1,1)-pizda1(2,2)
7312       vv1(2)=pizda1(1,2)+pizda1(2,1)
7313       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7314       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7315       if (l.eq.j+1) then
7316         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7317      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7318      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7319      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7320      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7321       else
7322         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7323      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7324      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7325      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7326      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7327       endif
7328       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7329       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7330       vv1(1)=pizda1(1,1)-pizda1(2,2)
7331       vv1(2)=pizda1(1,2)+pizda1(2,1)
7332       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7333      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7334      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7335      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7336       do iii=1,2
7337         if (swap) then
7338           ind=3-iii
7339         else
7340           ind=iii
7341         endif
7342         do kkk=1,5
7343           do lll=1,3
7344             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7345             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7346             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7347             call transpose2(EUgC(1,1,k),auxmat(1,1))
7348             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7349      &        pizda1(1,1))
7350             vv1(1)=pizda1(1,1)-pizda1(2,2)
7351             vv1(2)=pizda1(1,2)+pizda1(2,1)
7352             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7353             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7354      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7355             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7356      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7357             s5=scalar2(vv(1),Dtobr2(1,i))
7358             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7359           enddo
7360         enddo
7361       enddo
7362       return
7363       end
7364 c----------------------------------------------------------------------------
7365       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7366       implicit real*8 (a-h,o-z)
7367       include 'DIMENSIONS'
7368       include 'COMMON.IOUNITS'
7369       include 'COMMON.CHAIN'
7370       include 'COMMON.DERIV'
7371       include 'COMMON.INTERACT'
7372       include 'COMMON.CONTACTS'
7373       include 'COMMON.TORSION'
7374       include 'COMMON.VAR'
7375       include 'COMMON.GEO'
7376       logical swap
7377       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7378      & auxvec1(2),auxvec2(1),auxmat1(2,2)
7379       logical lprn
7380       common /kutas/ lprn
7381 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7382 C
7383 C      Parallel       Antiparallel
7384 C
7385 C          o             o
7386 C     \   /l\           /j\   /
7387 C      \ /   \         /   \ /
7388 C       o| o |         | o |o
7389 C     \ j|/k\|      \  |/k\|l
7390 C      \ /   \       \ /   \
7391 C       o             o
7392 C       i             i
7393 C
7394 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7395 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7396 C AL 7/4/01 s1 would occur in the sixth-order moment,
7397 C           but not in a cluster cumulant
7398 #ifdef MOMENT
7399       s1=dip(1,jj,i)*dip(1,kk,k)
7400 #endif
7401       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7402       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7403       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7404       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7405       call transpose2(EUg(1,1,k),auxmat(1,1))
7406       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7407       vv(1)=pizda(1,1)-pizda(2,2)
7408       vv(2)=pizda(1,2)+pizda(2,1)
7409       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7410 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7411 #ifdef MOMENT
7412       eello6_graph2=-(s1+s2+s3+s4)
7413 #else
7414       eello6_graph2=-(s2+s3+s4)
7415 #endif
7416 c      eello6_graph2=-s3
7417 C Derivatives in gamma(i-1)
7418       if (i.gt.1) then
7419 #ifdef MOMENT
7420         s1=dipderg(1,jj,i)*dip(1,kk,k)
7421 #endif
7422         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7423         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7424         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7425         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7426 #ifdef MOMENT
7427         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7428 #else
7429         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7430 #endif
7431 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7432       endif
7433 C Derivatives in gamma(k-1)
7434 #ifdef MOMENT
7435       s1=dip(1,jj,i)*dipderg(1,kk,k)
7436 #endif
7437       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7438       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7439       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7440       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7441       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7442       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7443       vv(1)=pizda(1,1)-pizda(2,2)
7444       vv(2)=pizda(1,2)+pizda(2,1)
7445       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7446 #ifdef MOMENT
7447       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7448 #else
7449       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7450 #endif
7451 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7452 C Derivatives in gamma(j-1) or gamma(l-1)
7453       if (j.gt.1) then
7454 #ifdef MOMENT
7455         s1=dipderg(3,jj,i)*dip(1,kk,k)
7456 #endif
7457         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7458         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7459         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7460         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7461         vv(1)=pizda(1,1)-pizda(2,2)
7462         vv(2)=pizda(1,2)+pizda(2,1)
7463         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7464 #ifdef MOMENT
7465         if (swap) then
7466           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7467         else
7468           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7469         endif
7470 #endif
7471         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7472 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7473       endif
7474 C Derivatives in gamma(l-1) or gamma(j-1)
7475       if (l.gt.1) then
7476 #ifdef MOMENT
7477         s1=dip(1,jj,i)*dipderg(3,kk,k)
7478 #endif
7479         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7480         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7481         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7482         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7483         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7484         vv(1)=pizda(1,1)-pizda(2,2)
7485         vv(2)=pizda(1,2)+pizda(2,1)
7486         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7487 #ifdef MOMENT
7488         if (swap) then
7489           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7490         else
7491           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7492         endif
7493 #endif
7494         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7495 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7496       endif
7497 C Cartesian derivatives.
7498       if (lprn) then
7499         write (2,*) 'In eello6_graph2'
7500         do iii=1,2
7501           write (2,*) 'iii=',iii
7502           do kkk=1,5
7503             write (2,*) 'kkk=',kkk
7504             do jjj=1,2
7505               write (2,'(3(2f10.5),5x)')
7506      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7507             enddo
7508           enddo
7509         enddo
7510       endif
7511       do iii=1,2
7512         do kkk=1,5
7513           do lll=1,3
7514 #ifdef MOMENT
7515             if (iii.eq.1) then
7516               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7517             else
7518               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7519             endif
7520 #endif
7521             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7522      &        auxvec(1))
7523             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7524             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7525      &        auxvec(1))
7526             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7527             call transpose2(EUg(1,1,k),auxmat(1,1))
7528             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7529      &        pizda(1,1))
7530             vv(1)=pizda(1,1)-pizda(2,2)
7531             vv(2)=pizda(1,2)+pizda(2,1)
7532             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7533 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7534 #ifdef MOMENT
7535             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7536 #else
7537             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7538 #endif
7539             if (swap) then
7540               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7541             else
7542               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7543             endif
7544           enddo
7545         enddo
7546       enddo
7547       return
7548       end
7549 c----------------------------------------------------------------------------
7550       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7551       implicit real*8 (a-h,o-z)
7552       include 'DIMENSIONS'
7553       include 'COMMON.IOUNITS'
7554       include 'COMMON.CHAIN'
7555       include 'COMMON.DERIV'
7556       include 'COMMON.INTERACT'
7557       include 'COMMON.CONTACTS'
7558       include 'COMMON.TORSION'
7559       include 'COMMON.VAR'
7560       include 'COMMON.GEO'
7561       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7562       logical swap
7563 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7564 C
7565 C      Parallel       Antiparallel
7566 C
7567 C          o             o
7568 C         /l\   /   \   /j\
7569 C        /   \ /     \ /   \
7570 C       /| o |o       o| o |\
7571 C       j|/k\|  /      |/k\|l /
7572 C        /   \ /       /   \ /
7573 C       /     o       /     o
7574 C       i             i
7575 C
7576 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7577 C
7578 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7579 C           energy moment and not to the cluster cumulant.
7580       iti=itortyp(itype(i))
7581       if (j.lt.nres-1) then
7582         itj1=itortyp(itype(j+1))
7583       else
7584         itj1=ntortyp+1
7585       endif
7586       itk=itortyp(itype(k))
7587       itk1=itortyp(itype(k+1))
7588       if (l.lt.nres-1) then
7589         itl1=itortyp(itype(l+1))
7590       else
7591         itl1=ntortyp+1
7592       endif
7593 #ifdef MOMENT
7594       s1=dip(4,jj,i)*dip(4,kk,k)
7595 #endif
7596       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7597       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7598       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7599       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7600       call transpose2(EE(1,1,itk),auxmat(1,1))
7601       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7602       vv(1)=pizda(1,1)+pizda(2,2)
7603       vv(2)=pizda(2,1)-pizda(1,2)
7604       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7605 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7606 #ifdef MOMENT
7607       eello6_graph3=-(s1+s2+s3+s4)
7608 #else
7609       eello6_graph3=-(s2+s3+s4)
7610 #endif
7611 c      eello6_graph3=-s4
7612 C Derivatives in gamma(k-1)
7613       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7614       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7615       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7616       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7617 C Derivatives in gamma(l-1)
7618       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7619       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7620       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7621       vv(1)=pizda(1,1)+pizda(2,2)
7622       vv(2)=pizda(2,1)-pizda(1,2)
7623       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7624       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7625 C Cartesian derivatives.
7626       do iii=1,2
7627         do kkk=1,5
7628           do lll=1,3
7629 #ifdef MOMENT
7630             if (iii.eq.1) then
7631               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7632             else
7633               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7634             endif
7635 #endif
7636             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7637      &        auxvec(1))
7638             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7639             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7640      &        auxvec(1))
7641             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7642             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7643      &        pizda(1,1))
7644             vv(1)=pizda(1,1)+pizda(2,2)
7645             vv(2)=pizda(2,1)-pizda(1,2)
7646             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7647 #ifdef MOMENT
7648             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7649 #else
7650             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7651 #endif
7652             if (swap) then
7653               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7654             else
7655               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7656             endif
7657 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7658           enddo
7659         enddo
7660       enddo
7661       return
7662       end
7663 c----------------------------------------------------------------------------
7664       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7665       implicit real*8 (a-h,o-z)
7666       include 'DIMENSIONS'
7667       include 'COMMON.IOUNITS'
7668       include 'COMMON.CHAIN'
7669       include 'COMMON.DERIV'
7670       include 'COMMON.INTERACT'
7671       include 'COMMON.CONTACTS'
7672       include 'COMMON.TORSION'
7673       include 'COMMON.VAR'
7674       include 'COMMON.GEO'
7675       include 'COMMON.FFIELD'
7676       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7677      & auxvec1(2),auxmat1(2,2)
7678       logical swap
7679 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7680 C
7681 C      Parallel       Antiparallel
7682 C
7683 C          o             o
7684 C         /l\   /   \   /j\
7685 C        /   \ /     \ /   \
7686 C       /| o |o       o| o |\
7687 C     \ j|/k\|      \  |/k\|l
7688 C      \ /   \       \ /   \
7689 C       o     \       o     \
7690 C       i             i
7691 C
7692 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7693 C
7694 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7695 C           energy moment and not to the cluster cumulant.
7696 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7697       iti=itortyp(itype(i))
7698       itj=itortyp(itype(j))
7699       if (j.lt.nres-1) then
7700         itj1=itortyp(itype(j+1))
7701       else
7702         itj1=ntortyp+1
7703       endif
7704       itk=itortyp(itype(k))
7705       if (k.lt.nres-1) then
7706         itk1=itortyp(itype(k+1))
7707       else
7708         itk1=ntortyp+1
7709       endif
7710       itl=itortyp(itype(l))
7711       if (l.lt.nres-1) then
7712         itl1=itortyp(itype(l+1))
7713       else
7714         itl1=ntortyp+1
7715       endif
7716 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7717 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7718 cd     & ' itl',itl,' itl1',itl1
7719 #ifdef MOMENT
7720       if (imat.eq.1) then
7721         s1=dip(3,jj,i)*dip(3,kk,k)
7722       else
7723         s1=dip(2,jj,j)*dip(2,kk,l)
7724       endif
7725 #endif
7726       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7727       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7728       if (j.eq.l+1) then
7729         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7730         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7731       else
7732         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7733         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7734       endif
7735       call transpose2(EUg(1,1,k),auxmat(1,1))
7736       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7737       vv(1)=pizda(1,1)-pizda(2,2)
7738       vv(2)=pizda(2,1)+pizda(1,2)
7739       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7740 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7741 #ifdef MOMENT
7742       eello6_graph4=-(s1+s2+s3+s4)
7743 #else
7744       eello6_graph4=-(s2+s3+s4)
7745 #endif
7746 C Derivatives in gamma(i-1)
7747       if (i.gt.1) then
7748 #ifdef MOMENT
7749         if (imat.eq.1) then
7750           s1=dipderg(2,jj,i)*dip(3,kk,k)
7751         else
7752           s1=dipderg(4,jj,j)*dip(2,kk,l)
7753         endif
7754 #endif
7755         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7756         if (j.eq.l+1) then
7757           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7758           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7759         else
7760           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7761           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7762         endif
7763         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7764         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7765 cd          write (2,*) 'turn6 derivatives'
7766 #ifdef MOMENT
7767           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7768 #else
7769           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7770 #endif
7771         else
7772 #ifdef MOMENT
7773           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7774 #else
7775           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7776 #endif
7777         endif
7778       endif
7779 C Derivatives in gamma(k-1)
7780 #ifdef MOMENT
7781       if (imat.eq.1) then
7782         s1=dip(3,jj,i)*dipderg(2,kk,k)
7783       else
7784         s1=dip(2,jj,j)*dipderg(4,kk,l)
7785       endif
7786 #endif
7787       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7788       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7789       if (j.eq.l+1) then
7790         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7791         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7792       else
7793         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7794         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7795       endif
7796       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7797       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7798       vv(1)=pizda(1,1)-pizda(2,2)
7799       vv(2)=pizda(2,1)+pizda(1,2)
7800       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7801       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7802 #ifdef MOMENT
7803         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7804 #else
7805         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7806 #endif
7807       else
7808 #ifdef MOMENT
7809         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7810 #else
7811         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7812 #endif
7813       endif
7814 C Derivatives in gamma(j-1) or gamma(l-1)
7815       if (l.eq.j+1 .and. l.gt.1) then
7816         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7817         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7818         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7819         vv(1)=pizda(1,1)-pizda(2,2)
7820         vv(2)=pizda(2,1)+pizda(1,2)
7821         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7822         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7823       else if (j.gt.1) then
7824         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7825         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7826         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7827         vv(1)=pizda(1,1)-pizda(2,2)
7828         vv(2)=pizda(2,1)+pizda(1,2)
7829         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7830         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7831           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7832         else
7833           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7834         endif
7835       endif
7836 C Cartesian derivatives.
7837       do iii=1,2
7838         do kkk=1,5
7839           do lll=1,3
7840 #ifdef MOMENT
7841             if (iii.eq.1) then
7842               if (imat.eq.1) then
7843                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7844               else
7845                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7846               endif
7847             else
7848               if (imat.eq.1) then
7849                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7850               else
7851                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7852               endif
7853             endif
7854 #endif
7855             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7856      &        auxvec(1))
7857             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7858             if (j.eq.l+1) then
7859               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7860      &          b1(1,itj1),auxvec(1))
7861               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7862             else
7863               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7864      &          b1(1,itl1),auxvec(1))
7865               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7866             endif
7867             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7868      &        pizda(1,1))
7869             vv(1)=pizda(1,1)-pizda(2,2)
7870             vv(2)=pizda(2,1)+pizda(1,2)
7871             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7872             if (swap) then
7873               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7874 #ifdef MOMENT
7875                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7876      &             -(s1+s2+s4)
7877 #else
7878                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7879      &             -(s2+s4)
7880 #endif
7881                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7882               else
7883 #ifdef MOMENT
7884                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7885 #else
7886                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7887 #endif
7888                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7889               endif
7890             else
7891 #ifdef MOMENT
7892               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7893 #else
7894               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7895 #endif
7896               if (l.eq.j+1) then
7897                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7898               else
7899                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7900               endif
7901             endif
7902           enddo
7903         enddo
7904       enddo
7905       return
7906       end
7907 c----------------------------------------------------------------------------
7908       double precision function eello_turn6(i,jj,kk)
7909       implicit real*8 (a-h,o-z)
7910       include 'DIMENSIONS'
7911       include 'COMMON.IOUNITS'
7912       include 'COMMON.CHAIN'
7913       include 'COMMON.DERIV'
7914       include 'COMMON.INTERACT'
7915       include 'COMMON.CONTACTS'
7916       include 'COMMON.TORSION'
7917       include 'COMMON.VAR'
7918       include 'COMMON.GEO'
7919       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7920      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7921      &  ggg1(3),ggg2(3)
7922       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7923      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7924 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7925 C           the respective energy moment and not to the cluster cumulant.
7926       s1=0.0d0
7927       s8=0.0d0
7928       s13=0.0d0
7929 c
7930       eello_turn6=0.0d0
7931       j=i+4
7932       k=i+1
7933       l=i+3
7934       iti=itortyp(itype(i))
7935       itk=itortyp(itype(k))
7936       itk1=itortyp(itype(k+1))
7937       itl=itortyp(itype(l))
7938       itj=itortyp(itype(j))
7939 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7940 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7941 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7942 cd        eello6=0.0d0
7943 cd        return
7944 cd      endif
7945 cd      write (iout,*)
7946 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7947 cd     &   ' and',k,l
7948 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7949       do iii=1,2
7950         do kkk=1,5
7951           do lll=1,3
7952             derx_turn(lll,kkk,iii)=0.0d0
7953           enddo
7954         enddo
7955       enddo
7956 cd      eij=1.0d0
7957 cd      ekl=1.0d0
7958 cd      ekont=1.0d0
7959       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7960 cd      eello6_5=0.0d0
7961 cd      write (2,*) 'eello6_5',eello6_5
7962 #ifdef MOMENT
7963       call transpose2(AEA(1,1,1),auxmat(1,1))
7964       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7965       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7966       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7967 #endif
7968       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7969       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7970       s2 = scalar2(b1(1,itk),vtemp1(1))
7971 #ifdef MOMENT
7972       call transpose2(AEA(1,1,2),atemp(1,1))
7973       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7974       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7975       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7976 #endif
7977       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7978       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7979       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7980 #ifdef MOMENT
7981       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7982       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7983       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7984       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7985       ss13 = scalar2(b1(1,itk),vtemp4(1))
7986       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7987 #endif
7988 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7989 c      s1=0.0d0
7990 c      s2=0.0d0
7991 c      s8=0.0d0
7992 c      s12=0.0d0
7993 c      s13=0.0d0
7994       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7995 C Derivatives in gamma(i+2)
7996       s1d =0.0d0
7997       s8d =0.0d0
7998 #ifdef MOMENT
7999       call transpose2(AEA(1,1,1),auxmatd(1,1))
8000       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8001       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8002       call transpose2(AEAderg(1,1,2),atempd(1,1))
8003       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8004       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8005 #endif
8006       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8007       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8008       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8009 c      s1d=0.0d0
8010 c      s2d=0.0d0
8011 c      s8d=0.0d0
8012 c      s12d=0.0d0
8013 c      s13d=0.0d0
8014       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8015 C Derivatives in gamma(i+3)
8016 #ifdef MOMENT
8017       call transpose2(AEA(1,1,1),auxmatd(1,1))
8018       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8019       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8020       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8021 #endif
8022       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8023       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8024       s2d = scalar2(b1(1,itk),vtemp1d(1))
8025 #ifdef MOMENT
8026       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8027       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8028 #endif
8029       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8030 #ifdef MOMENT
8031       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8032       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8033       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8034 #endif
8035 c      s1d=0.0d0
8036 c      s2d=0.0d0
8037 c      s8d=0.0d0
8038 c      s12d=0.0d0
8039 c      s13d=0.0d0
8040 #ifdef MOMENT
8041       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8042      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8043 #else
8044       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8045      &               -0.5d0*ekont*(s2d+s12d)
8046 #endif
8047 C Derivatives in gamma(i+4)
8048       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8049       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8050       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8051 #ifdef MOMENT
8052       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8053       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8054       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8055 #endif
8056 c      s1d=0.0d0
8057 c      s2d=0.0d0
8058 c      s8d=0.0d0
8059 C      s12d=0.0d0
8060 c      s13d=0.0d0
8061 #ifdef MOMENT
8062       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8063 #else
8064       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8065 #endif
8066 C Derivatives in gamma(i+5)
8067 #ifdef MOMENT
8068       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8069       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8070       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8071 #endif
8072       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8073       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8074       s2d = scalar2(b1(1,itk),vtemp1d(1))
8075 #ifdef MOMENT
8076       call transpose2(AEA(1,1,2),atempd(1,1))
8077       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8078       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8079 #endif
8080       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8081       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8082 #ifdef MOMENT
8083       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8084       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8085       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8086 #endif
8087 c      s1d=0.0d0
8088 c      s2d=0.0d0
8089 c      s8d=0.0d0
8090 c      s12d=0.0d0
8091 c      s13d=0.0d0
8092 #ifdef MOMENT
8093       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8094      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8095 #else
8096       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8097      &               -0.5d0*ekont*(s2d+s12d)
8098 #endif
8099 C Cartesian derivatives
8100       do iii=1,2
8101         do kkk=1,5
8102           do lll=1,3
8103 #ifdef MOMENT
8104             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8105             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8106             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8107 #endif
8108             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8109             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8110      &          vtemp1d(1))
8111             s2d = scalar2(b1(1,itk),vtemp1d(1))
8112 #ifdef MOMENT
8113             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8114             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8115             s8d = -(atempd(1,1)+atempd(2,2))*
8116      &           scalar2(cc(1,1,itl),vtemp2(1))
8117 #endif
8118             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8119      &           auxmatd(1,1))
8120             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8121             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8122 c      s1d=0.0d0
8123 c      s2d=0.0d0
8124 c      s8d=0.0d0
8125 c      s12d=0.0d0
8126 c      s13d=0.0d0
8127 #ifdef MOMENT
8128             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8129      &        - 0.5d0*(s1d+s2d)
8130 #else
8131             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8132      &        - 0.5d0*s2d
8133 #endif
8134 #ifdef MOMENT
8135             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8136      &        - 0.5d0*(s8d+s12d)
8137 #else
8138             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8139      &        - 0.5d0*s12d
8140 #endif
8141           enddo
8142         enddo
8143       enddo
8144 #ifdef MOMENT
8145       do kkk=1,5
8146         do lll=1,3
8147           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8148      &      achuj_tempd(1,1))
8149           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8150           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8151           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8152           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8153           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8154      &      vtemp4d(1))
8155           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8156           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8157           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8158         enddo
8159       enddo
8160 #endif
8161 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8162 cd     &  16*eel_turn6_num
8163 cd      goto 1112
8164       if (j.lt.nres-1) then
8165         j1=j+1
8166         j2=j-1
8167       else
8168         j1=j-1
8169         j2=j-2
8170       endif
8171       if (l.lt.nres-1) then
8172         l1=l+1
8173         l2=l-1
8174       else
8175         l1=l-1
8176         l2=l-2
8177       endif
8178       do ll=1,3
8179         ggg1(ll)=eel_turn6*g_contij(ll,1)
8180         ggg2(ll)=eel_turn6*g_contij(ll,2)
8181         ghalf=0.5d0*ggg1(ll)
8182 cd        ghalf=0.0d0
8183         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8184      &    +ekont*derx_turn(ll,2,1)
8185         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8186         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8187      &    +ekont*derx_turn(ll,4,1)
8188         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8189         ghalf=0.5d0*ggg2(ll)
8190 cd        ghalf=0.0d0
8191         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8192      &    +ekont*derx_turn(ll,2,2)
8193         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8194         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8195      &    +ekont*derx_turn(ll,4,2)
8196         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8197       enddo
8198 cd      goto 1112
8199       do m=i+1,j-1
8200         do ll=1,3
8201           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8202         enddo
8203       enddo
8204       do m=k+1,l-1
8205         do ll=1,3
8206           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8207         enddo
8208       enddo
8209 1112  continue
8210       do m=i+2,j2
8211         do ll=1,3
8212           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8213         enddo
8214       enddo
8215       do m=k+2,l2
8216         do ll=1,3
8217           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8218         enddo
8219       enddo
8220 cd      do iii=1,nres-3
8221 cd        write (2,*) iii,g_corr6_loc(iii)
8222 cd      enddo
8223       eello_turn6=ekont*eel_turn6
8224 cd      write (2,*) 'ekont',ekont
8225 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8226       return
8227       end
8228
8229 C-----------------------------------------------------------------------------
8230       double precision function scalar(u,v)
8231 !DIR$ INLINEALWAYS scalar
8232 #ifndef OSF
8233 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8234 #endif
8235       implicit none
8236       double precision u(3),v(3)
8237 cd      double precision sc
8238 cd      integer i
8239 cd      sc=0.0d0
8240 cd      do i=1,3
8241 cd        sc=sc+u(i)*v(i)
8242 cd      enddo
8243 cd      scalar=sc
8244
8245       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8246       return
8247       end
8248 crc-------------------------------------------------
8249       SUBROUTINE MATVEC2(A1,V1,V2)
8250 !DIR$ INLINEALWAYS MATVEC2
8251 #ifndef OSF
8252 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8253 #endif
8254       implicit real*8 (a-h,o-z)
8255       include 'DIMENSIONS'
8256       DIMENSION A1(2,2),V1(2),V2(2)
8257 c      DO 1 I=1,2
8258 c        VI=0.0
8259 c        DO 3 K=1,2
8260 c    3     VI=VI+A1(I,K)*V1(K)
8261 c        Vaux(I)=VI
8262 c    1 CONTINUE
8263
8264       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8265       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8266
8267       v2(1)=vaux1
8268       v2(2)=vaux2
8269       END
8270 C---------------------------------------
8271       SUBROUTINE MATMAT2(A1,A2,A3)
8272 #ifndef OSF
8273 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8274 #endif
8275       implicit real*8 (a-h,o-z)
8276       include 'DIMENSIONS'
8277       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8278 c      DIMENSION AI3(2,2)
8279 c        DO  J=1,2
8280 c          A3IJ=0.0
8281 c          DO K=1,2
8282 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8283 c          enddo
8284 c          A3(I,J)=A3IJ
8285 c       enddo
8286 c      enddo
8287
8288       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8289       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8290       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8291       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8292
8293       A3(1,1)=AI3_11
8294       A3(2,1)=AI3_21
8295       A3(1,2)=AI3_12
8296       A3(2,2)=AI3_22
8297       END
8298
8299 c-------------------------------------------------------------------------
8300       double precision function scalar2(u,v)
8301 !DIR$ INLINEALWAYS scalar2
8302       implicit none
8303       double precision u(2),v(2)
8304       double precision sc
8305       integer i
8306       scalar2=u(1)*v(1)+u(2)*v(2)
8307       return
8308       end
8309
8310 C-----------------------------------------------------------------------------
8311
8312       subroutine transpose2(a,at)
8313 !DIR$ INLINEALWAYS transpose2
8314 #ifndef OSF
8315 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8316 #endif
8317       implicit none
8318       double precision a(2,2),at(2,2)
8319       at(1,1)=a(1,1)
8320       at(1,2)=a(2,1)
8321       at(2,1)=a(1,2)
8322       at(2,2)=a(2,2)
8323       return
8324       end
8325 c--------------------------------------------------------------------------
8326       subroutine transpose(n,a,at)
8327       implicit none
8328       integer n,i,j
8329       double precision a(n,n),at(n,n)
8330       do i=1,n
8331         do j=1,n
8332           at(j,i)=a(i,j)
8333         enddo
8334       enddo
8335       return
8336       end
8337 C---------------------------------------------------------------------------
8338       subroutine prodmat3(a1,a2,kk,transp,prod)
8339 !DIR$ INLINEALWAYS prodmat3
8340 #ifndef OSF
8341 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8342 #endif
8343       implicit none
8344       integer i,j
8345       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8346       logical transp
8347 crc      double precision auxmat(2,2),prod_(2,2)
8348
8349       if (transp) then
8350 crc        call transpose2(kk(1,1),auxmat(1,1))
8351 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8352 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8353
8354            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8355      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8356            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8357      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8358            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8359      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8360            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8361      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8362
8363       else
8364 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8365 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8366
8367            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8368      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8369            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8370      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8371            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8372      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8373            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8374      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8375
8376       endif
8377 c      call transpose2(a2(1,1),a2t(1,1))
8378
8379 crc      print *,transp
8380 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8381 crc      print *,((prod(i,j),i=1,2),j=1,2)
8382
8383       return
8384       end
8385