source/unres/src_MD-NEWSC/energy_p_new_barrier.F

   1       SUBROUTINE etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106,107) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 108
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 108
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 108
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 108
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 108
 128 C New SC-SC potential
 129   106 call emomo(evdw,evdw_p,evdw_m)
 130       goto 108
 131 C Soft-sphere potential
 132   107 call e_softsphere(evdw)
 133 C
 134 C Calculate electrostatic (H-bonding) energy of the main chain.
 135 C
 136   108 continue
 137 cmc
 138 cmc Sep-06: egb takes care of dynamic ss bonds too
 139 cmc
 140 c      if (dyn_ss) call dyn_set_nss
 141
 142 c      print *,"Processor",myrank," computed USCSC"
 143 #ifdef TIMING
 144 #ifdef MPI
 145       time01=MPI_Wtime()
 146 #else
 147       time00=tcpu()
 148 #endif
 149 #endif
 150       call vec_and_deriv
 151 #ifdef TIMING
 152 #ifdef MPI
 153       time_vec=time_vec+MPI_Wtime()-time01
 154 #else
 155       time_vec=time_vec+tcpu()-time01
 156 #endif
 157 #endif
 158 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 159       if (ipot.lt.7) then
 160 #ifdef SPLITELE
 161          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 162      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 163      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 164      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 165 #else
 166          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 167      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 168      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 169      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 170 #endif
 171             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 172          else
 173             ees=0.0d0
 174             evdw1=0.0d0
 175             eel_loc=0.0d0
 176             eello_turn3=0.0d0
 177             eello_turn4=0.0d0
 178          endif
 179       else
 180 c        write (iout,*) "Soft-spheer ELEC potential"
 181         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 182      &   eello_turn4)
 183       endif
 184 c      print *,"Processor",myrank," computed UELEC"
 185 C
 186 C Calculate excluded-volume interaction energy between peptide groups
 187 C and side chains.
 188 C
 189       if (ipot.lt.7) then
 190        if(wscp.gt.0d0) then
 191         call escp(evdw2,evdw2_14)
 192        else
 193         evdw2=0
 194         evdw2_14=0
 195        endif
 196       else
 197 c        write (iout,*) "Soft-sphere SCP potential"
 198         call escp_soft_sphere(evdw2,evdw2_14)
 199       endif
 200 c
 201 c Calculate the bond-stretching energy
 202 c
 203       call ebond(estr)
 204 C
 205 C Calculate the disulfide-bridge and other energy and the contributions
 206 C from other distance constraints.
 207 cd    print *,'Calling EHPB'
 208       call edis(ehpb)
 209 cd    print *,'EHPB exitted succesfully.'
 210 C
 211 C Calculate the virtual-bond-angle energy.
 212 C
 213       if (wang.gt.0d0) then
 214         call ebend(ebe)
 215       else
 216         ebe=0
 217       endif
 218 c      print *,"Processor",myrank," computed UB"
 219 C
 220 C Calculate the SC local energy.
 221 C
 222       call esc(escloc)
 223 c      print *,"Processor",myrank," computed USC"
 224 C
 225 C Calculate the virtual-bond torsional energy.
 226 C
 227 cd    print *,'nterm=',nterm
 228       if (wtor.gt.0) then
 229        call etor(etors,edihcnstr)
 230       else
 231        etors=0
 232        edihcnstr=0
 233       endif
 234 c      print *,"Processor",myrank," computed Utor"
 235 C
 236 C 6/23/01 Calculate double-torsional energy
 237 C
 238       if (wtor_d.gt.0) then
 239        call etor_d(etors_d)
 240       else
 241        etors_d=0
 242       endif
 243 c      print *,"Processor",myrank," computed Utord"
 244 C
 245 C 21/5/07 Calculate local sicdechain correlation energy
 246 C
 247       if (wsccor.gt.0.0d0) then
 248         call eback_sc_corr(esccor)
 249       else
 250         esccor=0.0d0
 251       endif
 252 c      print *,"Processor",myrank," computed Usccorr"
 253 C
 254 C 12/1/95 Multi-body terms
 255 C
 256       n_corr=0
 257       n_corr1=0
 258       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 259      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.7) then
 260          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 261 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 262 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 263       else
 264          ecorr=0.0d0
 265          ecorr5=0.0d0
 266          ecorr6=0.0d0
 267          eturn6=0.0d0
 268       endif
 269       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.7) then
 270          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 271 cd         write (iout,*) "multibody_hb ecorr",ecorr
 272       endif
 273 c      print *,"Processor",myrank," computed Ucorr"
 274 C
 275 C If performing constraint dynamics, call the constraint energy
 276 C  after the equilibration time
 277       if(usampl.and.totT.gt.eq_time) then
 278          call EconstrQ
 279          call Econstr_back
 280       else
 281          Uconst=0.0d0
 282          Uconst_back=0.0d0
 283       endif
 284 #ifdef TIMING
 285 #ifdef MPI
 286       time_enecalc=time_enecalc+MPI_Wtime()-time00
 287 #else
 288       time_enecalc=time_enecalc+tcpu()-time00
 289 #endif
 290 #endif
 291 c      print *,"Processor",myrank," computed Uconstr"
 292 #ifdef TIMING
 293 #ifdef MPI
 294       time00=MPI_Wtime()
 295 #else
 296       time00=tcpu()
 297 #endif
 298 #endif
 299 c
 300 C Sum the energies
 301 C
 302       energia(1)=evdw
 303 #ifdef SCP14
 304       energia(2)=evdw2-evdw2_14
 305       energia(18)=evdw2_14
 306 #else
 307       energia(2)=evdw2
 308       energia(18)=0.0d0
 309 #endif
 310 #ifdef SPLITELE
 311       energia(3)=ees
 312       energia(16)=evdw1
 313 #else
 314       energia(3)=ees+evdw1
 315       energia(16)=0.0d0
 316 #endif
 317       energia(4)=ecorr
 318       energia(5)=ecorr5
 319       energia(6)=ecorr6
 320       energia(7)=eel_loc
 321       energia(8)=eello_turn3
 322       energia(9)=eello_turn4
 323       energia(10)=eturn6
 324       energia(11)=ebe
 325       energia(12)=escloc
 326       energia(13)=etors
 327       energia(14)=etors_d
 328       energia(15)=ehpb
 329       energia(19)=edihcnstr
 330       energia(17)=estr
 331       energia(20)=Uconst+Uconst_back
 332       energia(21)=esccor
 333       energia(22)=evdw_p
 334       energia(23)=evdw_m
 335 c      print *," Processor",myrank," calls SUM_ENERGY"
 336       call sum_energy(energia,.true.)
 337       if (dyn_ss) call dyn_set_nss
 338 c      print *," Processor",myrank," left SUM_ENERGY"
 339 #ifdef TIMING
 340 #ifdef MPI
 341       time_sumene=time_sumene+MPI_Wtime()-time00
 342 #else
 343       time_sumene=time_sumene+tcpu()-time00
 344 #endif
 345 #endif
 346       RETURN
 347       END SUBROUTINE etotal
 348 c-------------------------------------------------------------------------------
 349       subroutine sum_energy(energia,reduce)
 350       implicit real*8 (a-h,o-z)
 351       include 'DIMENSIONS'
 352 #ifndef ISNAN
 353       external proc_proc
 354 #ifdef WINPGI
 355 cMS$ATTRIBUTES C ::  proc_proc
 356 #endif
 357 #endif
 358 #ifdef MPI
 359       include "mpif.h"
 360 #endif
 361       include 'COMMON.SETUP'
 362       include 'COMMON.IOUNITS'
 363       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 364       include 'COMMON.FFIELD'
 365       include 'COMMON.DERIV'
 366       include 'COMMON.INTERACT'
 367       include 'COMMON.SBRIDGE'
 368       include 'COMMON.CHAIN'
 369       include 'COMMON.VAR'
 370       include 'COMMON.CONTROL'
 371       include 'COMMON.TIME1'
 372       logical reduce
 373 #ifdef MPI
 374       if (nfgtasks.gt.1 .and. reduce) then
 375 #ifdef DEBUG
 376         write (iout,*) "energies before REDUCE"
 377         call enerprint(energia)
 378         call flush(iout)
 379 #endif
 380         do i=0,n_ene
 381           enebuff(i)=energia(i)
 382         enddo
 383         time00=MPI_Wtime()
 384         call MPI_Barrier(FG_COMM,IERR)
 385         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 386         time00=MPI_Wtime()
 387         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 388      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 389 #ifdef DEBUG
 390         write (iout,*) "energies after REDUCE"
 391         call enerprint(energia)
 392         call flush(iout)
 393 #endif
 394         time_Reduce=time_Reduce+MPI_Wtime()-time00
 395       endif
 396       if (fg_rank.eq.0) then
 397 #endif
 398 #ifdef TSCSC
 399       evdw=energia(22)+wsct*energia(23)
 400 #else
 401       evdw=energia(1)
 402 #endif
 403 #ifdef SCP14
 404       evdw2=energia(2)+energia(18)
 405       evdw2_14=energia(18)
 406 #else
 407       evdw2=energia(2)
 408 #endif
 409 #ifdef SPLITELE
 410       ees=energia(3)
 411       evdw1=energia(16)
 412 #else
 413       ees=energia(3)
 414       evdw1=0.0d0
 415 #endif
 416       ecorr=energia(4)
 417       ecorr5=energia(5)
 418       ecorr6=energia(6)
 419       eel_loc=energia(7)
 420       eello_turn3=energia(8)
 421       eello_turn4=energia(9)
 422       eturn6=energia(10)
 423       ebe=energia(11)
 424       escloc=energia(12)
 425       etors=energia(13)
 426       etors_d=energia(14)
 427       ehpb=energia(15)
 428       edihcnstr=energia(19)
 429       estr=energia(17)
 430       Uconst=energia(20)
 431       esccor=energia(21)
 432 #ifdef SPLITELE
 433       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 434      & +wang*ebe+wtor*etors+wscloc*escloc
 435      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 436      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 437      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 438      & +wbond*estr+Uconst+wsccor*esccor
 439 #else
 440       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 441      & +wang*ebe+wtor*etors+wscloc*escloc
 442      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 443      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 444      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 445      & +wbond*estr+Uconst+wsccor*esccor
 446 #endif
 447       energia(0)=etot
 448 c detecting NaNQ
 449 #ifdef ISNAN
 450 #ifdef AIX
 451       if (isnan(etot).ne.0) energia(0)=1.0d+99
 452 #else
 453       if (isnan(etot)) energia(0)=1.0d+99
 454 #endif
 455 #else
 456       i=0
 457 #ifdef WINPGI
 458       idumm=proc_proc(etot,i)
 459 #else
 460       call proc_proc(etot,i)
 461 #endif
 462       if(i.eq.1)energia(0)=1.0d+99
 463 #endif
 464 #ifdef MPI
 465       endif
 466 #endif
 467       return
 468       end
 469 c-------------------------------------------------------------------------------
 470       subroutine sum_gradient
 471       implicit real*8 (a-h,o-z)
 472       include 'DIMENSIONS'
 473 #ifndef ISNAN
 474       external proc_proc
 475 #ifdef WINPGI
 476 cMS$ATTRIBUTES C ::  proc_proc
 477 #endif
 478 #endif
 479 #ifdef MPI
 480       include 'mpif.h'
 481 #endif
 482       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 483      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 484       include 'COMMON.SETUP'
 485       include 'COMMON.IOUNITS'
 486       include 'COMMON.FFIELD'
 487       include 'COMMON.DERIV'
 488       include 'COMMON.INTERACT'
 489       include 'COMMON.SBRIDGE'
 490       include 'COMMON.CHAIN'
 491       include 'COMMON.VAR'
 492       include 'COMMON.CONTROL'
 493       include 'COMMON.TIME1'
 494       include 'COMMON.MAXGRAD'
 495       include 'COMMON.SCCOR'
 496 #ifdef TIMING
 497 #ifdef MPI
 498       time01=MPI_Wtime()
 499 #else
 500       time01=tcpu()
 501 #endif
 502 #endif
 503 #ifdef DEBUG
 504       write (iout,*) "sum_gradient gvdwc, gvdwx"
 505       do i=1,nres
 506         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 507      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 508      &   (gvdwcT(j,i),j=1,3)
 509       enddo
 510       call flush(iout)
 511 #endif
 512 #ifdef MPI
 513 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 514         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 515      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 516 #endif
 517 C
 518 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 519 C            in virtual-bond-vector coordinates
 520 C
 521 #ifdef DEBUG
 522 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 523 c      do i=1,nres-1
 524 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 525 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 526 c      enddo
 527 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 528 c      do i=1,nres-1
 529 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 530 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 531 c      enddo
 532       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 533       do i=1,nres
 534         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 535      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 536      &   g_corr5_loc(i)
 537       enddo
 538       call flush(iout)
 539 #endif
 540 #ifdef SPLITELE
 541 #ifdef TSCSC
 542       do i=1,nct
 543         do j=1,3
 544           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 545      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 546      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 547      &                wel_loc*gel_loc_long(j,i)+
 548      &                wcorr*gradcorr_long(j,i)+
 549      &                wcorr5*gradcorr5_long(j,i)+
 550      &                wcorr6*gradcorr6_long(j,i)+
 551      &                wturn6*gcorr6_turn_long(j,i)+
 552      &                wstrain*ghpbc(j,i)
 553         enddo
 554       enddo
 555 #else
 556       do i=1,nct
 557         do j=1,3
 558           gradbufc(j,i)=wsc*gvdwc(j,i)+
 559      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 560      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 561      &                wel_loc*gel_loc_long(j,i)+
 562      &                wcorr*gradcorr_long(j,i)+
 563      &                wcorr5*gradcorr5_long(j,i)+
 564      &                wcorr6*gradcorr6_long(j,i)+
 565      &                wturn6*gcorr6_turn_long(j,i)+
 566      &                wstrain*ghpbc(j,i)
 567         enddo
 568       enddo
 569 #endif
 570 #else
 571       do i=1,nct
 572         do j=1,3
 573           gradbufc(j,i)=wsc*gvdwc(j,i)+
 574      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 575      &                welec*gelc_long(j,i)+
 576      &                wbond*gradb(j,i)+
 577      &                wel_loc*gel_loc_long(j,i)+
 578      &                wcorr*gradcorr_long(j,i)+
 579      &                wcorr5*gradcorr5_long(j,i)+
 580      &                wcorr6*gradcorr6_long(j,i)+
 581      &                wturn6*gcorr6_turn_long(j,i)+
 582      &                wstrain*ghpbc(j,i)
 583         enddo
 584       enddo
 585 #endif
 586 #ifdef MPI
 587       if (nfgtasks.gt.1) then
 588       time00=MPI_Wtime()
 589 #ifdef DEBUG
 590       write (iout,*) "gradbufc before allreduce"
 591       do i=1,nres
 592         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 593       enddo
 594       call flush(iout)
 595 #endif
 596       do i=1,nres
 597         do j=1,3
 598           gradbufc_sum(j,i)=gradbufc(j,i)
 599         enddo
 600       enddo
 601 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 602 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 603 c      time_reduce=time_reduce+MPI_Wtime()-time00
 604 #ifdef DEBUG
 605 c      write (iout,*) "gradbufc_sum after allreduce"
 606 c      do i=1,nres
 607 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 608 c      enddo
 609 c      call flush(iout)
 610 #endif
 611 #ifdef TIMING
 612 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 613 #endif
 614       do i=nnt,nres
 615         do k=1,3
 616           gradbufc(k,i)=0.0d0
 617         enddo
 618       enddo
 619 #ifdef DEBUG
 620       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 621       write (iout,*) (i," jgrad_start",jgrad_start(i),
 622      &                  " jgrad_end  ",jgrad_end(i),
 623      &                  i=igrad_start,igrad_end)
 624 #endif
 625 c
 626 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 627 c do not parallelize this part.
 628 c
 629 c      do i=igrad_start,igrad_end
 630 c        do j=jgrad_start(i),jgrad_end(i)
 631 c          do k=1,3
 632 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 633 c          enddo
 634 c        enddo
 635 c      enddo
 636       do j=1,3
 637         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 638       enddo
 639       do i=nres-2,nnt,-1
 640         do j=1,3
 641           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 642         enddo
 643       enddo
 644 #ifdef DEBUG
 645       write (iout,*) "gradbufc after summing"
 646       do i=1,nres
 647         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 648       enddo
 649       call flush(iout)
 650 #endif
 651       else
 652 #endif
 653 #ifdef DEBUG
 654       write (iout,*) "gradbufc"
 655       do i=1,nres
 656         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 657       enddo
 658       call flush(iout)
 659 #endif
 660       do i=1,nres
 661         do j=1,3
 662           gradbufc_sum(j,i)=gradbufc(j,i)
 663           gradbufc(j,i)=0.0d0
 664         enddo
 665       enddo
 666       do j=1,3
 667         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 668       enddo
 669       do i=nres-2,nnt,-1
 670         do j=1,3
 671           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 672         enddo
 673       enddo
 674 c      do i=nnt,nres-1
 675 c        do k=1,3
 676 c          gradbufc(k,i)=0.0d0
 677 c        enddo
 678 c        do j=i+1,nres
 679 c          do k=1,3
 680 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 681 c          enddo
 682 c        enddo
 683 c      enddo
 684 #ifdef DEBUG
 685       write (iout,*) "gradbufc after summing"
 686       do i=1,nres
 687         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 688       enddo
 689       call flush(iout)
 690 #endif
 691 #ifdef MPI
 692       endif
 693 #endif
 694       do k=1,3
 695         gradbufc(k,nres)=0.0d0
 696       enddo
 697       do i=1,nct
 698         do j=1,3
 699 #ifdef SPLITELE
 700           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 701      &                wel_loc*gel_loc(j,i)+
 702      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 703      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 704      &                wel_loc*gel_loc_long(j,i)+
 705      &                wcorr*gradcorr_long(j,i)+
 706      &                wcorr5*gradcorr5_long(j,i)+
 707      &                wcorr6*gradcorr6_long(j,i)+
 708      &                wturn6*gcorr6_turn_long(j,i))+
 709      &                wbond*gradb(j,i)+
 710      &                wcorr*gradcorr(j,i)+
 711      &                wturn3*gcorr3_turn(j,i)+
 712      &                wturn4*gcorr4_turn(j,i)+
 713      &                wcorr5*gradcorr5(j,i)+
 714      &                wcorr6*gradcorr6(j,i)+
 715      &                wturn6*gcorr6_turn(j,i)+
 716      &                wsccor*gsccorc(j,i)
 717      &               +wscloc*gscloc(j,i)
 718 #else
 719           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 720      &                wel_loc*gel_loc(j,i)+
 721      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 722      &                welec*gelc_long(j,i)+
 723      &                wel_loc*gel_loc_long(j,i)+
 724      &                wcorr*gcorr_long(j,i)+
 725      &                wcorr5*gradcorr5_long(j,i)+
 726      &                wcorr6*gradcorr6_long(j,i)+
 727      &                wturn6*gcorr6_turn_long(j,i))+
 728      &                wbond*gradb(j,i)+
 729      &                wcorr*gradcorr(j,i)+
 730      &                wturn3*gcorr3_turn(j,i)+
 731      &                wturn4*gcorr4_turn(j,i)+
 732      &                wcorr5*gradcorr5(j,i)+
 733      &                wcorr6*gradcorr6(j,i)+
 734      &                wturn6*gcorr6_turn(j,i)+
 735      &                wsccor*gsccorc(j,i)
 736      &               +wscloc*gscloc(j,i)
 737 #endif
 738 #ifdef TSCSC
 739           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 740      &                  wscp*gradx_scp(j,i)+
 741      &                  wbond*gradbx(j,i)+
 742      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 743      &                  wsccor*gsccorx(j,i)
 744      &                 +wscloc*gsclocx(j,i)
 745 #else
 746           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 747      &                  wbond*gradbx(j,i)+
 748      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 749      &                  wsccor*gsccorx(j,i)
 750      &                 +wscloc*gsclocx(j,i)
 751 #endif
 752         enddo
 753       enddo
 754 #ifdef DEBUG
 755       write (iout,*) "gloc before adding corr"
 756       do i=1,4*nres
 757         write (iout,*) i,gloc(i,icg)
 758       enddo
 759 #endif
 760       do i=1,nres-3
 761         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 762      &   +wcorr5*g_corr5_loc(i)
 763      &   +wcorr6*g_corr6_loc(i)
 764      &   +wturn4*gel_loc_turn4(i)
 765      &   +wturn3*gel_loc_turn3(i)
 766      &   +wturn6*gel_loc_turn6(i)
 767      &   +wel_loc*gel_loc_loc(i)
 768       enddo
 769 #ifdef DEBUG
 770       write (iout,*) "gloc after adding corr"
 771       do i=1,4*nres
 772         write (iout,*) i,gloc(i,icg)
 773       enddo
 774 #endif
 775 #ifdef MPI
 776       if (nfgtasks.gt.1) then
 777         do j=1,3
 778           do i=1,nres
 779             gradbufc(j,i)=gradc(j,i,icg)
 780             gradbufx(j,i)=gradx(j,i,icg)
 781           enddo
 782         enddo
 783         do i=1,4*nres
 784           glocbuf(i)=gloc(i,icg)
 785         enddo
 786 #ifdef DEBUG
 787       write (iout,*) "gloc_sc before reduce"
 788       do i=1,nres
 789        do j=1,3
 790         write (iout,*) i,j,gloc_sc(j,i,icg)
 791        enddo
 792       enddo
 793 #endif
 794         do i=1,nres
 795          do j=1,3
 796           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 797          enddo
 798         enddo
 799         time00=MPI_Wtime()
 800         call MPI_Barrier(FG_COMM,IERR)
 801         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 802         time00=MPI_Wtime()
 803         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 806      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 807         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 808      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 809         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 810      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 811         time_reduce=time_reduce+MPI_Wtime()-time00
 812 #ifdef DEBUG
 813       write (iout,*) "gloc_sc after reduce"
 814       do i=1,nres
 815        do j=1,3
 816         write (iout,*) i,j,gloc_sc(j,i,icg)
 817        enddo
 818       enddo
 819 #endif
 820 #ifdef DEBUG
 821       write (iout,*) "gloc after reduce"
 822       do i=1,4*nres
 823         write (iout,*) i,gloc(i,icg)
 824       enddo
 825 #endif
 826       endif
 827 #endif
 828       if (gnorm_check) then
 829 c
 830 c Compute the maximum elements of the gradient
 831 c
 832       gvdwc_max=0.0d0
 833       gvdwc_scp_max=0.0d0
 834       gelc_max=0.0d0
 835       gvdwpp_max=0.0d0
 836       gradb_max=0.0d0
 837       ghpbc_max=0.0d0
 838       gradcorr_max=0.0d0
 839       gel_loc_max=0.0d0
 840       gcorr3_turn_max=0.0d0
 841       gcorr4_turn_max=0.0d0
 842       gradcorr5_max=0.0d0
 843       gradcorr6_max=0.0d0
 844       gcorr6_turn_max=0.0d0
 845       gsccorc_max=0.0d0
 846       gscloc_max=0.0d0
 847       gvdwx_max=0.0d0
 848       gradx_scp_max=0.0d0
 849       ghpbx_max=0.0d0
 850       gradxorr_max=0.0d0
 851       gsccorx_max=0.0d0
 852       gsclocx_max=0.0d0
 853       do i=1,nct
 854         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 855         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 856 #ifdef TSCSC
 857         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 858         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 859 #endif
 860         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 861         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 862      &   gvdwc_scp_max=gvdwc_scp_norm
 863         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 864         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 865         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 866         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 867         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 868         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 869         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 870         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 871         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 872         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 873         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 874         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 875         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 876      &    gcorr3_turn(1,i)))
 877         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 878      &    gcorr3_turn_max=gcorr3_turn_norm
 879         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 880      &    gcorr4_turn(1,i)))
 881         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 882      &    gcorr4_turn_max=gcorr4_turn_norm
 883         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 884         if (gradcorr5_norm.gt.gradcorr5_max)
 885      &    gradcorr5_max=gradcorr5_norm
 886         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 887         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 888         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 889      &    gcorr6_turn(1,i)))
 890         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 891      &    gcorr6_turn_max=gcorr6_turn_norm
 892         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 893         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 894         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 895         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 896         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 897         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 898 #ifdef TSCSC
 899         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 900         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 901 #endif
 902         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 903         if (gradx_scp_norm.gt.gradx_scp_max)
 904      &    gradx_scp_max=gradx_scp_norm
 905         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 906         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 907         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 908         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 909         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 910         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 911         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 912         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 913       enddo
 914       if (gradout) then
 915 #ifdef AIX
 916         open(istat,file=statname,position="append")
 917 #else
 918         open(istat,file=statname,access="append")
 919 #endif
 920         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 921      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 922      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 923      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 924      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 925      &     gsccorx_max,gsclocx_max
 926         close(istat)
 927         if (gvdwc_max.gt.1.0d4) then
 928           write (iout,*) "gvdwc gvdwx gradb gradbx"
 929           do i=nnt,nct
 930             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 931      &        gradb(j,i),gradbx(j,i),j=1,3)
 932           enddo
 933           call pdbout(0.0d0,'cipiszcze',iout)
 934           call flush(iout)
 935         endif
 936       endif
 937       endif
 938 #ifdef DEBUG
 939       write (iout,*) "gradc gradx gloc"
 940       do i=1,nres
 941         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 942      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 943       enddo
 944 #endif
 945 #ifdef TIMING
 946 #ifdef MPI
 947       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 948 #else
 949       time_sumgradient=time_sumgradient+tcpu()-time01
 950 #endif
 951 #endif
 952       return
 953       end
 954 c-------------------------------------------------------------------------------
 955       subroutine rescale_weights(t_bath)
 956       implicit real*8 (a-h,o-z)
 957       include 'DIMENSIONS'
 958       include 'COMMON.IOUNITS'
 959       include 'COMMON.FFIELD'
 960       include 'COMMON.SBRIDGE'
 961       double precision kfac /2.4d0/
 962       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 963 c      facT=temp0/t_bath
 964 c      facT=2*temp0/(t_bath+temp0)
 965       if (rescale_mode.eq.0) then
 966         facT=1.0d0
 967         facT2=1.0d0
 968         facT3=1.0d0
 969         facT4=1.0d0
 970         facT5=1.0d0
 971       else if (rescale_mode.eq.1) then
 972         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 973         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 974         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 975         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 976         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 977       else if (rescale_mode.eq.2) then
 978         x=t_bath/temp0
 979         x2=x*x
 980         x3=x2*x
 981         x4=x3*x
 982         x5=x4*x
 983         facT=licznik/dlog(dexp(x)+dexp(-x))
 984         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 985         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 986         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 987         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 988       else
 989         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 990         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 991 #ifdef MPI
 992        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 993 #endif
 994        stop 555
 995       endif
 996       welec=weights(3)*fact
 997       wcorr=weights(4)*fact3
 998       wcorr5=weights(5)*fact4
 999       wcorr6=weights(6)*fact5
1000       wel_loc=weights(7)*fact2
1001       wturn3=weights(8)*fact2
1002       wturn4=weights(9)*fact3
1003       wturn6=weights(10)*fact5
1004       wtor=weights(13)*fact
1005       wtor_d=weights(14)*fact2
1006       wsccor=weights(21)*fact
1007 #ifdef TSCSC
1008 c      wsct=t_bath/temp0
1009       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1010 #endif
1011       return
1012       end
1013 C------------------------------------------------------------------------
1014       subroutine enerprint(energia)
1015       implicit real*8 (a-h,o-z)
1016       include 'DIMENSIONS'
1017       include 'COMMON.IOUNITS'
1018       include 'COMMON.FFIELD'
1019       include 'COMMON.SBRIDGE'
1020       include 'COMMON.MD'
1021       double precision energia(0:n_ene)
1022       etot=energia(0)
1023 #ifdef TSCSC
1024       evdw=energia(22)+wsct*energia(23)
1025 #else
1026       evdw=energia(1)
1027 #endif
1028       evdw2=energia(2)
1029 #ifdef SCP14
1030       evdw2=energia(2)+energia(18)
1031 #else
1032       evdw2=energia(2)
1033 #endif
1034       ees=energia(3)
1035 #ifdef SPLITELE
1036       evdw1=energia(16)
1037 #endif
1038       ecorr=energia(4)
1039       ecorr5=energia(5)
1040       ecorr6=energia(6)
1041       eel_loc=energia(7)
1042       eello_turn3=energia(8)
1043       eello_turn4=energia(9)
1044       eello_turn6=energia(10)
1045       ebe=energia(11)
1046       escloc=energia(12)
1047       etors=energia(13)
1048       etors_d=energia(14)
1049       ehpb=energia(15)
1050       edihcnstr=energia(19)
1051       estr=energia(17)
1052       Uconst=energia(20)
1053       esccor=energia(21)
1054 #ifdef SPLITELE
1055       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1056      &  estr,wbond,ebe,wang,
1057      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1058      &  ecorr,wcorr,
1059      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1060      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1061      &  edihcnstr,ebr*nss,
1062      &  Uconst,etot
1063    10 format (/'Virtual-chain energies:'//
1064      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1065      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1066      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1067      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1068      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1069      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1070      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1071      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1072      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1073      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1074      & ' (SS bridges & dist. cnstr.)'/
1075      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1076      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1077      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1078      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1079      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1080      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1081      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1082      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1083      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1084      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1085      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1086      & 'ETOT=  ',1pE16.6,' (total)')
1087 #else
1088       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1089      &  estr,wbond,ebe,wang,
1090      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1091      &  ecorr,wcorr,
1092      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1093      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1094      &  ebr*nss,Uconst,etot
1095    10 format (/'Virtual-chain energies:'//
1096      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1097      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1098      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1099      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1100      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1101      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1102      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1103      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1104      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1105      & ' (SS bridges & dist. cnstr.)'/
1106      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1107      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1108      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1109      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1110      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1111      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1112      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1113      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1114      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1115      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1116      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1117      & 'ETOT=  ',1pE16.6,' (total)')
1118 #endif
1119       return
1120       end
1121 C-----------------------------------------------------------------------
1122       subroutine elj(evdw,evdw_p,evdw_m)
1123 C
1124 C This subroutine calculates the interaction energy of nonbonded side chains
1125 C assuming the LJ potential of interaction.
1126 C
1127       implicit real*8 (a-h,o-z)
1128       include 'DIMENSIONS'
1129       parameter (accur=1.0d-10)
1130       include 'COMMON.GEO'
1131       include 'COMMON.VAR'
1132       include 'COMMON.LOCAL'
1133       include 'COMMON.CHAIN'
1134       include 'COMMON.DERIV'
1135       include 'COMMON.INTERACT'
1136       include 'COMMON.TORSION'
1137       include 'COMMON.SBRIDGE'
1138       include 'COMMON.NAMES'
1139       include 'COMMON.IOUNITS'
1140       include 'COMMON.CONTACTS'
1141       dimension gg(3)
1142 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1143       evdw=0.0D0
1144       do i=iatsc_s,iatsc_e
1145         itypi=itype(i)
1146         itypi1=itype(i+1)
1147         xi=c(1,nres+i)
1148         yi=c(2,nres+i)
1149         zi=c(3,nres+i)
1150 C Change 12/1/95
1151         num_conti=0
1152 C
1153 C Calculate SC interaction energy.
1154 C
1155         do iint=1,nint_gr(i)
1156 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1157 cd   &                  'iend=',iend(i,iint)
1158           do j=istart(i,iint),iend(i,iint)
1159             itypj=itype(j)
1160             xj=c(1,nres+j)-xi
1161             yj=c(2,nres+j)-yi
1162             zj=c(3,nres+j)-zi
1163 C Change 12/1/95 to calculate four-body interactions
1164             rij=xj*xj+yj*yj+zj*zj
1165             rrij=1.0D0/rij
1166 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1167             eps0ij=eps(itypi,itypj)
1168             fac=rrij**expon2
1169             e1=fac*fac*aa(itypi,itypj)
1170             e2=fac*bb(itypi,itypj)
1171             evdwij=e1+e2
1172 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1173 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1174 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1175 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1176 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1177 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1178 #ifdef TSCSC
1179             if (bb(itypi,itypj).gt.0) then
1180                evdw_p=evdw_p+evdwij
1181             else
1182                evdw_m=evdw_m+evdwij
1183             endif
1184 #else
1185             evdw=evdw+evdwij
1186 #endif
1187 C
1188 C Calculate the components of the gradient in DC and X
1189 C
1190             fac=-rrij*(e1+evdwij)
1191             gg(1)=xj*fac
1192             gg(2)=yj*fac
1193             gg(3)=zj*fac
1194 #ifdef TSCSC
1195             if (bb(itypi,itypj).gt.0.0d0) then
1196               do k=1,3
1197                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1198                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1199                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1200                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1201               enddo
1202             else
1203               do k=1,3
1204                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1205                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1206                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1207                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1208               enddo
1209             endif
1210 #else
1211             do k=1,3
1212               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1213               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1214               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1215               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1216             enddo
1217 #endif
1218 cgrad            do k=i,j-1
1219 cgrad              do l=1,3
1220 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1221 cgrad              enddo
1222 cgrad            enddo
1223 C
1224 C 12/1/95, revised on 5/20/97
1225 C
1226 C Calculate the contact function. The ith column of the array JCONT will
1227 C contain the numbers of atoms that make contacts with the atom I (of numbers
1228 C greater than I). The arrays FACONT and GACONT will contain the values of
1229 C the contact function and its derivative.
1230 C
1231 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1232 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1233 C Uncomment next line, if the correlation interactions are contact function only
1234             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1235               rij=dsqrt(rij)
1236               sigij=sigma(itypi,itypj)
1237               r0ij=rs0(itypi,itypj)
1238 C
1239 C Check whether the SC's are not too far to make a contact.
1240 C
1241               rcut=1.5d0*r0ij
1242               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1243 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1244 C
1245               if (fcont.gt.0.0D0) then
1246 C If the SC-SC distance if close to sigma, apply spline.
1247 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1248 cAdam &             fcont1,fprimcont1)
1249 cAdam           fcont1=1.0d0-fcont1
1250 cAdam           if (fcont1.gt.0.0d0) then
1251 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1252 cAdam             fcont=fcont*fcont1
1253 cAdam           endif
1254 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1255 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1256 cga             do k=1,3
1257 cga               gg(k)=gg(k)*eps0ij
1258 cga             enddo
1259 cga             eps0ij=-evdwij*eps0ij
1260 C Uncomment for AL's type of SC correlation interactions.
1261 cadam           eps0ij=-evdwij
1262                 num_conti=num_conti+1
1263                 jcont(num_conti,i)=j
1264                 facont(num_conti,i)=fcont*eps0ij
1265                 fprimcont=eps0ij*fprimcont/rij
1266                 fcont=expon*fcont
1267 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1268 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1269 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1270 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1271                 gacont(1,num_conti,i)=-fprimcont*xj
1272                 gacont(2,num_conti,i)=-fprimcont*yj
1273                 gacont(3,num_conti,i)=-fprimcont*zj
1274 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1275 cd              write (iout,'(2i3,3f10.5)')
1276 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1277               endif
1278             endif
1279           enddo      ! j
1280         enddo        ! iint
1281 C Change 12/1/95
1282         num_cont(i)=num_conti
1283       enddo          ! i
1284       do i=1,nct
1285         do j=1,3
1286           gvdwc(j,i)=expon*gvdwc(j,i)
1287           gvdwx(j,i)=expon*gvdwx(j,i)
1288         enddo
1289       enddo
1290 C******************************************************************************
1291 C
1292 C                              N O T E !!!
1293 C
1294 C To save time, the factor of EXPON has been extracted from ALL components
1295 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1296 C use!
1297 C
1298 C******************************************************************************
1299       return
1300       end
1301 C-----------------------------------------------------------------------------
1302       subroutine eljk(evdw,evdw_p,evdw_m)
1303 C
1304 C This subroutine calculates the interaction energy of nonbonded side chains
1305 C assuming the LJK potential of interaction.
1306 C
1307       implicit real*8 (a-h,o-z)
1308       include 'DIMENSIONS'
1309       include 'COMMON.GEO'
1310       include 'COMMON.VAR'
1311       include 'COMMON.LOCAL'
1312       include 'COMMON.CHAIN'
1313       include 'COMMON.DERIV'
1314       include 'COMMON.INTERACT'
1315       include 'COMMON.IOUNITS'
1316       include 'COMMON.NAMES'
1317       dimension gg(3)
1318       logical scheck
1319 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1320       evdw=0.0D0
1321       do i=iatsc_s,iatsc_e
1322         itypi=itype(i)
1323         itypi1=itype(i+1)
1324         xi=c(1,nres+i)
1325         yi=c(2,nres+i)
1326         zi=c(3,nres+i)
1327 C
1328 C Calculate SC interaction energy.
1329 C
1330         do iint=1,nint_gr(i)
1331           do j=istart(i,iint),iend(i,iint)
1332             itypj=itype(j)
1333             xj=c(1,nres+j)-xi
1334             yj=c(2,nres+j)-yi
1335             zj=c(3,nres+j)-zi
1336             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1337             fac_augm=rrij**expon
1338             e_augm=augm(itypi,itypj)*fac_augm
1339             r_inv_ij=dsqrt(rrij)
1340             rij=1.0D0/r_inv_ij
1341             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1342             fac=r_shift_inv**expon
1343             e1=fac*fac*aa(itypi,itypj)
1344             e2=fac*bb(itypi,itypj)
1345             evdwij=e_augm+e1+e2
1346 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1347 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1348 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1349 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1350 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1351 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1352 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1353 #ifdef TSCSC
1354             if (bb(itypi,itypj).gt.0) then
1355                evdw_p=evdw_p+evdwij
1356             else
1357                evdw_m=evdw_m+evdwij
1358             endif
1359 #else
1360             evdw=evdw+evdwij
1361 #endif
1362 C
1363 C Calculate the components of the gradient in DC and X
1364 C
1365             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1366             gg(1)=xj*fac
1367             gg(2)=yj*fac
1368             gg(3)=zj*fac
1369 #ifdef TSCSC
1370             if (bb(itypi,itypj).gt.0.0d0) then
1371               do k=1,3
1372                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1373                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1374                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1375                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1376               enddo
1377             else
1378               do k=1,3
1379                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1380                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1381                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1382                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1383               enddo
1384             endif
1385 #else
1386             do k=1,3
1387               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1388               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1389               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1390               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1391             enddo
1392 #endif
1393 cgrad            do k=i,j-1
1394 cgrad              do l=1,3
1395 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1396 cgrad              enddo
1397 cgrad            enddo
1398           enddo      ! j
1399         enddo        ! iint
1400       enddo          ! i
1401       do i=1,nct
1402         do j=1,3
1403           gvdwc(j,i)=expon*gvdwc(j,i)
1404           gvdwx(j,i)=expon*gvdwx(j,i)
1405         enddo
1406       enddo
1407       return
1408       end
1409 C-----------------------------------------------------------------------------
1410       subroutine ebp(evdw,evdw_p,evdw_m)
1411 C
1412 C This subroutine calculates the interaction energy of nonbonded side chains
1413 C assuming the Berne-Pechukas potential of interaction.
1414 C
1415       implicit real*8 (a-h,o-z)
1416       include 'DIMENSIONS'
1417       include 'COMMON.GEO'
1418       include 'COMMON.VAR'
1419       include 'COMMON.LOCAL'
1420       include 'COMMON.CHAIN'
1421       include 'COMMON.DERIV'
1422       include 'COMMON.NAMES'
1423       include 'COMMON.INTERACT'
1424       include 'COMMON.IOUNITS'
1425       include 'COMMON.CALC'
1426       common /srutu/ icall
1427 c     double precision rrsave(maxdim)
1428       logical lprn
1429       evdw=0.0D0
1430 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1431       evdw=0.0D0
1432 c     if (icall.eq.0) then
1433 c       lprn=.true.
1434 c     else
1435         lprn=.false.
1436 c     endif
1437       ind=0
1438       do i=iatsc_s,iatsc_e
1439         itypi=itype(i)
1440         itypi1=itype(i+1)
1441         xi=c(1,nres+i)
1442         yi=c(2,nres+i)
1443         zi=c(3,nres+i)
1444         dxi=dc_norm(1,nres+i)
1445         dyi=dc_norm(2,nres+i)
1446         dzi=dc_norm(3,nres+i)
1447 c        dsci_inv=dsc_inv(itypi)
1448         dsci_inv=vbld_inv(i+nres)
1449 C
1450 C Calculate SC interaction energy.
1451 C
1452         do iint=1,nint_gr(i)
1453           do j=istart(i,iint),iend(i,iint)
1454             ind=ind+1
1455             itypj=itype(j)
1456 c            dscj_inv=dsc_inv(itypj)
1457             dscj_inv=vbld_inv(j+nres)
1458             chi1=chi(itypi,itypj)
1459             chi2=chi(itypj,itypi)
1460             chi12=chi1*chi2
1461             chip1=chip(itypi)
1462             chip2=chip(itypj)
1463             chip12=chip1*chip2
1464             alf1=alp(itypi)
1465             alf2=alp(itypj)
1466             alf12=0.5D0*(alf1+alf2)
1467 C For diagnostics only!!!
1468 c           chi1=0.0D0
1469 c           chi2=0.0D0
1470 c           chi12=0.0D0
1471 c           chip1=0.0D0
1472 c           chip2=0.0D0
1473 c           chip12=0.0D0
1474 c           alf1=0.0D0
1475 c           alf2=0.0D0
1476 c           alf12=0.0D0
1477             xj=c(1,nres+j)-xi
1478             yj=c(2,nres+j)-yi
1479             zj=c(3,nres+j)-zi
1480             dxj=dc_norm(1,nres+j)
1481             dyj=dc_norm(2,nres+j)
1482             dzj=dc_norm(3,nres+j)
1483             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1484 cd          if (icall.eq.0) then
1485 cd            rrsave(ind)=rrij
1486 cd          else
1487 cd            rrij=rrsave(ind)
1488 cd          endif
1489             rij=dsqrt(rrij)
1490 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1491             call sc_angular
1492 C Calculate whole angle-dependent part of epsilon and contributions
1493 C to its derivatives
1494             fac=(rrij*sigsq)**expon2
1495             e1=fac*fac*aa(itypi,itypj)
1496             e2=fac*bb(itypi,itypj)
1497             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1498             eps2der=evdwij*eps3rt
1499             eps3der=evdwij*eps2rt
1500             evdwij=evdwij*eps2rt*eps3rt
1501 #ifdef TSCSC
1502             if (bb(itypi,itypj).gt.0) then
1503                evdw_p=evdw_p+evdwij
1504             else
1505                evdw_m=evdw_m+evdwij
1506             endif
1507 #else
1508             evdw=evdw+evdwij
1509 #endif
1510             if (lprn) then
1511             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1512             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1513 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1514 cd     &        restyp(itypi),i,restyp(itypj),j,
1515 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1516 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1517 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1518 cd     &        evdwij
1519             endif
1520 C Calculate gradient components.
1521             e1=e1*eps1*eps2rt**2*eps3rt**2
1522             fac=-expon*(e1+evdwij)
1523             sigder=fac/sigsq
1524             fac=rrij*fac
1525 C Calculate radial part of the gradient
1526             gg(1)=xj*fac
1527             gg(2)=yj*fac
1528             gg(3)=zj*fac
1529 C Calculate the angular part of the gradient and sum add the contributions
1530 C to the appropriate components of the Cartesian gradient.
1531 #ifdef TSCSC
1532             if (bb(itypi,itypj).gt.0) then
1533                call sc_grad
1534             else
1535                call sc_grad_T
1536             endif
1537 #else
1538             call sc_grad
1539 #endif
1540           enddo      ! j
1541         enddo        ! iint
1542       enddo          ! i
1543 c     stop
1544       return
1545       end
1546 C-----------------------------------------------------------------------------
1547       subroutine egb(evdw,evdw_p,evdw_m)
1548 C
1549 C This subroutine calculates the interaction energy of nonbonded side chains
1550 C assuming the Gay-Berne potential of interaction.
1551 C
1552       implicit real*8 (a-h,o-z)
1553       include 'DIMENSIONS'
1554       include 'COMMON.GEO'
1555       include 'COMMON.VAR'
1556       include 'COMMON.LOCAL'
1557       include 'COMMON.CHAIN'
1558       include 'COMMON.DERIV'
1559       include 'COMMON.NAMES'
1560       include 'COMMON.INTERACT'
1561       include 'COMMON.IOUNITS'
1562       include 'COMMON.CALC'
1563       include 'COMMON.CONTROL'
1564       include 'COMMON.SBRIDGE'
1565       logical lprn
1566        IF (energy_dec) write (iout,'(a)')
1567      &  ' AAi i  AAj  j  1/rij Rtail   evdw   Fcav   eheadtail'
1568 ccccc      energy_dec=.false.
1569 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1570       evdw=0.0D0
1571       evdw_p=0.0D0
1572       evdw_m=0.0D0
1573       lprn=.false.
1574 c     if (icall.eq.0) lprn=.false.
1575       ind=0
1576       do i=iatsc_s,iatsc_e
1577         itypi=itype(i)
1578         itypi1=itype(i+1)
1579         xi=c(1,nres+i)
1580         yi=c(2,nres+i)
1581         zi=c(3,nres+i)
1582         dxi=dc_norm(1,nres+i)
1583         dyi=dc_norm(2,nres+i)
1584         dzi=dc_norm(3,nres+i)
1585 c        dsci_inv=dsc_inv(itypi)
1586         dsci_inv=vbld_inv(i+nres)
1587 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1588 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1589 C
1590 C Calculate SC interaction energy.
1591 C
1592         do iint=1,nint_gr(i)
1593           do j=istart(i,iint),iend(i,iint)
1594             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1595               call dyn_ssbond_ene(i,j,evdwij)
1596               evdw=evdw+evdwij
1597               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1598      &                        'evdw',i,j,evdwij,' ss'
1599             ELSE
1600             ind=ind+1
1601             itypj=itype(j)
1602 c            dscj_inv=dsc_inv(itypj)
1603             dscj_inv=vbld_inv(j+nres)
1604 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1605 c     &       1.0d0/vbld(j+nres)
1606 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1607             sig0ij=sigma(itypi,itypj)
1608             chi1=chi(itypi,itypj)
1609             chi2=chi(itypj,itypi)
1610             chi12=chi1*chi2
1611             chip1=chip(itypi)
1612             chip2=chip(itypj)
1613             chip12=chip1*chip2
1614             alf1=alp(itypi)
1615             alf2=alp(itypj)
1616             alf12=0.5D0*(alf1+alf2)
1617 C For diagnostics only!!!
1618 c           chi1=0.0D0
1619 c           chi2=0.0D0
1620 c           chi12=0.0D0
1621 c           chip1=0.0D0
1622 c           chip2=0.0D0
1623 c           chip12=0.0D0
1624 c           alf1=0.0D0
1625 c           alf2=0.0D0
1626 c           alf12=0.0D0
1627             xj=c(1,nres+j)-xi
1628             yj=c(2,nres+j)-yi
1629             zj=c(3,nres+j)-zi
1630             dxj=dc_norm(1,nres+j)
1631             dyj=dc_norm(2,nres+j)
1632             dzj=dc_norm(3,nres+j)
1633 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1634 c            write (iout,*) "j",j," dc_norm",
1635 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1636             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1637             rij=dsqrt(rrij)
1638
1639 C Calculate angle-dependent terms of energy and contributions to their
1640 C derivatives.
1641             call sc_angular
1642             sigsq=1.0D0/sigsq
1643             sig=sig0ij*dsqrt(sigsq)
1644             rij_shift=1.0D0/rij-sig+sig0ij
1645 c for diagnostics; uncomment
1646 c            rij_shift=1.2*sig0ij
1647 C I hate to put IF's in the loops, but here don't have another choice!!!!
1648             if (rij_shift.le.0.0D0) then
1649               evdw=1.0D20
1650 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1651 cd     &        restyp(itypi),i,restyp(itypj),j,
1652 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1653               return
1654             endif
1655             sigder=-sig*sigsq
1656 c---------------------------------------------------------------
1657             rij_shift=1.0D0/rij_shift
1658             fac=rij_shift**expon
1659             e1=fac*fac*aa(itypi,itypj)
1660             e2=fac*bb(itypi,itypj)
1661             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1662             eps2der=evdwij*eps3rt
1663             eps3der=evdwij*eps2rt
1664 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1665 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1666             evdwij=evdwij*eps2rt*eps3rt
1667 #ifdef TSCSC
1668             if (bb(itypi,itypj).gt.0) then
1669                evdw_p=evdw_p+evdwij
1670             else
1671                evdw_m=evdw_m+evdwij
1672             endif
1673 #else
1674             evdw=evdw+evdwij
1675 #endif
1676             if (lprn) then
1677             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1678             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1679 c!            write (iout,*) "POT = 4 (GB), ENERGY COMPONENTS:"
1680             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1681      &        restyp(itypi),i,restyp(itypj),j,
1682      &        epsi,sigm,chi1,chi2,chip1,chip2,
1683      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1684      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1685      &        evdwij
1686             endif
1687
1688 c!            if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1689 c!     &                        'evdw',i,j,evdwij
1690
1691 C Calculate gradient components.
1692             e1=e1*eps1*eps2rt**2*eps3rt**2
1693             fac=-expon*(e1+evdwij)*rij_shift
1694             sigder=fac*sigder
1695             fac=rij*fac
1696 c            fac=0.0d0
1697 C Calculate the radial part of the gradient
1698             gg(1)=xj*fac
1699             gg(2)=yj*fac
1700             gg(3)=zj*fac
1701 C Calculate angular part of the gradient.
1702 #ifdef TSCSC
1703             if (bb(itypi,itypj).gt.0) then
1704                call sc_grad
1705             else
1706                call sc_grad_T
1707             endif
1708 #else
1709             call sc_grad
1710 #endif
1711        IF (energy_dec) write (iout,'(2(1x,a3,i3),2f6.2,4f20.8)')
1712      &  restyp(itype(i)),i,restyp(itype(j)),j,
1713      &  1.0d0/rij,Rtail,evdwij,Fcav,eheadtail,evdw
1714             ENDIF    ! dyn_ss
1715           enddo      ! j
1716         enddo        ! iint
1717       enddo          ! i
1718 c      write (iout,*) "Number of loop steps in EGB:",ind
1719 cccc      energy_dec=.false.
1720       return
1721       end
1722 C-----------------------------------------------------------------------------
1723       subroutine egbv(evdw,evdw_p,evdw_m)
1724 C
1725 C This subroutine calculates the interaction energy of nonbonded side chains
1726 C assuming the Gay-Berne-Vorobjev potential of interaction.
1727 C
1728       implicit real*8 (a-h,o-z)
1729       include 'DIMENSIONS'
1730       include 'COMMON.GEO'
1731       include 'COMMON.VAR'
1732       include 'COMMON.LOCAL'
1733       include 'COMMON.CHAIN'
1734       include 'COMMON.DERIV'
1735       include 'COMMON.NAMES'
1736       include 'COMMON.INTERACT'
1737       include 'COMMON.IOUNITS'
1738       include 'COMMON.CALC'
1739       common /srutu/ icall
1740       logical lprn
1741       evdw=0.0D0
1742 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1743       evdw=0.0D0
1744       lprn=.false.
1745 c     if (icall.eq.0) lprn=.true.
1746       ind=0
1747       do i=iatsc_s,iatsc_e
1748         itypi=itype(i)
1749         itypi1=itype(i+1)
1750         xi=c(1,nres+i)
1751         yi=c(2,nres+i)
1752         zi=c(3,nres+i)
1753         dxi=dc_norm(1,nres+i)
1754         dyi=dc_norm(2,nres+i)
1755         dzi=dc_norm(3,nres+i)
1756 c        dsci_inv=dsc_inv(itypi)
1757         dsci_inv=vbld_inv(i+nres)
1758 C
1759 C Calculate SC interaction energy.
1760 C
1761         do iint=1,nint_gr(i)
1762           do j=istart(i,iint),iend(i,iint)
1763             ind=ind+1
1764             itypj=itype(j)
1765 c            dscj_inv=dsc_inv(itypj)
1766             dscj_inv=vbld_inv(j+nres)
1767             sig0ij=sigma(itypi,itypj)
1768             r0ij=r0(itypi,itypj)
1769             chi1=chi(itypi,itypj)
1770             chi2=chi(itypj,itypi)
1771             chi12=chi1*chi2
1772             chip1=chip(itypi)
1773             chip2=chip(itypj)
1774             chip12=chip1*chip2
1775             alf1=alp(itypi)
1776             alf2=alp(itypj)
1777             alf12=0.5D0*(alf1+alf2)
1778 C For diagnostics only!!!
1779 c           chi1=0.0D0
1780 c           chi2=0.0D0
1781 c           chi12=0.0D0
1782 c           chip1=0.0D0
1783 c           chip2=0.0D0
1784 c           chip12=0.0D0
1785 c           alf1=0.0D0
1786 c           alf2=0.0D0
1787 c           alf12=0.0D0
1788             xj=c(1,nres+j)-xi
1789             yj=c(2,nres+j)-yi
1790             zj=c(3,nres+j)-zi
1791             dxj=dc_norm(1,nres+j)
1792             dyj=dc_norm(2,nres+j)
1793             dzj=dc_norm(3,nres+j)
1794             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1795             rij=dsqrt(rrij)
1796 C Calculate angle-dependent terms of energy and contributions to their
1797 C derivatives.
1798             call sc_angular
1799             sigsq=1.0D0/sigsq
1800             sig=sig0ij*dsqrt(sigsq)
1801             rij_shift=1.0D0/rij-sig+r0ij
1802 C I hate to put IF's in the loops, but here don't have another choice!!!!
1803             if (rij_shift.le.0.0D0) then
1804               evdw=1.0D20
1805               return
1806             endif
1807             sigder=-sig*sigsq
1808 c---------------------------------------------------------------
1809             rij_shift=1.0D0/rij_shift
1810             fac=rij_shift**expon
1811             e1=fac*fac*aa(itypi,itypj)
1812             e2=fac*bb(itypi,itypj)
1813             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1814             eps2der=evdwij*eps3rt
1815             eps3der=evdwij*eps2rt
1816             fac_augm=rrij**expon
1817             e_augm=augm(itypi,itypj)*fac_augm
1818             evdwij=evdwij*eps2rt*eps3rt
1819 #ifdef TSCSC
1820             if (bb(itypi,itypj).gt.0) then
1821                evdw_p=evdw_p+evdwij+e_augm
1822             else
1823                evdw_m=evdw_m+evdwij+e_augm
1824             endif
1825 #else
1826             evdw=evdw+evdwij+e_augm
1827 #endif
1828             if (lprn) then
1829             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1830             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1831             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1832      &        restyp(itypi),i,restyp(itypj),j,
1833      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1834      &        chi1,chi2,chip1,chip2,
1835      &        eps1,eps2rt**2,eps3rt**2,
1836      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1837      &        evdwij+e_augm
1838             endif
1839 C Calculate gradient components.
1840             e1=e1*eps1*eps2rt**2*eps3rt**2
1841             fac=-expon*(e1+evdwij)*rij_shift
1842             sigder=fac*sigder
1843             fac=rij*fac-2*expon*rrij*e_augm
1844 C Calculate the radial part of the gradient
1845             gg(1)=xj*fac
1846             gg(2)=yj*fac
1847             gg(3)=zj*fac
1848 C Calculate angular part of the gradient.
1849 #ifdef TSCSC
1850             if (bb(itypi,itypj).gt.0) then
1851                call sc_grad
1852             else
1853                call sc_grad_T
1854             endif
1855 #else
1856             call sc_grad
1857 #endif
1858           enddo      ! j
1859         enddo        ! iint
1860       enddo          ! i
1861       end
1862
1863 C-----------------------------------------------------------------------------
1864
1865
1866       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1867 C
1868 C This subroutine calculates the interaction energy of nonbonded side chains
1869 C assuming the Gay-Berne potential of interaction.
1870 C
1871        IMPLICIT NONE
1872        INCLUDE 'DIMENSIONS'
1873        INCLUDE 'COMMON.CALC'
1874        INCLUDE 'COMMON.CONTROL'
1875        INCLUDE 'COMMON.CHAIN'
1876        INCLUDE 'COMMON.DERIV'
1877        INCLUDE 'COMMON.EMP'
1878        INCLUDE 'COMMON.GEO'
1879        INCLUDE 'COMMON.INTERACT'
1880        INCLUDE 'COMMON.IOUNITS'
1881        INCLUDE 'COMMON.LOCAL'
1882        INCLUDE 'COMMON.NAMES'
1883        INCLUDE 'COMMON.VAR'
1884        logical lprn
1885        double precision scalar
1886        double precision ener(4)
1887        integer troll
1888
1889        IF (energy_dec) write (iout,'(a)')
1890      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1891      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1892        evdw   = 0.0D0
1893        evdw_p = 0.0D0
1894        evdw_m = 0.0D0
1895 c DIAGNOSTICS
1896 ccccc      energy_dec=.false.
1897 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1898 c      lprn   = .false.
1899 c     if (icall.eq.0) lprn=.false.
1900 c END DIAGNOSTICS
1901 c      ind = 0
1902        DO i = iatsc_s, iatsc_e
1903         itypi  = itype(i)
1904 c        itypi1 = itype(i+1)
1905         dxi    = dc_norm(1,nres+i)
1906         dyi    = dc_norm(2,nres+i)
1907         dzi    = dc_norm(3,nres+i)
1908 c        dsci_inv=dsc_inv(itypi)
1909         dsci_inv = vbld_inv(i+nres)
1910 c        DO k = 1, 3
1911 c         ctail(k,1) = c(k, i+nres)
1912 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1913 c        END DO
1914         xi=c(1,nres+i)
1915         yi=c(2,nres+i)
1916         zi=c(3,nres+i)
1917 c!-------------------------------------------------------------------
1918 C Calculate SC interaction energy.
1919         DO iint = 1, nint_gr(i)
1920          DO j = istart(i,iint), iend(i,iint)
1921 c! initialize variables for electrostatic gradients
1922           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1923 c            ind=ind+1
1924 c            dscj_inv = dsc_inv(itypj)
1925           dscj_inv = vbld_inv(j+nres)
1926 c! rij holds 1/(distance of Calpha atoms)
1927           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1928           rij  = dsqrt(rrij)
1929 c!-------------------------------------------------------------------
1930 C Calculate angle-dependent terms of energy and contributions to their
1931 C derivatives.
1932
1933 #IFDEF CHECK_MOMO
1934 c!      DO troll = 10, 5000
1935 c!      om1    = 0.0d0
1936 c!      om2    = 0.0d0
1937 c!      om12   = 1.0d0
1938 c!      sqom1  = om1 * om1
1939 c!      sqom2  = om2 * om2
1940 c!      sqom12 = om12 * om12
1941 c!      rij    = 5.0d0 / troll
1942 c!      rrij   = rij * rij
1943 c!      Rtail  = troll / 5.0d0
1944 c!      Rhead  = troll / 5.0d0
1945 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1946 c!      Rtail = dsqrt((Rtail**2)
1947 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1948 c!      rij = 1.0d0/Rtail
1949 c!      rrij = rij * rij
1950 #ENDIF
1951           CALL sc_angular
1952 c! this should be in elgrad_init but om's are calculated by sc_angular
1953 c! which in turn is used by older potentials
1954 c! which proves how tangled UNRES code is >.<
1955 c! om = omega, sqom = om^2
1956           sqom1  = om1 * om1
1957           sqom2  = om2 * om2
1958           sqom12 = om12 * om12
1959
1960 c! now we calculate EGB - Gey-Berne
1961 c! It will be summed up in evdwij and saved in evdw
1962           sigsq     = 1.0D0  / sigsq
1963           sig       = sig0ij * dsqrt(sigsq)
1964 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1965           rij_shift = Rtail - sig + sig0ij
1966           IF (rij_shift.le.0.0D0) THEN
1967            evdw = 1.0D20
1968            RETURN
1969           END IF
1970           sigder = -sig * sigsq
1971           rij_shift = 1.0D0 / rij_shift
1972           fac       = rij_shift**expon
1973           c1        = fac  * fac * aa(itypi,itypj)
1974 c!          c1        = 0.0d0
1975           c2        = fac  * bb(itypi,itypj)
1976 c!          c2        = 0.0d0
1977           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1978           eps2der   = eps3rt * evdwij
1979           eps3der   = eps2rt * evdwij
1980 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1981           evdwij    = eps2rt * eps3rt * evdwij
1982 c!      evdwij = 0.0d0
1983 c!      write (*,*) "Gey Berne = ", evdwij
1984 #ifdef TSCSC
1985           IF (bb(itypi,itypj).gt.0) THEN
1986            evdw_p = evdw_p + evdwij
1987           ELSE
1988            evdw_m = evdw_m + evdwij
1989           END IF
1990 #else
1991           evdw = evdw
1992      &         + evdwij
1993 #endif
1994 c!-------------------------------------------------------------------
1995 c! Calculate some components of GGB
1996           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1997           fac    = -expon * (c1 + evdwij) * rij_shift
1998           sigder = fac * sigder
1999 c!          fac    = rij * fac
2000 c! Calculate distance derivative
2001 c!          gg(1) = xj * fac
2002 c!          gg(2) = yj * fac
2003 c!          gg(3) = zj * fac
2004           gg(1) = fac
2005           gg(2) = fac
2006           gg(3) = fac
2007 c!      write (*,*) "gg(1) = ", gg(1)
2008 c!      write (*,*) "gg(2) = ", gg(2)
2009 c!      write (*,*) "gg(3) = ", gg(3)
2010 c! The angular derivatives of GGB are brought together in sc_grad
2011 c!-------------------------------------------------------------------
2012 c! Fcav
2013 c!
2014 c! Catch gly-gly interactions to skip calculation of something that
2015 c! does not exist
2016
2017       IF (itypi.eq.10.and.itypj.eq.10) THEN
2018        Fcav = 0.0d0
2019        dFdR = 0.0d0
2020        dCAVdOM1  = 0.0d0
2021        dCAVdOM2  = 0.0d0
2022        dCAVdOM12 = 0.0d0
2023       ELSE
2024
2025 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
2026        fac = chis1 * sqom1 + chis2 * sqom2
2027      &     - 2.0d0 * chis12 * om1 * om2 * om12
2028 c! we will use pom later in Gcav, so dont mess with it!
2029        pom = 1.0d0 - chis1 * chis2 * sqom12
2030
2031        Lambf = (1.0d0 - (fac / pom))
2032        Lambf = dsqrt(Lambf)
2033
2034
2035        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
2036 c!       write (*,*) "sparrow = ", sparrow
2037        Chif = Rtail * sparrow
2038        ChiLambf = Chif * Lambf
2039        eagle = dsqrt(ChiLambf)
2040        bat = ChiLambf ** 11.0d0
2041
2042        top = b1 * ( eagle + b2 * ChiLambf - b3 )
2043        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
2044        botsq = bot * bot
2045
2046 c!      write (*,*) "sig1 = ",sig1
2047 c!      write (*,*) "sig2 = ",sig2
2048 c!      write (*,*) "Rtail = ",Rtail
2049 c!      write (*,*) "sparrow = ",sparrow
2050 c!      write (*,*) "Chis1 = ", chis1
2051 c!      write (*,*) "Chis2 = ", chis2
2052 c!      write (*,*) "Chis12 = ", chis12
2053 c!      write (*,*) "om1 = ", om1
2054 c!      write (*,*) "om2 = ", om2
2055 c!      write (*,*) "om12 = ", om12
2056 c!      write (*,*) "sqom1 = ", sqom1
2057 c!      write (*,*) "sqom2 = ", sqom2
2058 c!      write (*,*) "sqom12 = ", sqom12
2059 c!      write (*,*) "Lambf = ",Lambf
2060 c!      write (*,*) "b1 = ",b1
2061 c!      write (*,*) "b2 = ",b2
2062 c!      write (*,*) "b3 = ",b3
2063 c!      write (*,*) "b4 = ",b4
2064 c!      write (*,*) "top = ",top
2065 c!      write (*,*) "bot = ",bot
2066        Fcav = top / bot
2067 c!       Fcav = 0.0d0
2068 c!      write (*,*) "Fcav = ", Fcav
2069 c!-------------------------------------------------------------------
2070 c! derivative of Fcav is Gcav...
2071 c!---------------------------------------------------
2072
2073        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
2074        dbot = 12.0d0 * b4 * bat * Lambf
2075        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
2076 c!       dFdR = 0.0d0
2077 c!      write (*,*) "dFcav/dR = ", dFdR
2078
2079        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
2080        dbot = 12.0d0 * b4 * bat * Chif
2081        eagle = Lambf * pom
2082        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
2083        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
2084        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
2085      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
2086
2087        dFdL = ((dtop * bot - top * dbot) / botsq)
2088 c!       dFdL = 0.0d0
2089        dCAVdOM1  = dFdL * ( dFdOM1 )
2090        dCAVdOM2  = dFdL * ( dFdOM2 )
2091        dCAVdOM12 = dFdL * ( dFdOM12 )
2092 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
2093 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
2094 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
2095 c!      write (*,*) ""
2096 c!-------------------------------------------------------------------
2097 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
2098 c! Pom is used here to project the gradient vector into
2099 c! cartesian coordinates and at the same time contains
2100 c! dXhb/dXsc derivative (for charged amino acids
2101 c! location of hydrophobic centre of interaction is not
2102 c! the same as geometric centre of side chain, this
2103 c! derivative takes that into account)
2104 c! derivatives of omega angles will be added in sc_grad
2105
2106        DO k= 1, 3
2107         ertail(k) = Rtail_distance(k)/Rtail
2108        END DO
2109        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
2110        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
2111        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2112        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2113        DO k = 1, 3
2114 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
2115 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
2116         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
2117         gvdwx(k,i) = gvdwx(k,i)
2118      &             - (( dFdR + gg(k) ) * pom)
2119 c!     &             - ( dFdR * pom )
2120         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
2121         gvdwx(k,j) = gvdwx(k,j)
2122      &             + (( dFdR + gg(k) ) * pom)
2123 c!     &             + ( dFdR * pom )
2124
2125         gvdwc(k,i) = gvdwc(k,i)
2126      &             - (( dFdR + gg(k) ) * ertail(k))
2127 c!     &             - ( dFdR * ertail(k))
2128
2129         gvdwc(k,j) = gvdwc(k,j)
2130      &             + (( dFdR + gg(k) ) * ertail(k))
2131 c!     &             + ( dFdR * ertail(k))
2132
2133         gg(k) = 0.0d0
2134 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
2135 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
2136       END DO
2137
2138 c!-------------------------------------------------------------------
2139 c! Compute head-head and head-tail energies for each state
2140
2141           isel = iabs(Qi) + iabs(Qj)
2142           IF (isel.eq.0) THEN
2143 c! No charges - do nothing
2144            eheadtail = 0.0d0
2145
2146           ELSE IF (isel.eq.4) THEN
2147 c! Calculate dipole-dipole interactions
2148            CALL edd(ecl)
2149            eheadtail = ECL
2150
2151           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
2152 c! Charge-nonpolar interactions
2153            CALL eqn(epol)
2154            eheadtail = epol
2155
2156           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
2157 c! Nonpolar-charge interactions
2158            CALL enq(epol)
2159            eheadtail = epol
2160
2161           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
2162 c! Charge-dipole interactions
2163            CALL eqd(ecl, elj, epol)
2164            eheadtail = ECL + elj + epol
2165
2166           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
2167 c! Dipole-charge interactions
2168            CALL edq(ecl, elj, epol)
2169            eheadtail = ECL + elj + epol
2170
2171           ELSE IF ((isel.eq.2.and.
2172      &          iabs(Qi).eq.1).and.
2173      &          nstate(itypi,itypj).eq.1) THEN
2174 c! Same charge-charge interaction ( +/+ or -/- )
2175            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
2176            eheadtail = ECL + Egb + Epol + Fisocav + Elj
2177
2178           ELSE IF ((isel.eq.2.and.
2179      &          iabs(Qi).eq.1).and.
2180      &          nstate(itypi,itypj).ne.1) THEN
2181 c! Different charge-charge interaction ( +/- or -/+ )
2182            CALL energy_quad
2183      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
2184           END IF
2185        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
2186 c!      write (*,*) "evdw = ", evdw
2187 c!      write (*,*) "Fcav = ", Fcav
2188 c!      write (*,*) "eheadtail = ", eheadtail
2189        evdw = evdw
2190      &      + Fcav
2191      &      + eheadtail
2192
2193        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
2194      &  restyp(itype(i)),i,restyp(itype(j)),j,
2195      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
2196      &  Equad,evdw
2197        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
2198      &  restyp(itype(i)),i,restyp(itype(j)),j,
2199      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
2200      &  Equad,evdw
2201 #IFDEF CHECK_MOMO
2202        evdw = 0.0d0
2203        END DO ! troll
2204 #ENDIF
2205
2206 c!-------------------------------------------------------------------
2207 c! As all angular derivatives are done, now we sum them up,
2208 c! then transform and project into cartesian vectors and add to gvdwc
2209 c! We call sc_grad always, with the exception of +/- interaction.
2210 c! This is because energy_quad subroutine needs to handle
2211 c! this job in his own way.
2212 c! This IS probably not very efficient and SHOULD be optimised
2213 c! but it will require major restructurization of emomo
2214 c! so it will be left as it is for now
2215 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
2216        IF (nstate(itypi,itypj).eq.1) THEN
2217 #ifdef TSCSC
2218         IF (bb(itypi,itypj).gt.0) THEN
2219          CALL sc_grad
2220         ELSE
2221          CALL sc_grad_T
2222         END IF
2223 #else
2224         CALL sc_grad
2225 #endif
2226        END IF
2227 c!-------------------------------------------------------------------
2228 c! NAPISY KONCOWE
2229          END DO   ! j
2230         END DO    ! iint
2231        END DO     ! i
2232 c      write (iout,*) "Number of loop steps in EGB:",ind
2233 c      energy_dec=.false.
2234        RETURN
2235       END SUBROUTINE emomo
2236 c! END OF MOMO
2237
2238
2239 C-----------------------------------------------------------------------------
2240
2241
2242       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
2243        IMPLICIT NONE
2244        INCLUDE 'DIMENSIONS'
2245        INCLUDE 'COMMON.CALC'
2246        INCLUDE 'COMMON.CHAIN'
2247        INCLUDE 'COMMON.CONTROL'
2248        INCLUDE 'COMMON.DERIV'
2249        INCLUDE 'COMMON.EMP'
2250        INCLUDE 'COMMON.GEO'
2251        INCLUDE 'COMMON.INTERACT'
2252        INCLUDE 'COMMON.IOUNITS'
2253        INCLUDE 'COMMON.LOCAL'
2254        INCLUDE 'COMMON.NAMES'
2255        INCLUDE 'COMMON.VAR'
2256        double precision scalar, facd3, facd4, federmaus, adler
2257 c! Epol and Gpol analytical parameters
2258        alphapol1 = alphapol(itypi,itypj)
2259        alphapol2 = alphapol(itypj,itypi)
2260 c! Fisocav and Gisocav analytical parameters
2261        al1  = alphiso(1,itypi,itypj)
2262        al2  = alphiso(2,itypi,itypj)
2263        al3  = alphiso(3,itypi,itypj)
2264        al4  = alphiso(4,itypi,itypj)
2265        csig = (1.0d0
2266      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
2267      &      + sigiso2(itypi,itypj)**2.0d0))
2268 c!
2269        pis  = sig0head(itypi,itypj)
2270        eps_head = epshead(itypi,itypj)
2271        Rhead_sq = Rhead * Rhead
2272 c! R1 - distance between head of ith side chain and tail of jth sidechain
2273 c! R2 - distance between head of jth side chain and tail of ith sidechain
2274        R1 = 0.0d0
2275        R2 = 0.0d0
2276        DO k = 1, 3
2277 c! Calculate head-to-tail distances needed by Epol
2278         R1=R1+(ctail(k,2)-chead(k,1))**2
2279         R2=R2+(chead(k,2)-ctail(k,1))**2
2280        END DO
2281 c! Pitagoras
2282        R1 = dsqrt(R1)
2283        R2 = dsqrt(R2)
2284
2285 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2286 c!     &        +dhead(1,1,itypi,itypj))**2))
2287 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2288 c!     &        +dhead(2,1,itypi,itypj))**2))
2289
2290 c!-------------------------------------------------------------------
2291 c! Coulomb electrostatic interaction
2292        Ecl = (332.0d0 * Qij) / Rhead
2293 c! derivative of Ecl is Gcl...
2294        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
2295        dGCLdOM1 = 0.0d0
2296        dGCLdOM2 = 0.0d0
2297        dGCLdOM12 = 0.0d0
2298 c!-------------------------------------------------------------------
2299 c! Generalised Born Solvent Polarization
2300 c! Charged head polarizes the solvent
2301        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
2302        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
2303        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
2304 c! Derivative of Egb is Ggb...
2305        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
2306        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
2307      &        / ( 2.0d0 * Fgb )
2308        dGGBdR = dGGBdFGB * dFGBdR
2309 c!-------------------------------------------------------------------
2310 c! Fisocav - isotropic cavity creation term
2311 c! or "how much energy it costs to put charged head in water"
2312        pom = Rhead * csig
2313        top = al1 * (dsqrt(pom) + al2 * pom - al3)
2314        bot = (1.0d0 + al4 * pom**12.0d0)
2315        botsq = bot * bot
2316        FisoCav = top / bot
2317 c!      write (*,*) "Rhead = ",Rhead
2318 c!      write (*,*) "csig = ",csig
2319 c!      write (*,*) "pom = ",pom
2320 c!      write (*,*) "al1 = ",al1
2321 c!      write (*,*) "al2 = ",al2
2322 c!      write (*,*) "al3 = ",al3
2323 c!      write (*,*) "al4 = ",al4
2324 c!      write (*,*) "top = ",top
2325 c!      write (*,*) "bot = ",bot
2326 c! Derivative of Fisocav is GCV...
2327        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
2328        dbot = 12.0d0 * al4 * pom ** 11.0d0
2329        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
2330 c!-------------------------------------------------------------------
2331 c! Epol
2332 c! Polarization energy - charged heads polarize hydrophobic "neck"
2333        MomoFac1 = (1.0d0 - chi1 * sqom2)
2334        MomoFac2 = (1.0d0 - chi2 * sqom1)
2335        RR1  = ( R1 * R1 ) / MomoFac1
2336        RR2  = ( R2 * R2 ) / MomoFac2
2337        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2338        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
2339        fgb1 = sqrt( RR1 + a12sq * ee1 )
2340        fgb2 = sqrt( RR2 + a12sq * ee2 )
2341        epol = 332.0d0 * eps_inout_fac * (
2342      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
2343 c!       epol = 0.0d0
2344 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
2345 c       write (*,*) "alphapol1 = ", alphapol1
2346 c       write (*,*) "alphapol2 = ", alphapol2
2347 c       write (*,*) "fgb1 = ", fgb1
2348 c       write (*,*) "fgb2 = ", fgb2
2349 c       write (*,*) "epol = ", epol
2350 c! derivative of Epol is Gpol...
2351        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2352      &          / (fgb1 ** 5.0d0)
2353        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2354      &          / (fgb2 ** 5.0d0)
2355        dFGBdR1 = ( (R1 / MomoFac1)
2356      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2357      &        / ( 2.0d0 * fgb1 )
2358        dFGBdR2 = ( (R2 / MomoFac2)
2359      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2360      &        / ( 2.0d0 * fgb2 )
2361        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2362      &          * ( 2.0d0 - 0.5d0 * ee1) )
2363      &          / ( 2.0d0 * fgb1 )
2364        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2365      &          * ( 2.0d0 - 0.5d0 * ee2) )
2366      &          / ( 2.0d0 * fgb2 )
2367        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2368 c!       dPOLdR1 = 0.0d0
2369        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2370 c!       dPOLdR2 = 0.0d0
2371        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2372 c!       dPOLdOM1 = 0.0d0
2373        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2374 c!       dPOLdOM2 = 0.0d0
2375 c!-------------------------------------------------------------------
2376 c! Elj
2377 c! Lennard-Jones 6-12 interaction between heads
2378        pom = (pis / Rhead)**6.0d0
2379        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2380 c! derivative of Elj is Glj
2381        dGLJdR = 4.0d0 * eps_head
2382      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2383      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2384 c!-------------------------------------------------------------------
2385 c! Return the results
2386 c! These things do the dRdX derivatives, that is
2387 c! allow us to change what we see from function that changes with
2388 c! distance to function that changes with LOCATION (of the interaction
2389 c! site)
2390        DO k = 1, 3
2391         erhead(k) = Rhead_distance(k)/Rhead
2392         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2393         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2394        END DO
2395
2396        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2397        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2398        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2399        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2400        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2401        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2402        facd1 = d1 * vbld_inv(i+nres)
2403        facd2 = d2 * vbld_inv(j+nres)
2404        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2405        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2406
2407 c! Now we add appropriate partial derivatives (one in each dimension)
2408        DO k = 1, 3
2409         hawk   = (erhead_tail(k,1) +
2410      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
2411         condor = (erhead_tail(k,2) +
2412      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2413
2414         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2415         gvdwx(k,i) = gvdwx(k,i)
2416      &             - dGCLdR * pom
2417      &             - dGGBdR * pom
2418      &             - dGCVdR * pom
2419      &             - dPOLdR1 * hawk
2420      &             - dPOLdR2 * (erhead_tail(k,2)
2421      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2422      &             - dGLJdR * pom
2423
2424         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2425         gvdwx(k,j) = gvdwx(k,j)
2426      &             + dGCLdR * pom
2427      &             + dGGBdR * pom
2428      &             + dGCVdR * pom
2429      &             + dPOLdR1 * (erhead_tail(k,1)
2430      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2431      &             + dPOLdR2 * condor
2432      &             + dGLJdR * pom
2433
2434         gvdwc(k,i) = gvdwc(k,i)
2435      &             - dGCLdR * erhead(k)
2436      &             - dGGBdR * erhead(k)
2437      &             - dGCVdR * erhead(k)
2438      &             - dPOLdR1 * erhead_tail(k,1)
2439      &             - dPOLdR2 * erhead_tail(k,2)
2440      &             - dGLJdR * erhead(k)
2441
2442         gvdwc(k,j) = gvdwc(k,j)
2443      &             + dGCLdR * erhead(k)
2444      &             + dGGBdR * erhead(k)
2445      &             + dGCVdR * erhead(k)
2446      &             + dPOLdR1 * erhead_tail(k,1)
2447      &             + dPOLdR2 * erhead_tail(k,2)
2448      &             + dGLJdR * erhead(k)
2449
2450        END DO
2451        RETURN
2452       END SUBROUTINE eqq
2453 c!-------------------------------------------------------------------
2454       SUBROUTINE energy_quad
2455      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
2456        IMPLICIT NONE
2457        INCLUDE 'DIMENSIONS'
2458        INCLUDE 'COMMON.CALC'
2459        INCLUDE 'COMMON.CHAIN'
2460        INCLUDE 'COMMON.CONTROL'
2461        INCLUDE 'COMMON.DERIV'
2462        INCLUDE 'COMMON.EMP'
2463        INCLUDE 'COMMON.GEO'
2464        INCLUDE 'COMMON.INTERACT'
2465        INCLUDE 'COMMON.IOUNITS'
2466        INCLUDE 'COMMON.LOCAL'
2467        INCLUDE 'COMMON.NAMES'
2468        INCLUDE 'COMMON.VAR'
2469        double precision scalar
2470        double precision ener(4)
2471        double precision dcosom1(3),dcosom2(3)
2472 c! used in Epol derivatives
2473        double precision facd3, facd4
2474        double precision federmaus, adler
2475 c! Epol and Gpol analytical parameters
2476        alphapol1 = alphapol(itypi,itypj)
2477        alphapol2 = alphapol(itypj,itypi)
2478 c! Fisocav and Gisocav analytical parameters
2479        al1  = alphiso(1,itypi,itypj)
2480        al2  = alphiso(2,itypi,itypj)
2481        al3  = alphiso(3,itypi,itypj)
2482        al4  = alphiso(4,itypi,itypj)
2483        csig = (1.0d0
2484      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
2485      &      + sigiso2(itypi,itypj)**2.0d0))
2486 c!
2487        w1   = wqdip(1,itypi,itypj)
2488        w2   = wqdip(2,itypi,itypj)
2489        pis  = sig0head(itypi,itypj)
2490        eps_head = epshead(itypi,itypj)
2491 c! First things first:
2492 c! We need to do sc_grad's job with GB and Fcav
2493        eom1  =
2494      &         eps2der * eps2rt_om1
2495      &       - 2.0D0 * alf1 * eps3der
2496      &       + sigder * sigsq_om1
2497      &       + dCAVdOM1
2498        eom2  =
2499      &         eps2der * eps2rt_om2
2500      &       + 2.0D0 * alf2 * eps3der
2501      &       + sigder * sigsq_om2
2502      &       + dCAVdOM2
2503        eom12 =
2504      &         evdwij  * eps1_om12
2505      &       + eps2der * eps2rt_om12
2506      &       - 2.0D0 * alf12 * eps3der
2507      &       + sigder *sigsq_om12
2508      &       + dCAVdOM12
2509 c! now some magical transformations to project gradient into
2510 c! three cartesian vectors
2511        DO k = 1, 3
2512         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
2513         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
2514         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
2515 c! this acts on hydrophobic center of interaction
2516         gvdwx(k,i)= gvdwx(k,i) - gg(k)
2517      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2518      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2519         gvdwx(k,j)= gvdwx(k,j) + gg(k)
2520      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2521      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2522 c! this acts on Calpha
2523         gvdwc(k,i)=gvdwc(k,i)-gg(k)
2524         gvdwc(k,j)=gvdwc(k,j)+gg(k)
2525        END DO
2526 c! sc_grad is done, now we will compute
2527        eheadtail = 0.0d0
2528        eom1 = 0.0d0
2529        eom2 = 0.0d0
2530        eom12 = 0.0d0
2531
2532 c! ENERGY DEBUG
2533 c!       ii = 1
2534 c!       jj = 1
2535 c!       d1 = dhead(1, 1, itypi, itypj)
2536 c!       d2 = dhead(2, 1, itypi, itypj)
2537 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2538 c!     &        +dhead(1,ii,itypi,itypj))**2))
2539 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2540 c!     &        +dhead(2,jj,itypi,itypj))**2))
2541 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
2542 c! END OF ENERGY DEBUG
2543 c*************************************************************
2544        DO istate = 1, nstate(itypi,itypj)
2545 c*************************************************************
2546         IF (istate.ne.1) THEN
2547          IF (istate.lt.3) THEN
2548           ii = 1
2549          ELSE
2550           ii = 2
2551          END IF
2552         jj = istate/ii
2553         d1 = dhead(1,ii,itypi,itypj)
2554         d2 = dhead(2,jj,itypi,itypj)
2555         DO k = 1,3
2556          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2557          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2558          Rhead_distance(k) = chead(k,2) - chead(k,1)
2559         END DO
2560 c! pitagoras (root of sum of squares)
2561         Rhead = dsqrt(
2562      &          (Rhead_distance(1)*Rhead_distance(1))
2563      &        + (Rhead_distance(2)*Rhead_distance(2))
2564      &        + (Rhead_distance(3)*Rhead_distance(3)))
2565         END IF
2566         Rhead_sq = Rhead * Rhead
2567
2568 c! R1 - distance between head of ith side chain and tail of jth sidechain
2569 c! R2 - distance between head of jth side chain and tail of ith sidechain
2570         R1 = 0.0d0
2571         R2 = 0.0d0
2572         DO k = 1, 3
2573 c! Calculate head-to-tail distances
2574          R1=R1+(ctail(k,2)-chead(k,1))**2
2575          R2=R2+(chead(k,2)-ctail(k,1))**2
2576         END DO
2577 c! Pitagoras
2578         R1 = dsqrt(R1)
2579         R2 = dsqrt(R2)
2580
2581 c! ENERGY DEBUG
2582 c!      write (*,*) "istate = ", istate
2583 c!      write (*,*) "ii = ", ii
2584 c!      write (*,*) "jj = ", jj
2585 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2586 c!     &        +dhead(1,ii,itypi,itypj))**2))
2587 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2588 c!     &        +dhead(2,jj,itypi,itypj))**2))
2589 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
2590 c!      Rhead_sq = Rhead * Rhead
2591 c!      write (*,*) "d1 = ",d1
2592 c!      write (*,*) "d2 = ",d2
2593 c!      write (*,*) "R1 = ",R1
2594 c!      write (*,*) "R2 = ",R2
2595 c!      write (*,*) "Rhead = ",Rhead
2596 c! END OF ENERGY DEBUG
2597
2598 c!-------------------------------------------------------------------
2599 c! Coulomb electrostatic interaction
2600         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
2601 c!        Ecl = 0.0d0
2602 c!        write (*,*) "Ecl = ", Ecl
2603 c! derivative of Ecl is Gcl...
2604         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
2605 c!        dGCLdR = 0.0d0
2606         dGCLdOM1 = 0.0d0
2607         dGCLdOM2 = 0.0d0
2608         dGCLdOM12 = 0.0d0
2609 c!-------------------------------------------------------------------
2610 c! Generalised Born Solvent Polarization
2611         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
2612         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
2613         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
2614 c!        Egb = 0.0d0
2615 c!      write (*,*) "a1*a2 = ", a12sq
2616 c!      write (*,*) "Rhead = ", Rhead
2617 c!      write (*,*) "Rhead_sq = ", Rhead_sq
2618 c!      write (*,*) "ee = ", ee
2619 c!      write (*,*) "Fgb = ", Fgb
2620 c!      write (*,*) "fac = ", eps_inout_fac
2621 c!      write (*,*) "Qij = ", Qij
2622 c!      write (*,*) "Egb = ", Egb
2623 c! Derivative of Egb is Ggb...
2624 c! dFGBdR is used by Quad's later...
2625         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
2626         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
2627      &         / ( 2.0d0 * Fgb )
2628         dGGBdR = dGGBdFGB * dFGBdR
2629 c!        dGGBdR = 0.0d0
2630 c!-------------------------------------------------------------------
2631 c! Fisocav - isotropic cavity creation term
2632         pom = Rhead * csig
2633         top = al1 * (dsqrt(pom) + al2 * pom - al3)
2634         bot = (1.0d0 + al4 * pom**12.0d0)
2635         botsq = bot * bot
2636         FisoCav = top / bot
2637 c!        FisoCav = 0.0d0
2638 c!      write (*,*) "pom = ",pom
2639 c!      write (*,*) "al1 = ",al1
2640 c!      write (*,*) "al2 = ",al2
2641 c!      write (*,*) "al3 = ",al3
2642 c!      write (*,*) "al4 = ",al4
2643 c!      write (*,*) "top = ",top
2644 c!      write (*,*) "bot = ",bot
2645 c!      write (*,*) "Fisocav = ", Fisocav
2646
2647 c! Derivative of Fisocav is GCV...
2648         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
2649         dbot = 12.0d0 * al4 * pom ** 11.0d0
2650         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
2651 c!        dGCVdR = 0.0d0
2652 c!-------------------------------------------------------------------
2653 c! Polarization energy
2654 c! Epol
2655         MomoFac1 = (1.0d0 - chi1 * sqom2)
2656         MomoFac2 = (1.0d0 - chi2 * sqom1)
2657         RR1  = ( R1 * R1 ) / MomoFac1
2658         RR2  = ( R2 * R2 ) / MomoFac2
2659         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2660         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
2661         fgb1 = sqrt( RR1 + a12sq * ee1 )
2662         fgb2 = sqrt( RR2 + a12sq * ee2 )
2663         epol = 332.0d0 * eps_inout_fac * (
2664      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
2665 c!        epol = 0.0d0
2666 c! derivative of Epol is Gpol...
2667         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2668      &            / (fgb1 ** 5.0d0)
2669         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2670      &            / (fgb2 ** 5.0d0)
2671         dFGBdR1 = ( (R1 / MomoFac1)
2672      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
2673      &          / ( 2.0d0 * fgb1 )
2674         dFGBdR2 = ( (R2 / MomoFac2)
2675      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
2676      &          / ( 2.0d0 * fgb2 )
2677         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2678      &           * ( 2.0d0 - 0.5d0 * ee1) )
2679      &           / ( 2.0d0 * fgb1 )
2680         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2681      &           * ( 2.0d0 - 0.5d0 * ee2) )
2682      &           / ( 2.0d0 * fgb2 )
2683         dPOLdR1 = dPOLdFGB1 * dFGBdR1
2684 c!        dPOLdR1 = 0.0d0
2685         dPOLdR2 = dPOLdFGB2 * dFGBdR2
2686 c!        dPOLdR2 = 0.0d0
2687         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2688 c!        dPOLdOM1 = 0.0d0
2689         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2690 c!        dPOLdOM2 = 0.0d0
2691 c!-------------------------------------------------------------------
2692 c! Elj
2693         pom = (pis / Rhead)**6.0d0
2694         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2695 c!        Elj = 0.0d0
2696 c! derivative of Elj is Glj
2697         dGLJdR = 4.0d0 * eps_head
2698      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2699      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2700 c!        dGLJdR = 0.0d0
2701 c!-------------------------------------------------------------------
2702 c! Equad
2703        IF (Wqd.ne.0.0d0) THEN
2704         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
2705      &        - 37.5d0  * ( sqom1 + sqom2 )
2706      &        + 157.5d0 * ( sqom1 * sqom2 )
2707      &        - 45.0d0  * om1*om2*om12
2708         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
2709         Equad = fac * Beta1
2710 c!        Equad = 0.0d0
2711 c! derivative of Equad...
2712         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
2713 c!        dQUADdR = 0.0d0
2714         dQUADdOM1 = fac
2715      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
2716 c!        dQUADdOM1 = 0.0d0
2717         dQUADdOM2 = fac
2718      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
2719 c!        dQUADdOM2 = 0.0d0
2720         dQUADdOM12 = fac
2721      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
2722 c!        dQUADdOM12 = 0.0d0
2723         ELSE
2724          Beta1 = 0.0d0
2725          Equad = 0.0d0
2726         END IF
2727 c!-------------------------------------------------------------------
2728 c! Return the results
2729 c! Angular stuff
2730         eom1 = dPOLdOM1 + dQUADdOM1
2731         eom2 = dPOLdOM2 + dQUADdOM2
2732         eom12 = dQUADdOM12
2733 c! now some magical transformations to project gradient into
2734 c! three cartesian vectors
2735         DO k = 1, 3
2736          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
2737          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
2738          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
2739         END DO
2740 c! Radial stuff
2741         DO k = 1, 3
2742          erhead(k) = Rhead_distance(k)/Rhead
2743          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2744          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2745         END DO
2746         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2747         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2748         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2749         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2750         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2751         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2752         facd1 = d1 * vbld_inv(i+nres)
2753         facd2 = d2 * vbld_inv(j+nres)
2754         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2755         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2756 c! Throw the results into gheadtail which holds gradients
2757 c! for each micro-state
2758         DO k = 1, 3
2759          hawk   = erhead_tail(k,1) +
2760      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
2761          condor = erhead_tail(k,2) +
2762      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
2763
2764          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2765 c! this acts on hydrophobic center of interaction
2766          gheadtail(k,1,1) = gheadtail(k,1,1)
2767      &                    - dGCLdR * pom
2768      &                    - dGGBdR * pom
2769      &                    - dGCVdR * pom
2770      &                    - dPOLdR1 * hawk
2771      &                    - dPOLdR2 * (erhead_tail(k,2)
2772      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2773      &                    - dGLJdR * pom
2774      &                    - dQUADdR * pom
2775      &                    - tuna(k)
2776      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2777      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2778
2779          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2780 c! this acts on hydrophobic center of interaction
2781          gheadtail(k,2,1) = gheadtail(k,2,1)
2782      &                    + dGCLdR * pom
2783      &                    + dGGBdR * pom
2784      &                    + dGCVdR * pom
2785      &                    + dPOLdR1 * (erhead_tail(k,1)
2786      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2787      &                    + dPOLdR2 * condor
2788      &                    + dGLJdR * pom
2789      &                    + dQUADdR * pom
2790      &                    + tuna(k)
2791      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2792      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2793
2794 c! this acts on Calpha
2795          gheadtail(k,3,1) = gheadtail(k,3,1)
2796      &                    - dGCLdR * erhead(k)
2797      &                    - dGGBdR * erhead(k)
2798      &                    - dGCVdR * erhead(k)
2799      &                    - dPOLdR1 * erhead_tail(k,1)
2800      &                    - dPOLdR2 * erhead_tail(k,2)
2801      &                    - dGLJdR * erhead(k)
2802      &                    - dQUADdR * erhead(k)
2803      &                    - tuna(k)
2804
2805 c! this acts on Calpha
2806          gheadtail(k,4,1) = gheadtail(k,4,1)
2807      &                    + dGCLdR * erhead(k)
2808      &                    + dGGBdR * erhead(k)
2809      &                    + dGCVdR * erhead(k)
2810      &                    + dPOLdR1 * erhead_tail(k,1)
2811      &                    + dPOLdR2 * erhead_tail(k,2)
2812      &                    + dGLJdR * erhead(k)
2813      &                    + dQUADdR * erhead(k)
2814      &                    + tuna(k)
2815         END DO
2816 c!      write(*,*) "ECL = ", Ecl
2817 c!      write(*,*) "Egb = ", Egb
2818 c!      write(*,*) "Epol = ", Epol
2819 c!      write(*,*) "Fisocav = ", Fisocav
2820 c!      write(*,*) "Elj = ", Elj
2821 c!      write(*,*) "Equad = ", Equad
2822 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2823 c!      write(*,*) "eheadtail = ", eheadtail
2824 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2825 c!      write(*,*) "dGCLdR = ", dGCLdR
2826 c!      write(*,*) "dGGBdR = ", dGGBdR
2827 c!      write(*,*) "dGCVdR = ", dGCVdR
2828 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2829 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2830 c!      write(*,*) "dGLJdR = ", dGLJdR
2831 c!      write(*,*) "dQUADdR = ", dQUADdR
2832 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2833         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2834         eheadtail = eheadtail
2835      &            + wstate(istate, itypi, itypj)
2836      &            * dexp(-betaT * ener(istate))
2837 c! foreach cartesian dimension
2838         DO k = 1, 3
2839 c! foreach of two gvdwx and gvdwc
2840          DO l = 1, 4
2841           gheadtail(k,l,2) = gheadtail(k,l,2)
2842      &                     + wstate( istate, itypi, itypj )
2843      &                     * dexp(-betaT * ener(istate))
2844      &                     * gheadtail(k,l,1)
2845           gheadtail(k,l,1) = 0.0d0
2846          END DO
2847         END DO
2848        END DO
2849 c! Here ended the gigantic DO istate = 1, 4, which starts
2850 c! at the beggining of the subroutine
2851
2852        DO k = 1, 3
2853         DO l = 1, 4
2854          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2855         END DO
2856         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2857         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2858         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2859         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2860         DO l = 1, 4
2861          gheadtail(k,l,1) = 0.0d0
2862          gheadtail(k,l,2) = 0.0d0
2863         END DO
2864        END DO
2865        eheadtail = (-dlog(eheadtail)) / betaT
2866        dPOLdOM1 = 0.0d0
2867        dPOLdOM2 = 0.0d0
2868        dQUADdOM1 = 0.0d0
2869        dQUADdOM2 = 0.0d0
2870        dQUADdOM12 = 0.0d0
2871        RETURN
2872       END SUBROUTINE energy_quad
2873
2874
2875 c!-------------------------------------------------------------------
2876
2877
2878       SUBROUTINE eqn(Epol)
2879       IMPLICIT NONE
2880       INCLUDE 'DIMENSIONS'
2881       INCLUDE 'COMMON.CALC'
2882       INCLUDE 'COMMON.CHAIN'
2883       INCLUDE 'COMMON.CONTROL'
2884       INCLUDE 'COMMON.DERIV'
2885       INCLUDE 'COMMON.EMP'
2886       INCLUDE 'COMMON.GEO'
2887       INCLUDE 'COMMON.INTERACT'
2888       INCLUDE 'COMMON.IOUNITS'
2889       INCLUDE 'COMMON.LOCAL'
2890       INCLUDE 'COMMON.NAMES'
2891       INCLUDE 'COMMON.VAR'
2892       double precision scalar, facd4, federmaus
2893       alphapol1 = alphapol(itypi,itypj)
2894 c! R1 - distance between head of ith side chain and tail of jth sidechain
2895        R1 = 0.0d0
2896        DO k = 1, 3
2897 c! Calculate head-to-tail distances
2898         R1=R1+(ctail(k,2)-chead(k,1))**2
2899        END DO
2900 c! Pitagoras
2901        R1 = dsqrt(R1)
2902
2903 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2904 c!     &        +dhead(1,1,itypi,itypj))**2))
2905 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2906 c!     &        +dhead(2,1,itypi,itypj))**2))
2907 c--------------------------------------------------------------------
2908 c Polarization energy
2909 c Epol
2910        MomoFac1 = (1.0d0 - chi1 * sqom2)
2911        RR1  = R1 * R1 / MomoFac1
2912        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2913        fgb1 = sqrt( RR1 + a12sq * ee1)
2914        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2915 c!       epol = 0.0d0
2916 c!------------------------------------------------------------------
2917 c! derivative of Epol is Gpol...
2918        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2919      &          / (fgb1 ** 5.0d0)
2920        dFGBdR1 = ( (R1 / MomoFac1)
2921      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2922      &        / ( 2.0d0 * fgb1 )
2923        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2924      &          * (2.0d0 - 0.5d0 * ee1) )
2925      &          / (2.0d0 * fgb1)
2926        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2927 c!       dPOLdR1 = 0.0d0
2928        dPOLdOM1 = 0.0d0
2929        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2930 c!       dPOLdOM2 = 0.0d0
2931 c!-------------------------------------------------------------------
2932 c! Return the results
2933 c! (see comments in Eqq)
2934        DO k = 1, 3
2935         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2936        END DO
2937        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2938        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2939        facd1 = d1 * vbld_inv(i+nres)
2940        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2941
2942        DO k = 1, 3
2943         hawk = (erhead_tail(k,1) +
2944      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2945
2946         gvdwx(k,i) = gvdwx(k,i)
2947      &             - dPOLdR1 * hawk
2948         gvdwx(k,j) = gvdwx(k,j)
2949      &             + dPOLdR1 * (erhead_tail(k,1)
2950      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2951
2952         gvdwc(k,i) = gvdwc(k,i)
2953      &             - dPOLdR1 * erhead_tail(k,1)
2954         gvdwc(k,j) = gvdwc(k,j)
2955      &             + dPOLdR1 * erhead_tail(k,1)
2956
2957        END DO
2958        RETURN
2959       END SUBROUTINE eqn
2960
2961
2962 c!-------------------------------------------------------------------
2963
2964
2965
2966       SUBROUTINE enq(Epol)
2967        IMPLICIT NONE
2968        INCLUDE 'DIMENSIONS'
2969        INCLUDE 'COMMON.CALC'
2970        INCLUDE 'COMMON.CHAIN'
2971        INCLUDE 'COMMON.CONTROL'
2972        INCLUDE 'COMMON.DERIV'
2973        INCLUDE 'COMMON.EMP'
2974        INCLUDE 'COMMON.GEO'
2975        INCLUDE 'COMMON.INTERACT'
2976        INCLUDE 'COMMON.IOUNITS'
2977        INCLUDE 'COMMON.LOCAL'
2978        INCLUDE 'COMMON.NAMES'
2979        INCLUDE 'COMMON.VAR'
2980        double precision scalar, facd3, adler
2981        alphapol2 = alphapol(itypj,itypi)
2982 c! R2 - distance between head of jth side chain and tail of ith sidechain
2983        R2 = 0.0d0
2984        DO k = 1, 3
2985 c! Calculate head-to-tail distances
2986         R2=R2+(chead(k,2)-ctail(k,1))**2
2987        END DO
2988 c! Pitagoras
2989        R2 = dsqrt(R2)
2990
2991 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2992 c!     &        +dhead(1,1,itypi,itypj))**2))
2993 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2994 c!     &        +dhead(2,1,itypi,itypj))**2))
2995 c------------------------------------------------------------------------
2996 c Polarization energy
2997        MomoFac2 = (1.0d0 - chi2 * sqom1)
2998        RR2  = R2 * R2 / MomoFac2
2999        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
3000        fgb2 = sqrt(RR2  + a12sq * ee2)
3001        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
3002 c!       epol = 0.0d0
3003 c!-------------------------------------------------------------------
3004 c! derivative of Epol is Gpol...
3005        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
3006      &          / (fgb2 ** 5.0d0)
3007        dFGBdR2 = ( (R2 / MomoFac2)
3008      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
3009      &        / (2.0d0 * fgb2)
3010        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
3011      &          * (2.0d0 - 0.5d0 * ee2) )
3012      &          / (2.0d0 * fgb2)
3013        dPOLdR2 = dPOLdFGB2 * dFGBdR2
3014 c!       dPOLdR2 = 0.0d0
3015        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
3016 c!       dPOLdOM1 = 0.0d0
3017        dPOLdOM2 = 0.0d0
3018 c!-------------------------------------------------------------------
3019 c! Return the results
3020 c! (See comments in Eqq)
3021        DO k = 1, 3
3022         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
3023        END DO
3024        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
3025        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
3026        facd2 = d2 * vbld_inv(j+nres)
3027        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
3028        DO k = 1, 3
3029         condor = (erhead_tail(k,2)
3030      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
3031
3032         gvdwx(k,i) = gvdwx(k,i)
3033      &             - dPOLdR2 * (erhead_tail(k,2)
3034      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
3035         gvdwx(k,j) = gvdwx(k,j)
3036      &             + dPOLdR2 * condor
3037
3038         gvdwc(k,i) = gvdwc(k,i)
3039      &             - dPOLdR2 * erhead_tail(k,2)
3040         gvdwc(k,j) = gvdwc(k,j)
3041      &             + dPOLdR2 * erhead_tail(k,2)
3042
3043        END DO
3044       RETURN
3045       END SUBROUTINE enq
3046
3047
3048 c!-------------------------------------------------------------------
3049
3050
3051       SUBROUTINE eqd(Ecl,Elj,Epol)
3052        IMPLICIT NONE
3053        INCLUDE 'DIMENSIONS'
3054        INCLUDE 'COMMON.CALC'
3055        INCLUDE 'COMMON.CHAIN'
3056        INCLUDE 'COMMON.CONTROL'
3057        INCLUDE 'COMMON.DERIV'
3058        INCLUDE 'COMMON.EMP'
3059        INCLUDE 'COMMON.GEO'
3060        INCLUDE 'COMMON.INTERACT'
3061        INCLUDE 'COMMON.IOUNITS'
3062        INCLUDE 'COMMON.LOCAL'
3063        INCLUDE 'COMMON.NAMES'
3064        INCLUDE 'COMMON.VAR'
3065        double precision scalar, facd4, federmaus
3066        alphapol1 = alphapol(itypi,itypj)
3067        w1        = wqdip(1,itypi,itypj)
3068        w2        = wqdip(2,itypi,itypj)
3069        pis       = sig0head(itypi,itypj)
3070        eps_head   = epshead(itypi,itypj)
3071 c!-------------------------------------------------------------------
3072 c! R1 - distance between head of ith side chain and tail of jth sidechain
3073        R1 = 0.0d0
3074        DO k = 1, 3
3075 c! Calculate head-to-tail distances
3076         R1=R1+(ctail(k,2)-chead(k,1))**2
3077        END DO
3078 c! Pitagoras
3079        R1 = dsqrt(R1)
3080
3081 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
3082 c!     &        +dhead(1,1,itypi,itypj))**2))
3083 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
3084 c!     &        +dhead(2,1,itypi,itypj))**2))
3085
3086 c!-------------------------------------------------------------------
3087 c! ecl
3088        sparrow  = w1 * Qi * om1
3089        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
3090        Ecl = sparrow / Rhead**2.0d0
3091      &     - hawk    / Rhead**4.0d0
3092 c!-------------------------------------------------------------------
3093 c! derivative of ecl is Gcl
3094 c! dF/dr part
3095        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
3096      &           + 4.0d0 * hawk    / Rhead**5.0d0
3097 c! dF/dom1
3098        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
3099 c! dF/dom2
3100        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
3101 c--------------------------------------------------------------------
3102 c Polarization energy
3103 c Epol
3104        MomoFac1 = (1.0d0 - chi1 * sqom2)
3105        RR1  = R1 * R1 / MomoFac1
3106        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
3107        fgb1 = sqrt( RR1 + a12sq * ee1)
3108        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
3109 c!       epol = 0.0d0
3110 c!------------------------------------------------------------------
3111 c! derivative of Epol is Gpol...
3112        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
3113      &          / (fgb1 ** 5.0d0)
3114        dFGBdR1 = ( (R1 / MomoFac1)
3115      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
3116      &        / ( 2.0d0 * fgb1 )
3117        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
3118      &          * (2.0d0 - 0.5d0 * ee1) )
3119      &          / (2.0d0 * fgb1)
3120        dPOLdR1 = dPOLdFGB1 * dFGBdR1
3121 c!       dPOLdR1 = 0.0d0
3122        dPOLdOM1 = 0.0d0
3123        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
3124 c!       dPOLdOM2 = 0.0d0
3125 c!-------------------------------------------------------------------
3126 c! Elj
3127        pom = (pis / Rhead)**6.0d0
3128        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
3129 c! derivative of Elj is Glj
3130        dGLJdR = 4.0d0 * eps_head
3131      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
3132      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
3133 c!-------------------------------------------------------------------
3134 c! Return the results
3135        DO k = 1, 3
3136         erhead(k) = Rhead_distance(k)/Rhead
3137         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
3138        END DO
3139
3140        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
3141        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
3142        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
3143        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
3144        facd1 = d1 * vbld_inv(i+nres)
3145        facd2 = d2 * vbld_inv(j+nres)
3146        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
3147
3148        DO k = 1, 3
3149         hawk = (erhead_tail(k,1) +
3150      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
3151
3152         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
3153         gvdwx(k,i) = gvdwx(k,i)
3154      &             - dGCLdR * pom
3155      &             - dPOLdR1 * hawk
3156      &             - dGLJdR * pom
3157
3158         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
3159         gvdwx(k,j) = gvdwx(k,j)
3160      &             + dGCLdR * pom
3161      &             + dPOLdR1 * (erhead_tail(k,1)
3162      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
3163      &             + dGLJdR * pom
3164
3165
3166         gvdwc(k,i) = gvdwc(k,i)
3167      &             - dGCLdR * erhead(k)
3168      &             - dPOLdR1 * erhead_tail(k,1)
3169      &             - dGLJdR * erhead(k)
3170
3171         gvdwc(k,j) = gvdwc(k,j)
3172      &             + dGCLdR * erhead(k)
3173      &             + dPOLdR1 * erhead_tail(k,1)
3174      &             + dGLJdR * erhead(k)
3175
3176        END DO
3177        RETURN
3178       END SUBROUTINE eqd
3179
3180
3181 c!-------------------------------------------------------------------
3182
3183
3184       SUBROUTINE edq(Ecl,Elj,Epol)
3185        IMPLICIT NONE
3186        INCLUDE 'DIMENSIONS'
3187        INCLUDE 'COMMON.CALC'
3188        INCLUDE 'COMMON.CHAIN'
3189        INCLUDE 'COMMON.CONTROL'
3190        INCLUDE 'COMMON.DERIV'
3191        INCLUDE 'COMMON.EMP'
3192        INCLUDE 'COMMON.GEO'
3193        INCLUDE 'COMMON.INTERACT'
3194        INCLUDE 'COMMON.IOUNITS'
3195        INCLUDE 'COMMON.LOCAL'
3196        INCLUDE 'COMMON.NAMES'
3197        INCLUDE 'COMMON.VAR'
3198        double precision scalar, facd3, adler
3199        alphapol2 = alphapol(itypj,itypi)
3200        w1        = wqdip(1,itypi,itypj)
3201        w2        = wqdip(2,itypi,itypj)
3202        pis       = sig0head(itypi,itypj)
3203        eps_head  = epshead(itypi,itypj)
3204 c!-------------------------------------------------------------------
3205 c! R2 - distance between head of jth side chain and tail of ith sidechain
3206        R2 = 0.0d0
3207        DO k = 1, 3
3208 c! Calculate head-to-tail distances
3209         R2=R2+(chead(k,2)-ctail(k,1))**2
3210        END DO
3211 c! Pitagoras
3212        R2 = dsqrt(R2)
3213
3214 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
3215 c!     &        +dhead(1,1,itypi,itypj))**2))
3216 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
3217 c!     &        +dhead(2,1,itypi,itypj))**2))
3218
3219
3220 c!-------------------------------------------------------------------
3221 c! ecl
3222        sparrow  = w1 * Qi * om1
3223        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
3224        ECL = sparrow / Rhead**2.0d0
3225      &     - hawk    / Rhead**4.0d0
3226 c!-------------------------------------------------------------------
3227 c! derivative of ecl is Gcl
3228 c! dF/dr part
3229        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
3230      &           + 4.0d0 * hawk    / Rhead**5.0d0
3231 c! dF/dom1
3232        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
3233 c! dF/dom2
3234        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
3235 c--------------------------------------------------------------------
3236 c Polarization energy
3237 c Epol
3238        MomoFac2 = (1.0d0 - chi2 * sqom1)
3239        RR2  = R2 * R2 / MomoFac2
3240        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
3241        fgb2 = sqrt(RR2  + a12sq * ee2)
3242        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
3243 c!       epol = 0.0d0
3244 c! derivative of Epol is Gpol...
3245        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
3246      &          / (fgb2 ** 5.0d0)
3247        dFGBdR2 = ( (R2 / MomoFac2)
3248      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
3249      &        / (2.0d0 * fgb2)
3250        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
3251      &          * (2.0d0 - 0.5d0 * ee2) )
3252      &          / (2.0d0 * fgb2)
3253        dPOLdR2 = dPOLdFGB2 * dFGBdR2
3254 c!       dPOLdR2 = 0.0d0
3255        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
3256 c!       dPOLdOM1 = 0.0d0
3257        dPOLdOM2 = 0.0d0
3258 c!-------------------------------------------------------------------
3259 c! Elj
3260        pom = (pis / Rhead)**6.0d0
3261        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
3262 c! derivative of Elj is Glj
3263        dGLJdR = 4.0d0 * eps_head
3264      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
3265      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
3266 c!-------------------------------------------------------------------
3267 c! Return the results
3268 c! (see comments in Eqq)
3269        DO k = 1, 3
3270         erhead(k) = Rhead_distance(k)/Rhead
3271         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
3272        END DO
3273        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
3274        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
3275        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
3276        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
3277        facd1 = d1 * vbld_inv(i+nres)
3278        facd2 = d2 * vbld_inv(j+nres)
3279        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
3280
3281        DO k = 1, 3
3282         condor = (erhead_tail(k,2)
3283      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
3284
3285         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
3286         gvdwx(k,i) = gvdwx(k,i)
3287      &             - dGCLdR * pom
3288      &             - dPOLdR2 * (erhead_tail(k,2)
3289      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
3290      &             - dGLJdR * pom
3291
3292         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
3293         gvdwx(k,j) = gvdwx(k,j)
3294      &             + dGCLdR * pom
3295      &             + dPOLdR2 * condor
3296      &             + dGLJdR * pom
3297
3298
3299         gvdwc(k,i) = gvdwc(k,i)
3300      &             - dGCLdR * erhead(k)
3301      &             - dPOLdR2 * erhead_tail(k,2)
3302      &             - dGLJdR * erhead(k)
3303
3304         gvdwc(k,j) = gvdwc(k,j)
3305      &             + dGCLdR * erhead(k)
3306      &             + dPOLdR2 * erhead_tail(k,2)
3307      &             + dGLJdR * erhead(k)
3308
3309        END DO
3310        RETURN
3311       END SUBROUTINE edq
3312
3313
3314 C--------------------------------------------------------------------
3315
3316
3317       SUBROUTINE edd(ECL)
3318        IMPLICIT NONE
3319        INCLUDE 'DIMENSIONS'
3320        INCLUDE 'COMMON.CALC'
3321        INCLUDE 'COMMON.CHAIN'
3322        INCLUDE 'COMMON.CONTROL'
3323        INCLUDE 'COMMON.DERIV'
3324        INCLUDE 'COMMON.EMP'
3325        INCLUDE 'COMMON.GEO'
3326        INCLUDE 'COMMON.INTERACT'
3327        INCLUDE 'COMMON.IOUNITS'
3328        INCLUDE 'COMMON.LOCAL'
3329        INCLUDE 'COMMON.NAMES'
3330        INCLUDE 'COMMON.VAR'
3331        double precision scalar
3332 c!       csig = sigiso(itypi,itypj)
3333        w1 = wqdip(1,itypi,itypj)
3334        w2 = wqdip(2,itypi,itypj)
3335 c!-------------------------------------------------------------------
3336 c! ECL
3337        fac = (om12 - 3.0d0 * om1 * om2)
3338        c1 = (w1 / (Rhead**3.0d0)) * fac
3339        c2 = (w2 / Rhead ** 6.0d0)
3340      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
3341        ECL = c1 - c2
3342 c!       write (*,*) "w1 = ", w1
3343 c!       write (*,*) "w2 = ", w2
3344 c!       write (*,*) "om1 = ", om1
3345 c!       write (*,*) "om2 = ", om2
3346 c!       write (*,*) "om12 = ", om12
3347 c!       write (*,*) "fac = ", fac
3348 c!       write (*,*) "c1 = ", c1
3349 c!       write (*,*) "c2 = ", c2
3350 c!       write (*,*) "Ecl = ", Ecl
3351 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
3352 c!       write (*,*) "c2_2 = ",
3353 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
3354 c!-------------------------------------------------------------------
3355 c! dervative of ECL is GCL...
3356 c! dECL/dr
3357        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
3358        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
3359      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
3360        dGCLdR = c1 - c2
3361 c! dECL/dom1
3362        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
3363        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
3364      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
3365        dGCLdOM1 = c1 - c2
3366 c! dECL/dom2
3367        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
3368        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
3369      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
3370        dGCLdOM2 = c1 - c2
3371 c! dECL/dom12
3372        c1 = w1 / (Rhead ** 3.0d0)
3373        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
3374        dGCLdOM12 = c1 - c2
3375 c!-------------------------------------------------------------------
3376 c! Return the results
3377 c! (see comments in Eqq)
3378        DO k= 1, 3
3379         erhead(k) = Rhead_distance(k)/Rhead
3380        END DO
3381        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
3382        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
3383        facd1 = d1 * vbld_inv(i+nres)
3384        facd2 = d2 * vbld_inv(j+nres)
3385        DO k = 1, 3
3386
3387         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
3388         gvdwx(k,i) = gvdwx(k,i)
3389      &             - dGCLdR * pom
3390         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
3391         gvdwx(k,j) = gvdwx(k,j)
3392      &             + dGCLdR * pom
3393
3394         gvdwc(k,i) = gvdwc(k,i)
3395      &             - dGCLdR * erhead(k)
3396         gvdwc(k,j) = gvdwc(k,j)
3397      &             + dGCLdR * erhead(k)
3398        END DO
3399        RETURN
3400       END SUBROUTINE edd
3401
3402
3403 c!-------------------------------------------------------------------
3404
3405
3406       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
3407        IMPLICIT NONE
3408 c! maxres
3409        INCLUDE 'DIMENSIONS'
3410 c! itypi, itypj, i, j, k, l, chead,
3411        INCLUDE 'COMMON.CALC'
3412 c! c, nres, dc_norm
3413        INCLUDE 'COMMON.CHAIN'
3414 c! gradc, gradx
3415        INCLUDE 'COMMON.DERIV'
3416 c! electrostatic gradients-specific variables
3417        INCLUDE 'COMMON.EMP'
3418 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
3419        INCLUDE 'COMMON.INTERACT'
3420 c! t_bath, Rb
3421        INCLUDE 'COMMON.MD'
3422 c! io for debug, disable it in final builds
3423        INCLUDE 'COMMON.IOUNITS'
3424 c!-------------------------------------------------------------------
3425 c! Variable Init
3426
3427 c! what amino acid is the aminoacid j'th?
3428        itypj = itype(j)
3429 c! 1/(Gas Constant * Thermostate temperature) = BetaT
3430 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
3431 c!       t_bath = 300
3432 c!       BetaT = 1.0d0 / (t_bath * Rb)
3433        BetaT = 1.0d0 / (298.0d0 * Rb)
3434 c! Gay-berne var's
3435        sig0ij = sigma( itypi,itypj )
3436        chi1   = chi( itypi, itypj )
3437        chi2   = chi( itypj, itypi )
3438        chi12  = chi1 * chi2
3439        chip1  = chipp( itypi, itypj )
3440        chip2  = chipp( itypj, itypi )
3441        chip12 = chip1 * chip2
3442 c! not used by momo potential, but needed by sc_angular which is shared
3443 c! by all energy_potential subroutines
3444        alf1   = 0.0d0
3445        alf2   = 0.0d0
3446        alf12  = 0.0d0
3447 c! location, location, location
3448        xj  = c( 1, nres+j ) - xi
3449        yj  = c( 2, nres+j ) - yi
3450        zj  = c( 3, nres+j ) - zi
3451        dxj = dc_norm( 1, nres+j )
3452        dyj = dc_norm( 2, nres+j )
3453        dzj = dc_norm( 3, nres+j )
3454 c! distance from center of chain(?) to polar/charged head
3455 c!       write (*,*) "istate = ", 1
3456 c!       write (*,*) "ii = ", 1
3457 c!       write (*,*) "jj = ", 1
3458        d1 = dhead(1, 1, itypi, itypj)
3459        d2 = dhead(2, 1, itypi, itypj)
3460 c! ai*aj from Fgb
3461        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
3462 c!       a12sq = a12sq * a12sq
3463 c! charge of amino acid itypi is...
3464        Qi  = icharge(itypi)
3465        Qj  = icharge(itypj)
3466        Qij = Qi * Qj
3467 c! chis1,2,12
3468        chis1 = chis(itypi,itypj)
3469        chis2 = chis(itypj,itypi)
3470        chis12 = chis1 * chis2
3471        sig1 = sigmap1(itypi,itypj)
3472        sig2 = sigmap2(itypi,itypj)
3473 c!       write (*,*) "sig1 = ", sig1
3474 c!       write (*,*) "sig2 = ", sig2
3475 c! alpha factors from Fcav/Gcav
3476        b1 = alphasur(1,itypi,itypj)
3477        b2 = alphasur(2,itypi,itypj)
3478        b3 = alphasur(3,itypi,itypj)
3479        b4 = alphasur(4,itypi,itypj)
3480 c! used to determine whether we want to do quadrupole calculations
3481        wqd = wquad(itypi, itypj)
3482 c! used by Fgb
3483        eps_in = epsintab(itypi,itypj)
3484        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
3485 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
3486 c!-------------------------------------------------------------------
3487 c! tail location and distance calculations
3488        Rtail = 0.0d0
3489        DO k = 1, 3
3490         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
3491         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
3492        END DO
3493 c! tail distances will be themselves usefull elswhere
3494 c1 (in Gcav, for example)
3495        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
3496        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
3497        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
3498        Rtail = dsqrt(
3499      &     (Rtail_distance(1)*Rtail_distance(1))
3500      &   + (Rtail_distance(2)*Rtail_distance(2))
3501      &   + (Rtail_distance(3)*Rtail_distance(3)))
3502 c!-------------------------------------------------------------------
3503 c! Calculate location and distance between polar heads
3504 c! distance between heads
3505 c! for each one of our three dimensional space...
3506        DO k = 1,3
3507 c! location of polar head is computed by taking hydrophobic centre
3508 c! and moving by a d1 * dc_norm vector
3509 c! see unres publications for very informative images
3510         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
3511         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
3512 c! distance
3513 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
3514 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
3515         Rhead_distance(k) = chead(k,2) - chead(k,1)
3516        END DO
3517 c! pitagoras (root of sum of squares)
3518        Rhead = dsqrt(
3519      &     (Rhead_distance(1)*Rhead_distance(1))
3520      &   + (Rhead_distance(2)*Rhead_distance(2))
3521      &   + (Rhead_distance(3)*Rhead_distance(3)))
3522 c!-------------------------------------------------------------------
3523 c! zero everything that should be zero'ed
3524        Egb = 0.0d0
3525        ECL = 0.0d0
3526        Elj = 0.0d0
3527        Equad = 0.0d0
3528        Epol = 0.0d0
3529        eheadtail = 0.0d0
3530        dGCLdOM1 = 0.0d0
3531        dGCLdOM2 = 0.0d0
3532        dGCLdOM12 = 0.0d0
3533        dPOLdOM1 = 0.0d0
3534        dPOLdOM2 = 0.0d0
3535        RETURN
3536       END SUBROUTINE elgrad_init
3537
3538
3539 c!-------------------------------------------------------------------
3540
3541       subroutine sc_angular
3542 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
3543 C om12. Called by ebp, egb, and egbv.
3544       implicit none
3545       include 'COMMON.CALC'
3546       include 'COMMON.IOUNITS'
3547       erij(1)=xj*rij
3548       erij(2)=yj*rij
3549       erij(3)=zj*rij
3550       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3551       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3552       om12=dxi*dxj+dyi*dyj+dzi*dzj
3553 c!      om1    = 0.0d0
3554 c!      om2    = 0.0d0
3555 c!      om12   = 0.0d0
3556       chiom12=chi12*om12
3557 C Calculate eps1(om12) and its derivative in om12
3558       faceps1=1.0D0-om12*chiom12
3559       faceps1_inv=1.0D0/faceps1
3560       eps1=dsqrt(faceps1_inv)
3561 C Following variable is eps1*deps1/dom12
3562       eps1_om12=faceps1_inv*chiom12
3563 c diagnostics only
3564 c      faceps1_inv=om12
3565 c      eps1=om12
3566 c      eps1_om12=1.0d0
3567 c      write (iout,*) "om12",om12," eps1",eps1
3568 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
3569 C and om12.
3570       om1om2=om1*om2
3571       chiom1=chi1*om1
3572       chiom2=chi2*om2
3573       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
3574       sigsq=1.0D0-facsig*faceps1_inv
3575       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
3576       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
3577       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
3578 c diagnostics only
3579 c      sigsq=1.0d0
3580 c      sigsq_om1=0.0d0
3581 c      sigsq_om2=0.0d0
3582 c      sigsq_om12=0.0d0
3583 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
3584 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
3585 c     &    " eps1",eps1
3586 C Calculate eps2 and its derivatives in om1, om2, and om12.
3587       chipom1=chip1*om1
3588       chipom2=chip2*om2
3589       chipom12=chip12*om12
3590       facp=1.0D0-om12*chipom12
3591       facp_inv=1.0D0/facp
3592       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
3593 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
3594 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
3595 C Following variable is the square root of eps2
3596       eps2rt=1.0D0-facp1*facp_inv
3597 C Following three variables are the derivatives of the square root of eps
3598 C in om1, om2, and om12.
3599       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
3600       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
3601       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
3602 C Evaluate the "asymmetric" factor in the VDW constant, eps3
3603 c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular
3604 c! Or frankly, we should restructurize the whole energy section
3605       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
3606 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
3607 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
3608 c     &  " eps2rt_om12",eps2rt_om12
3609 C Calculate whole angle-dependent part of epsilon and contributions
3610 C to its derivatives
3611       return
3612       end
3613
3614 C----------------------------------------------------------------------------
3615       subroutine sc_grad_T
3616       implicit real*8 (a-h,o-z)
3617       include 'DIMENSIONS'
3618       include 'COMMON.CHAIN'
3619       include 'COMMON.DERIV'
3620       include 'COMMON.CALC'
3621       include 'COMMON.IOUNITS'
3622       double precision dcosom1(3),dcosom2(3)
3623       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
3624       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
3625       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
3626      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
3627 c diagnostics only
3628 c      eom1=0.0d0
3629 c      eom2=0.0d0
3630 c      eom12=evdwij*eps1_om12
3631 c end diagnostics
3632 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
3633 c     &  " sigder",sigder
3634 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
3635 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
3636       do k=1,3
3637         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3638         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3639       enddo
3640       do k=1,3
3641         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3642       enddo
3643 c      write (iout,*) "gg",(gg(k),k=1,3)
3644       do k=1,3
3645         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
3646      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
3647      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
3648         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
3649      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
3650      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
3651 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
3652 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
3653 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
3654 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
3655       enddo
3656 C
3657 C Calculate the components of the gradient in DC and X
3658 C
3659 cgrad      do k=i,j-1
3660 cgrad        do l=1,3
3661 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
3662 cgrad        enddo
3663 cgrad      enddo
3664       do l=1,3
3665         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
3666         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
3667       enddo
3668       return
3669       end
3670
3671 C----------------------------------------------------------------------------
3672
3673
3674       SUBROUTINE sc_grad
3675        IMPLICIT real*8 (a-h,o-z)
3676        INCLUDE 'DIMENSIONS'
3677        INCLUDE 'COMMON.CHAIN'
3678        INCLUDE 'COMMON.DERIV'
3679        INCLUDE 'COMMON.CALC'
3680        INCLUDE 'COMMON.IOUNITS'
3681        INCLUDE 'COMMON.EMP'
3682        double precision dcosom1(3),dcosom2(3)
3683 c!       write (*,*) "Start sc_grad"
3684 c! each eom holds sum of omega-angular derivatives of each component
3685 c! of energy function. First GGB, then Gcav, dipole-dipole,...
3686        eom1  =
3687      &         eps2der * eps2rt_om1
3688      &       - 2.0D0 * alf1 * eps3der
3689      &       + sigder * sigsq_om1
3690      &       + dCAVdOM1
3691      &       + dGCLdOM1
3692      &       + dPOLdOM1
3693
3694        eom2  =
3695      &         eps2der * eps2rt_om2
3696      &       + 2.0D0 * alf2 * eps3der
3697      &       + sigder * sigsq_om2
3698      &       + dCAVdOM2
3699      &       + dGCLdOM2
3700      &       + dPOLdOM2
3701
3702        eom12 =
3703      &         evdwij  * eps1_om12
3704      &       + eps2der * eps2rt_om12
3705      &       - 2.0D0 * alf12 * eps3der
3706      &       + sigder *sigsq_om12
3707      &       + dCAVdOM12
3708      &       + dGCLdOM12
3709
3710 c!      write (*,*) "evdwij=", evdwij
3711 c!      write (*,*) "eps1_om12=", eps1_om12
3712 c!      write (*,*) "eps2der=", eps2rt_om12
3713 c!      write (*,*) "alf12=", alf12
3714 c!      write (*,*) "eps3der=", eps3der
3715 c!      write (*,*) "eom1=", eom1
3716 c!      write (*,*) "eom2=", eom2
3717 c!      write (*,*) "eom12=", eom12
3718 c!      eom1 = 0.0d0
3719 c!      eom2 = 0.0d0
3720 c!      eom12 = 0.0d0
3721 c!      write (*,*) ""
3722
3723        DO k = 1, 3
3724 c! now some magical transformations to project gradient into
3725 c! three cartesian vectors
3726 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
3727 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
3728 c!      write (*,*) "gg(",k,")=", gg(k)
3729         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
3730         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
3731         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
3732 c!      write (*,*) "gg(",k,")=", gg(k)
3733 c! this acts on hydrophobic center of interaction
3734         gvdwx(k,i)= gvdwx(k,i) - gg(k)
3735      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
3736      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
3737         gvdwx(k,j)= gvdwx(k,j) + gg(k)
3738      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
3739      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
3740 c! this acts on Calpha
3741         gvdwc(k,i)=gvdwc(k,i)-gg(k)
3742         gvdwc(k,j)=gvdwc(k,j)+gg(k)
3743 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
3744 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
3745        END DO
3746 c!      write (*,*) "*************"
3747 c!      write (*,*) ""
3748        RETURN
3749       END SUBROUTINE sc_grad
3750
3751
3752 C-----------------------------------------------------------------------
3753
3754
3755       subroutine e_softsphere(evdw)
3756 C
3757 C This subroutine calculates the interaction energy of nonbonded side chains
3758 C assuming the LJ potential of interaction.
3759 C
3760       implicit real*8 (a-h,o-z)
3761       include 'DIMENSIONS'
3762       parameter (accur=1.0d-10)
3763       include 'COMMON.GEO'
3764       include 'COMMON.VAR'
3765       include 'COMMON.LOCAL'
3766       include 'COMMON.CHAIN'
3767       include 'COMMON.DERIV'
3768       include 'COMMON.INTERACT'
3769       include 'COMMON.TORSION'
3770       include 'COMMON.SBRIDGE'
3771       include 'COMMON.NAMES'
3772       include 'COMMON.IOUNITS'
3773       include 'COMMON.CONTACTS'
3774       dimension gg(3)
3775 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
3776       evdw=0.0D0
3777       do i=iatsc_s,iatsc_e
3778         itypi=itype(i)
3779         itypi1=itype(i+1)
3780         xi=c(1,nres+i)
3781         yi=c(2,nres+i)
3782         zi=c(3,nres+i)
3783 C
3784 C Calculate SC interaction energy.
3785 C
3786         do iint=1,nint_gr(i)
3787 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
3788 cd   &                  'iend=',iend(i,iint)
3789           do j=istart(i,iint),iend(i,iint)
3790             itypj=itype(j)
3791             xj=c(1,nres+j)-xi
3792             yj=c(2,nres+j)-yi
3793             zj=c(3,nres+j)-zi
3794             rij=xj*xj+yj*yj+zj*zj
3795 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
3796             r0ij=r0(itypi,itypj)
3797             r0ijsq=r0ij*r0ij
3798 c            print *,i,j,r0ij,dsqrt(rij)
3799             if (rij.lt.r0ijsq) then
3800               evdwij=0.25d0*(rij-r0ijsq)**2
3801               fac=rij-r0ijsq
3802             else
3803               evdwij=0.0d0
3804               fac=0.0d0
3805             endif
3806             evdw=evdw+evdwij
3807 C
3808 C Calculate the components of the gradient in DC and X
3809 C
3810             gg(1)=xj*fac
3811             gg(2)=yj*fac
3812             gg(3)=zj*fac
3813             do k=1,3
3814               gvdwx(k,i)=gvdwx(k,i)-gg(k)
3815               gvdwx(k,j)=gvdwx(k,j)+gg(k)
3816               gvdwc(k,i)=gvdwc(k,i)-gg(k)
3817               gvdwc(k,j)=gvdwc(k,j)+gg(k)
3818             enddo
3819 cgrad            do k=i,j-1
3820 cgrad              do l=1,3
3821 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
3822 cgrad              enddo
3823 cgrad            enddo
3824           enddo ! j
3825         enddo ! iint
3826       enddo ! i
3827       return
3828       end
3829 C--------------------------------------------------------------------------
3830       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
3831      &              eello_turn4)
3832 C
3833 C Soft-sphere potential of p-p interaction
3834 C
3835       implicit real*8 (a-h,o-z)
3836       include 'DIMENSIONS'
3837       include 'COMMON.CONTROL'
3838       include 'COMMON.IOUNITS'
3839       include 'COMMON.GEO'
3840       include 'COMMON.VAR'
3841       include 'COMMON.LOCAL'
3842       include 'COMMON.CHAIN'
3843       include 'COMMON.DERIV'
3844       include 'COMMON.INTERACT'
3845       include 'COMMON.CONTACTS'
3846       include 'COMMON.TORSION'
3847       include 'COMMON.VECTORS'
3848       include 'COMMON.FFIELD'
3849       dimension ggg(3)
3850 cd      write(iout,*) 'In EELEC_soft_sphere'
3851       ees=0.0D0
3852       evdw1=0.0D0
3853       eel_loc=0.0d0
3854       eello_turn3=0.0d0
3855       eello_turn4=0.0d0
3856       ind=0
3857       do i=iatel_s,iatel_e
3858         dxi=dc(1,i)
3859         dyi=dc(2,i)
3860         dzi=dc(3,i)
3861         xmedi=c(1,i)+0.5d0*dxi
3862         ymedi=c(2,i)+0.5d0*dyi
3863         zmedi=c(3,i)+0.5d0*dzi
3864         num_conti=0
3865 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3866         do j=ielstart(i),ielend(i)
3867           ind=ind+1
3868           iteli=itel(i)
3869           itelj=itel(j)
3870           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3871           r0ij=rpp(iteli,itelj)
3872           r0ijsq=r0ij*r0ij
3873           dxj=dc(1,j)
3874           dyj=dc(2,j)
3875           dzj=dc(3,j)
3876           xj=c(1,j)+0.5D0*dxj-xmedi
3877           yj=c(2,j)+0.5D0*dyj-ymedi
3878           zj=c(3,j)+0.5D0*dzj-zmedi
3879           rij=xj*xj+yj*yj+zj*zj
3880           if (rij.lt.r0ijsq) then
3881             evdw1ij=0.25d0*(rij-r0ijsq)**2
3882             fac=rij-r0ijsq
3883           else
3884             evdw1ij=0.0d0
3885             fac=0.0d0
3886           endif
3887           evdw1=evdw1+evdw1ij
3888 C
3889 C Calculate contributions to the Cartesian gradient.
3890 C
3891           ggg(1)=fac*xj
3892           ggg(2)=fac*yj
3893           ggg(3)=fac*zj
3894           do k=1,3
3895             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3896             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3897           enddo
3898 *
3899 * Loop over residues i+1 thru j-1.
3900 *
3901 cgrad          do k=i+1,j-1
3902 cgrad            do l=1,3
3903 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3904 cgrad            enddo
3905 cgrad          enddo
3906         enddo ! j
3907       enddo   ! i
3908 cgrad      do i=nnt,nct-1
3909 cgrad        do k=1,3
3910 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
3911 cgrad        enddo
3912 cgrad        do j=i+1,nct-1
3913 cgrad          do k=1,3
3914 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
3915 cgrad          enddo
3916 cgrad        enddo
3917 cgrad      enddo
3918       return
3919       end
3920 c------------------------------------------------------------------------------
3921       subroutine vec_and_deriv
3922       implicit real*8 (a-h,o-z)
3923       include 'DIMENSIONS'
3924 #ifdef MPI
3925       include 'mpif.h'
3926 #endif
3927       include 'COMMON.IOUNITS'
3928       include 'COMMON.GEO'
3929       include 'COMMON.VAR'
3930       include 'COMMON.LOCAL'
3931       include 'COMMON.CHAIN'
3932       include 'COMMON.VECTORS'
3933       include 'COMMON.SETUP'
3934       include 'COMMON.TIME1'
3935       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
3936 C Compute the local reference systems. For reference system (i), the
3937 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
3938 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
3939 #ifdef PARVEC
3940       do i=ivec_start,ivec_end
3941 #else
3942       do i=1,nres-1
3943 #endif
3944           if (i.eq.nres-1) then
3945 C Case of the last full residue
3946 C Compute the Z-axis
3947             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
3948             costh=dcos(pi-theta(nres))
3949             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3950             do k=1,3
3951               uz(k,i)=fac*uz(k,i)
3952             enddo
3953 C Compute the derivatives of uz
3954             uzder(1,1,1)= 0.0d0
3955             uzder(2,1,1)=-dc_norm(3,i-1)
3956             uzder(3,1,1)= dc_norm(2,i-1)
3957             uzder(1,2,1)= dc_norm(3,i-1)
3958             uzder(2,2,1)= 0.0d0
3959             uzder(3,2,1)=-dc_norm(1,i-1)
3960             uzder(1,3,1)=-dc_norm(2,i-1)
3961             uzder(2,3,1)= dc_norm(1,i-1)
3962             uzder(3,3,1)= 0.0d0
3963             uzder(1,1,2)= 0.0d0
3964             uzder(2,1,2)= dc_norm(3,i)
3965             uzder(3,1,2)=-dc_norm(2,i)
3966             uzder(1,2,2)=-dc_norm(3,i)
3967             uzder(2,2,2)= 0.0d0
3968             uzder(3,2,2)= dc_norm(1,i)
3969             uzder(1,3,2)= dc_norm(2,i)
3970             uzder(2,3,2)=-dc_norm(1,i)
3971             uzder(3,3,2)= 0.0d0
3972 C Compute the Y-axis
3973             facy=fac
3974             do k=1,3
3975               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3976             enddo
3977 C Compute the derivatives of uy
3978             do j=1,3
3979               do k=1,3
3980                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3981      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3982                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3983               enddo
3984               uyder(j,j,1)=uyder(j,j,1)-costh
3985               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3986             enddo
3987             do j=1,2
3988               do k=1,3
3989                 do l=1,3
3990                   uygrad(l,k,j,i)=uyder(l,k,j)
3991                   uzgrad(l,k,j,i)=uzder(l,k,j)
3992                 enddo
3993               enddo
3994             enddo
3995             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3996             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3997             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3998             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3999           else
4000 C Other residues
4001 C Compute the Z-axis
4002             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
4003             costh=dcos(pi-theta(i+2))
4004             fac=1.0d0/dsqrt(1.0d0-costh*costh)
4005             do k=1,3
4006               uz(k,i)=fac*uz(k,i)
4007             enddo
4008 C Compute the derivatives of uz
4009             uzder(1,1,1)= 0.0d0
4010             uzder(2,1,1)=-dc_norm(3,i+1)
4011             uzder(3,1,1)= dc_norm(2,i+1)
4012             uzder(1,2,1)= dc_norm(3,i+1)
4013             uzder(2,2,1)= 0.0d0
4014             uzder(3,2,1)=-dc_norm(1,i+1)
4015             uzder(1,3,1)=-dc_norm(2,i+1)
4016             uzder(2,3,1)= dc_norm(1,i+1)
4017             uzder(3,3,1)= 0.0d0
4018             uzder(1,1,2)= 0.0d0
4019             uzder(2,1,2)= dc_norm(3,i)
4020             uzder(3,1,2)=-dc_norm(2,i)
4021             uzder(1,2,2)=-dc_norm(3,i)
4022             uzder(2,2,2)= 0.0d0
4023             uzder(3,2,2)= dc_norm(1,i)
4024             uzder(1,3,2)= dc_norm(2,i)
4025             uzder(2,3,2)=-dc_norm(1,i)
4026             uzder(3,3,2)= 0.0d0
4027 C Compute the Y-axis
4028             facy=fac
4029             do k=1,3
4030               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
4031             enddo
4032 C Compute the derivatives of uy
4033             do j=1,3
4034               do k=1,3
4035                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
4036      &                        -dc_norm(k,i)*dc_norm(j,i+1)
4037                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
4038               enddo
4039               uyder(j,j,1)=uyder(j,j,1)-costh
4040               uyder(j,j,2)=1.0d0+uyder(j,j,2)
4041             enddo
4042             do j=1,2
4043               do k=1,3
4044                 do l=1,3
4045                   uygrad(l,k,j,i)=uyder(l,k,j)
4046                   uzgrad(l,k,j,i)=uzder(l,k,j)
4047                 enddo
4048               enddo
4049             enddo
4050             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
4051             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
4052             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
4053             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
4054           endif
4055       enddo
4056       do i=1,nres-1
4057         vbld_inv_temp(1)=vbld_inv(i+1)
4058         if (i.lt.nres-1) then
4059           vbld_inv_temp(2)=vbld_inv(i+2)
4060           else
4061           vbld_inv_temp(2)=vbld_inv(i)
4062           endif
4063         do j=1,2
4064           do k=1,3
4065             do l=1,3
4066               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
4067               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
4068             enddo
4069           enddo
4070         enddo
4071       enddo
4072 #if defined(PARVEC) && defined(MPI)
4073       if (nfgtasks1.gt.1) then
4074         time00=MPI_Wtime()
4075 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
4076 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
4077 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
4078         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
4079      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
4080      &   FG_COMM1,IERR)
4081         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
4082      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
4083      &   FG_COMM1,IERR)
4084         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
4085      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
4086      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
4087         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
4088      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
4089      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
4090         time_gather=time_gather+MPI_Wtime()-time00
4091       endif
4092 c      if (fg_rank.eq.0) then
4093 c        write (iout,*) "Arrays UY and UZ"
4094 c        do i=1,nres-1
4095 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
4096 c     &     (uz(k,i),k=1,3)
4097 c        enddo
4098 c      endif
4099 #endif
4100       return
4101       end
4102 C-----------------------------------------------------------------------------
4103       subroutine check_vecgrad
4104       implicit real*8 (a-h,o-z)
4105       include 'DIMENSIONS'
4106       include 'COMMON.IOUNITS'
4107       include 'COMMON.GEO'
4108       include 'COMMON.VAR'
4109       include 'COMMON.LOCAL'
4110       include 'COMMON.CHAIN'
4111       include 'COMMON.VECTORS'
4112       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
4113       dimension uyt(3,maxres),uzt(3,maxres)
4114       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
4115       double precision delta /1.0d-7/
4116       call vec_and_deriv
4117 cd      do i=1,nres
4118 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
4119 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
4120 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
4121 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
4122 cd     &     (dc_norm(if90,i),if90=1,3)
4123 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
4124 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
4125 cd          write(iout,'(a)')
4126 cd      enddo
4127       do i=1,nres
4128         do j=1,2
4129           do k=1,3
4130             do l=1,3
4131               uygradt(l,k,j,i)=uygrad(l,k,j,i)
4132               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
4133             enddo
4134           enddo
4135         enddo
4136       enddo
4137       call vec_and_deriv
4138       do i=1,nres
4139         do j=1,3
4140           uyt(j,i)=uy(j,i)
4141           uzt(j,i)=uz(j,i)
4142         enddo
4143       enddo
4144       do i=1,nres
4145 cd        write (iout,*) 'i=',i
4146         do k=1,3
4147           erij(k)=dc_norm(k,i)
4148         enddo
4149         do j=1,3
4150           do k=1,3
4151             dc_norm(k,i)=erij(k)
4152           enddo
4153           dc_norm(j,i)=dc_norm(j,i)+delta
4154 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
4155 c          do k=1,3
4156 c            dc_norm(k,i)=dc_norm(k,i)/fac
4157 c          enddo
4158 c          write (iout,*) (dc_norm(k,i),k=1,3)
4159 c          write (iout,*) (erij(k),k=1,3)
4160           call vec_and_deriv
4161           do k=1,3
4162             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
4163             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
4164             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
4165             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
4166           enddo
4167 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
4168 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
4169 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
4170         enddo
4171         do k=1,3
4172           dc_norm(k,i)=erij(k)
4173         enddo
4174 cd        do k=1,3
4175 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
4176 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
4177 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
4178 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
4179 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
4180 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
4181 cd          write (iout,'(a)')
4182 cd        enddo
4183       enddo
4184       return
4185       end
4186 C--------------------------------------------------------------------------
4187       subroutine set_matrices
4188       implicit real*8 (a-h,o-z)
4189       include 'DIMENSIONS'
4190 #ifdef MPI
4191       include "mpif.h"
4192       include "COMMON.SETUP"
4193       integer IERR
4194       integer status(MPI_STATUS_SIZE)
4195 #endif
4196       include 'COMMON.IOUNITS'
4197       include 'COMMON.GEO'
4198       include 'COMMON.VAR'
4199       include 'COMMON.LOCAL'
4200       include 'COMMON.CHAIN'
4201       include 'COMMON.DERIV'
4202       include 'COMMON.INTERACT'
4203       include 'COMMON.CONTACTS'
4204       include 'COMMON.TORSION'
4205       include 'COMMON.VECTORS'
4206       include 'COMMON.FFIELD'
4207       double precision auxvec(2),auxmat(2,2)
4208 C
4209 C Compute the virtual-bond-torsional-angle dependent quantities needed
4210 C to calculate the el-loc multibody terms of various order.
4211 C
4212 #ifdef PARMAT
4213       do i=ivec_start+2,ivec_end+2
4214 #else
4215       do i=3,nres+1
4216 #endif
4217         if (i .lt. nres+1) then
4218           sin1=dsin(phi(i))
4219           cos1=dcos(phi(i))
4220           sintab(i-2)=sin1
4221           costab(i-2)=cos1
4222           obrot(1,i-2)=cos1
4223           obrot(2,i-2)=sin1
4224           sin2=dsin(2*phi(i))
4225           cos2=dcos(2*phi(i))
4226           sintab2(i-2)=sin2
4227           costab2(i-2)=cos2
4228           obrot2(1,i-2)=cos2
4229           obrot2(2,i-2)=sin2
4230           Ug(1,1,i-2)=-cos1
4231           Ug(1,2,i-2)=-sin1
4232           Ug(2,1,i-2)=-sin1
4233           Ug(2,2,i-2)= cos1
4234           Ug2(1,1,i-2)=-cos2
4235           Ug2(1,2,i-2)=-sin2
4236           Ug2(2,1,i-2)=-sin2
4237           Ug2(2,2,i-2)= cos2
4238         else
4239           costab(i-2)=1.0d0
4240           sintab(i-2)=0.0d0
4241           obrot(1,i-2)=1.0d0
4242           obrot(2,i-2)=0.0d0
4243           obrot2(1,i-2)=0.0d0
4244           obrot2(2,i-2)=0.0d0
4245           Ug(1,1,i-2)=1.0d0
4246           Ug(1,2,i-2)=0.0d0
4247           Ug(2,1,i-2)=0.0d0
4248           Ug(2,2,i-2)=1.0d0
4249           Ug2(1,1,i-2)=0.0d0
4250           Ug2(1,2,i-2)=0.0d0
4251           Ug2(2,1,i-2)=0.0d0
4252           Ug2(2,2,i-2)=0.0d0
4253         endif
4254         if (i .gt. 3 .and. i .lt. nres+1) then
4255           obrot_der(1,i-2)=-sin1
4256           obrot_der(2,i-2)= cos1
4257           Ugder(1,1,i-2)= sin1
4258           Ugder(1,2,i-2)=-cos1
4259           Ugder(2,1,i-2)=-cos1
4260           Ugder(2,2,i-2)=-sin1
4261           dwacos2=cos2+cos2
4262           dwasin2=sin2+sin2
4263           obrot2_der(1,i-2)=-dwasin2
4264           obrot2_der(2,i-2)= dwacos2
4265           Ug2der(1,1,i-2)= dwasin2
4266           Ug2der(1,2,i-2)=-dwacos2
4267           Ug2der(2,1,i-2)=-dwacos2
4268           Ug2der(2,2,i-2)=-dwasin2
4269         else
4270           obrot_der(1,i-2)=0.0d0
4271           obrot_der(2,i-2)=0.0d0
4272           Ugder(1,1,i-2)=0.0d0
4273           Ugder(1,2,i-2)=0.0d0
4274           Ugder(2,1,i-2)=0.0d0
4275           Ugder(2,2,i-2)=0.0d0
4276           obrot2_der(1,i-2)=0.0d0
4277           obrot2_der(2,i-2)=0.0d0
4278           Ug2der(1,1,i-2)=0.0d0
4279           Ug2der(1,2,i-2)=0.0d0
4280           Ug2der(2,1,i-2)=0.0d0
4281           Ug2der(2,2,i-2)=0.0d0
4282         endif
4283 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
4284         if (i.gt. nnt+2 .and. i.lt.nct+2) then
4285           iti = itortyp(itype(i-2))
4286         else
4287           iti=ntortyp+1
4288         endif
4289 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
4290         if (i.gt. nnt+1 .and. i.lt.nct+1) then
4291           iti1 = itortyp(itype(i-1))
4292         else
4293           iti1=ntortyp+1
4294         endif
4295 cd        write (iout,*) '*******i',i,' iti1',iti
4296 cd        write (iout,*) 'b1',b1(:,iti)
4297 cd        write (iout,*) 'b2',b2(:,iti)
4298 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
4299 c        if (i .gt. iatel_s+2) then
4300         if (i .gt. nnt+2) then
4301           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
4302           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
4303           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
4304      &    then
4305           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
4306           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
4307           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
4308           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
4309           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
4310           endif
4311         else
4312           do k=1,2
4313             Ub2(k,i-2)=0.0d0
4314             Ctobr(k,i-2)=0.0d0
4315             Dtobr2(k,i-2)=0.0d0
4316             do l=1,2
4317               EUg(l,k,i-2)=0.0d0
4318               CUg(l,k,i-2)=0.0d0
4319               DUg(l,k,i-2)=0.0d0
4320               DtUg2(l,k,i-2)=0.0d0
4321             enddo
4322           enddo
4323         endif
4324         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
4325         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
4326         do k=1,2
4327           muder(k,i-2)=Ub2der(k,i-2)
4328         enddo
4329 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
4330         if (i.gt. nnt+1 .and. i.lt.nct+1) then
4331           iti1 = itortyp(itype(i-1))
4332         else
4333           iti1=ntortyp+1
4334         endif
4335         do k=1,2
4336           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
4337         enddo
4338 cd        write (iout,*) 'mu ',mu(:,i-2)
4339 cd        write (iout,*) 'mu1',mu1(:,i-2)
4340 cd        write (iout,*) 'mu2',mu2(:,i-2)
4341         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
4342      &  then
4343         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
4344         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
4345         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
4346         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
4347         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
4348 C Vectors and matrices dependent on a single virtual-bond dihedral.
4349         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
4350         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
4351         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
4352         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
4353         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
4354         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
4355         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
4356         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
4357         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
4358         endif
4359       enddo
4360 C Matrices dependent on two consecutive virtual-bond dihedrals.
4361 C The order of matrices is from left to right.
4362       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
4363      &then
4364 c      do i=max0(ivec_start,2),ivec_end
4365       do i=2,nres-1
4366         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
4367         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
4368         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
4369         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
4370         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
4371         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
4372         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
4373         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
4374       enddo
4375       endif
4376 #if defined(MPI) && defined(PARMAT)
4377 #ifdef DEBUG
4378 c      if (fg_rank.eq.0) then
4379         write (iout,*) "Arrays UG and UGDER before GATHER"
4380         do i=1,nres-1
4381           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4382      &     ((ug(l,k,i),l=1,2),k=1,2),
4383      &     ((ugder(l,k,i),l=1,2),k=1,2)
4384         enddo
4385         write (iout,*) "Arrays UG2 and UG2DER"
4386         do i=1,nres-1
4387           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4388      &     ((ug2(l,k,i),l=1,2),k=1,2),
4389      &     ((ug2der(l,k,i),l=1,2),k=1,2)
4390         enddo
4391         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
4392         do i=1,nres-1
4393           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4394      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
4395      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
4396         enddo
4397         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
4398         do i=1,nres-1
4399           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4400      &     costab(i),sintab(i),costab2(i),sintab2(i)
4401         enddo
4402         write (iout,*) "Array MUDER"
4403         do i=1,nres-1
4404           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
4405         enddo
4406 c      endif
4407 #endif
4408       if (nfgtasks.gt.1) then
4409         time00=MPI_Wtime()
4410 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
4411 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
4412 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
4413 #ifdef MATGATHER
4414         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
4415      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4416      &   FG_COMM1,IERR)
4417         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
4418      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4419      &   FG_COMM1,IERR)
4420         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
4421      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4422      &   FG_COMM1,IERR)
4423         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
4424      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4425      &   FG_COMM1,IERR)
4426         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
4427      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4428      &   FG_COMM1,IERR)
4429         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
4430      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4431      &   FG_COMM1,IERR)
4432         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
4433      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
4434      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
4435         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
4436      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
4437      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
4438         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
4439      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
4440      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
4441         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
4442      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
4443      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
4444         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
4445      &  then
4446         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
4447      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4448      &   FG_COMM1,IERR)
4449         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
4450      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4451      &   FG_COMM1,IERR)
4452         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
4453      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4454      &   FG_COMM1,IERR)
4455        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
4456      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4457      &   FG_COMM1,IERR)
4458         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
4459      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4460      &   FG_COMM1,IERR)
4461         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
4462      &   ivec_count(fg_rank1),
4463      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4464      &   FG_COMM1,IERR)
4465         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
4466      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4467      &   FG_COMM1,IERR)
4468         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
4469      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4470      &   FG_COMM1,IERR)
4471         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
4472      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4473      &   FG_COMM1,IERR)
4474         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
4475      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4476      &   FG_COMM1,IERR)
4477         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
4478      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4479      &   FG_COMM1,IERR)
4480         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
4481      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4482      &   FG_COMM1,IERR)
4483         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
4484      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4485      &   FG_COMM1,IERR)
4486         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
4487      &   ivec_count(fg_rank1),
4488      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4489      &   FG_COMM1,IERR)
4490         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
4491      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4492      &   FG_COMM1,IERR)
4493        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
4494      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4495      &   FG_COMM1,IERR)
4496         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
4497      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4498      &   FG_COMM1,IERR)
4499        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
4500      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4501      &   FG_COMM1,IERR)
4502         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
4503      &   ivec_count(fg_rank1),
4504      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4505      &   FG_COMM1,IERR)
4506         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
4507      &   ivec_count(fg_rank1),
4508      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4509      &   FG_COMM1,IERR)
4510         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
4511      &   ivec_count(fg_rank1),
4512      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
4513      &   MPI_MAT2,FG_COMM1,IERR)
4514         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
4515      &   ivec_count(fg_rank1),
4516      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
4517      &   MPI_MAT2,FG_COMM1,IERR)
4518         endif
4519 #else
4520 c Passes matrix info through the ring
4521       isend=fg_rank1
4522       irecv=fg_rank1-1
4523       if (irecv.lt.0) irecv=nfgtasks1-1
4524       iprev=irecv
4525       inext=fg_rank1+1
4526       if (inext.ge.nfgtasks1) inext=0
4527       do i=1,nfgtasks1-1
4528 c        write (iout,*) "isend",isend," irecv",irecv
4529 c        call flush(iout)
4530         lensend=lentyp(isend)
4531         lenrecv=lentyp(irecv)
4532 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
4533 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
4534 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
4535 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
4536 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
4537 c        write (iout,*) "Gather ROTAT1"
4538 c        call flush(iout)
4539 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
4540 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
4541 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
4542 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
4543 c        write (iout,*) "Gather ROTAT2"
4544 c        call flush(iout)
4545         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
4546      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
4547      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
4548      &   iprev,4400+irecv,FG_COMM,status,IERR)
4549 c        write (iout,*) "Gather ROTAT_OLD"
4550 c        call flush(iout)
4551         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
4552      &   MPI_PRECOMP11(lensend),inext,5500+isend,
4553      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
4554      &   iprev,5500+irecv,FG_COMM,status,IERR)
4555 c        write (iout,*) "Gather PRECOMP11"
4556 c        call flush(iout)
4557         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
4558      &   MPI_PRECOMP12(lensend),inext,6600+isend,
4559      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
4560      &   iprev,6600+irecv,FG_COMM,status,IERR)
4561 c        write (iout,*) "Gather PRECOMP12"
4562 c        call flush(iout)
4563         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
4564      &  then
4565         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
4566      &   MPI_ROTAT2(lensend),inext,7700+isend,
4567      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
4568      &   iprev,7700+irecv,FG_COMM,status,IERR)
4569 c        write (iout,*) "Gather PRECOMP21"
4570 c        call flush(iout)
4571         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
4572      &   MPI_PRECOMP22(lensend),inext,8800+isend,
4573      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
4574      &   iprev,8800+irecv,FG_COMM,status,IERR)
4575 c        write (iout,*) "Gather PRECOMP22"
4576 c        call flush(iout)
4577         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
4578      &   MPI_PRECOMP23(lensend),inext,9900+isend,
4579      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
4580      &   MPI_PRECOMP23(lenrecv),
4581      &   iprev,9900+irecv,FG_COMM,status,IERR)
4582 c        write (iout,*) "Gather PRECOMP23"
4583 c        call flush(iout)
4584         endif
4585         isend=irecv
4586         irecv=irecv-1
4587         if (irecv.lt.0) irecv=nfgtasks1-1
4588       enddo
4589 #endif
4590         time_gather=time_gather+MPI_Wtime()-time00
4591       endif
4592 #ifdef DEBUG
4593 c      if (fg_rank.eq.0) then
4594         write (iout,*) "Arrays UG and UGDER"
4595         do i=1,nres-1
4596           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4597      &     ((ug(l,k,i),l=1,2),k=1,2),
4598      &     ((ugder(l,k,i),l=1,2),k=1,2)
4599         enddo
4600         write (iout,*) "Arrays UG2 and UG2DER"
4601         do i=1,nres-1
4602           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4603      &     ((ug2(l,k,i),l=1,2),k=1,2),
4604      &     ((ug2der(l,k,i),l=1,2),k=1,2)
4605         enddo
4606         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
4607         do i=1,nres-1
4608           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4609      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
4610      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
4611         enddo
4612         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
4613         do i=1,nres-1
4614           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4615      &     costab(i),sintab(i),costab2(i),sintab2(i)
4616         enddo
4617         write (iout,*) "Array MUDER"
4618         do i=1,nres-1
4619           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
4620         enddo
4621 c      endif
4622 #endif
4623 #endif
4624 cd      do i=1,nres
4625 cd        iti = itortyp(itype(i))
4626 cd        write (iout,*) i
4627 cd        do j=1,2
4628 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
4629 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
4630 cd        enddo
4631 cd      enddo
4632       return
4633       end
4634 C--------------------------------------------------------------------------
4635       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
4636 C
4637 C This subroutine calculates the average interaction energy and its gradient
4638 C in the virtual-bond vectors between non-adjacent peptide groups, based on
4639 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
4640 C The potential depends both on the distance of peptide-group centers and on
4641 C the orientation of the CA-CA virtual bonds.
4642 C
4643       implicit real*8 (a-h,o-z)
4644 #ifdef MPI
4645       include 'mpif.h'
4646 #endif
4647       include 'DIMENSIONS'
4648       include 'COMMON.CONTROL'
4649       include 'COMMON.SETUP'
4650       include 'COMMON.IOUNITS'
4651       include 'COMMON.GEO'
4652       include 'COMMON.VAR'
4653       include 'COMMON.LOCAL'
4654       include 'COMMON.CHAIN'
4655       include 'COMMON.DERIV'
4656       include 'COMMON.INTERACT'
4657       include 'COMMON.CONTACTS'
4658       include 'COMMON.TORSION'
4659       include 'COMMON.VECTORS'
4660       include 'COMMON.FFIELD'
4661       include 'COMMON.TIME1'
4662       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
4663      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
4664       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
4665      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
4666       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4667      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4668      &    num_conti,j1,j2
4669 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
4670 #ifdef MOMENT
4671       double precision scal_el /1.0d0/
4672 #else
4673       double precision scal_el /0.5d0/
4674 #endif
4675 C 12/13/98
4676 C 13-go grudnia roku pamietnego...
4677       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4678      &                   0.0d0,1.0d0,0.0d0,
4679      &                   0.0d0,0.0d0,1.0d0/
4680 cd      write(iout,*) 'In EELEC'
4681 cd      do i=1,nloctyp
4682 cd        write(iout,*) 'Type',i
4683 cd        write(iout,*) 'B1',B1(:,i)
4684 cd        write(iout,*) 'B2',B2(:,i)
4685 cd        write(iout,*) 'CC',CC(:,:,i)
4686 cd        write(iout,*) 'DD',DD(:,:,i)
4687 cd        write(iout,*) 'EE',EE(:,:,i)
4688 cd      enddo
4689 cd      call check_vecgrad
4690 cd      stop
4691       if (icheckgrad.eq.1) then
4692         do i=1,nres-1
4693           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
4694           do k=1,3
4695             dc_norm(k,i)=dc(k,i)*fac
4696           enddo
4697 c          write (iout,*) 'i',i,' fac',fac
4698         enddo
4699       endif
4700       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4701      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
4702      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
4703 c        call vec_and_deriv
4704 #ifdef TIMING
4705         time01=MPI_Wtime()
4706 #endif
4707         call set_matrices
4708 #ifdef TIMING
4709         time_mat=time_mat+MPI_Wtime()-time01
4710 #endif
4711       endif
4712 cd      do i=1,nres-1
4713 cd        write (iout,*) 'i=',i
4714 cd        do k=1,3
4715 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
4716 cd        enddo
4717 cd        do k=1,3
4718 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
4719 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
4720 cd        enddo
4721 cd      enddo
4722       t_eelecij=0.0d0
4723       ees=0.0D0
4724       evdw1=0.0D0
4725       eel_loc=0.0d0
4726       eello_turn3=0.0d0
4727       eello_turn4=0.0d0
4728       ind=0
4729       do i=1,nres
4730         num_cont_hb(i)=0
4731       enddo
4732 cd      print '(a)','Enter EELEC'
4733 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
4734       do i=1,nres
4735         gel_loc_loc(i)=0.0d0
4736         gcorr_loc(i)=0.0d0
4737       enddo
4738 c
4739 c
4740 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
4741 C
4742 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
4743 C
4744       do i=iturn3_start,iturn3_end
4745         dxi=dc(1,i)
4746         dyi=dc(2,i)
4747         dzi=dc(3,i)
4748         dx_normi=dc_norm(1,i)
4749         dy_normi=dc_norm(2,i)
4750         dz_normi=dc_norm(3,i)
4751         xmedi=c(1,i)+0.5d0*dxi
4752         ymedi=c(2,i)+0.5d0*dyi
4753         zmedi=c(3,i)+0.5d0*dzi
4754         num_conti=0
4755         call eelecij(i,i+2,ees,evdw1,eel_loc)
4756         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
4757         num_cont_hb(i)=num_conti
4758       enddo
4759       do i=iturn4_start,iturn4_end
4760         dxi=dc(1,i)
4761         dyi=dc(2,i)
4762         dzi=dc(3,i)
4763         dx_normi=dc_norm(1,i)
4764         dy_normi=dc_norm(2,i)
4765         dz_normi=dc_norm(3,i)
4766         xmedi=c(1,i)+0.5d0*dxi
4767         ymedi=c(2,i)+0.5d0*dyi
4768         zmedi=c(3,i)+0.5d0*dzi
4769         num_conti=num_cont_hb(i)
4770         call eelecij(i,i+3,ees,evdw1,eel_loc)
4771         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
4772         num_cont_hb(i)=num_conti
4773       enddo   ! i
4774 c
4775 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
4776 c
4777       do i=iatel_s,iatel_e
4778         dxi=dc(1,i)
4779         dyi=dc(2,i)
4780         dzi=dc(3,i)
4781         dx_normi=dc_norm(1,i)
4782         dy_normi=dc_norm(2,i)
4783         dz_normi=dc_norm(3,i)
4784         xmedi=c(1,i)+0.5d0*dxi
4785         ymedi=c(2,i)+0.5d0*dyi
4786         zmedi=c(3,i)+0.5d0*dzi
4787 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
4788         num_conti=num_cont_hb(i)
4789         do j=ielstart(i),ielend(i)
4790           call eelecij(i,j,ees,evdw1,eel_loc)
4791         enddo ! j
4792         num_cont_hb(i)=num_conti
4793       enddo   ! i
4794 c      write (iout,*) "Number of loop steps in EELEC:",ind
4795 cd      do i=1,nres
4796 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
4797 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
4798 cd      enddo
4799 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
4800 ccc      eel_loc=eel_loc+eello_turn3
4801 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
4802       return
4803       end
4804 C-------------------------------------------------------------------------------
4805       subroutine eelecij(i,j,ees,evdw1,eel_loc)
4806       implicit real*8 (a-h,o-z)
4807       include 'DIMENSIONS'
4808 #ifdef MPI
4809       include "mpif.h"
4810 #endif
4811       include 'COMMON.CONTROL'
4812       include 'COMMON.IOUNITS'
4813       include 'COMMON.GEO'
4814       include 'COMMON.VAR'
4815       include 'COMMON.LOCAL'
4816       include 'COMMON.CHAIN'
4817       include 'COMMON.DERIV'
4818       include 'COMMON.INTERACT'
4819       include 'COMMON.CONTACTS'
4820       include 'COMMON.TORSION'
4821       include 'COMMON.VECTORS'
4822       include 'COMMON.FFIELD'
4823       include 'COMMON.TIME1'
4824       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
4825      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
4826       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
4827      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
4828       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4829      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4830      &    num_conti,j1,j2
4831 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
4832 #ifdef MOMENT
4833       double precision scal_el /1.0d0/
4834 #else
4835       double precision scal_el /0.5d0/
4836 #endif
4837 C 12/13/98
4838 C 13-go grudnia roku pamietnego...
4839       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4840      &                   0.0d0,1.0d0,0.0d0,
4841      &                   0.0d0,0.0d0,1.0d0/
4842 c          time00=MPI_Wtime()
4843 cd      write (iout,*) "eelecij",i,j
4844 c          ind=ind+1
4845           iteli=itel(i)
4846           itelj=itel(j)
4847           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
4848           aaa=app(iteli,itelj)
4849           bbb=bpp(iteli,itelj)
4850           ael6i=ael6(iteli,itelj)
4851           ael3i=ael3(iteli,itelj)
4852           dxj=dc(1,j)
4853           dyj=dc(2,j)
4854           dzj=dc(3,j)
4855           dx_normj=dc_norm(1,j)
4856           dy_normj=dc_norm(2,j)
4857           dz_normj=dc_norm(3,j)
4858           xj=c(1,j)+0.5D0*dxj-xmedi
4859           yj=c(2,j)+0.5D0*dyj-ymedi
4860           zj=c(3,j)+0.5D0*dzj-zmedi
4861           rij=xj*xj+yj*yj+zj*zj
4862           rrmij=1.0D0/rij
4863           rij=dsqrt(rij)
4864           rmij=1.0D0/rij
4865           r3ij=rrmij*rmij
4866           r6ij=r3ij*r3ij
4867           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4868           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4869           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4870           fac=cosa-3.0D0*cosb*cosg
4871           ev1=aaa*r6ij*r6ij
4872 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4873           if (j.eq.i+2) ev1=scal_el*ev1
4874           ev2=bbb*r6ij
4875           fac3=ael6i*r6ij
4876           fac4=ael3i*r3ij
4877           evdwij=ev1+ev2
4878           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4879           el2=fac4*fac
4880           eesij=el1+el2
4881 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4882           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4883           ees=ees+eesij
4884           evdw1=evdw1+evdwij
4885 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4886 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4887 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4888 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4889
4890           if (energy_dec) then
4891               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
4892               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
4893           endif
4894
4895 C
4896 C Calculate contributions to the Cartesian gradient.
4897 C
4898 #ifdef SPLITELE
4899           facvdw=-6*rrmij*(ev1+evdwij)
4900           facel=-3*rrmij*(el1+eesij)
4901           fac1=fac
4902           erij(1)=xj*rmij
4903           erij(2)=yj*rmij
4904           erij(3)=zj*rmij
4905 *
4906 * Radial derivatives. First process both termini of the fragment (i,j)
4907 *
4908           ggg(1)=facel*xj
4909           ggg(2)=facel*yj
4910           ggg(3)=facel*zj
4911 c          do k=1,3
4912 c            ghalf=0.5D0*ggg(k)
4913 c            gelc(k,i)=gelc(k,i)+ghalf
4914 c            gelc(k,j)=gelc(k,j)+ghalf
4915 c          enddo
4916 c 9/28/08 AL Gradient compotents will be summed only at the end
4917           do k=1,3
4918             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4919             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4920           enddo
4921 *
4922 * Loop over residues i+1 thru j-1.
4923 *
4924 cgrad          do k=i+1,j-1
4925 cgrad            do l=1,3
4926 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4927 cgrad            enddo
4928 cgrad          enddo
4929           ggg(1)=facvdw*xj
4930           ggg(2)=facvdw*yj
4931           ggg(3)=facvdw*zj
4932 c          do k=1,3
4933 c            ghalf=0.5D0*ggg(k)
4934 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4935 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4936 c          enddo
4937 c 9/28/08 AL Gradient compotents will be summed only at the end
4938           do k=1,3
4939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4940             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4941           enddo
4942 *
4943 * Loop over residues i+1 thru j-1.
4944 *
4945 cgrad          do k=i+1,j-1
4946 cgrad            do l=1,3
4947 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4948 cgrad            enddo
4949 cgrad          enddo
4950 #else
4951           facvdw=ev1+evdwij
4952           facel=el1+eesij
4953           fac1=fac
4954           fac=-3*rrmij*(facvdw+facvdw+facel)
4955           erij(1)=xj*rmij
4956           erij(2)=yj*rmij
4957           erij(3)=zj*rmij
4958 *
4959 * Radial derivatives. First process both termini of the fragment (i,j)
4960 *
4961           ggg(1)=fac*xj
4962           ggg(2)=fac*yj
4963           ggg(3)=fac*zj
4964 c          do k=1,3
4965 c            ghalf=0.5D0*ggg(k)
4966 c            gelc(k,i)=gelc(k,i)+ghalf
4967 c            gelc(k,j)=gelc(k,j)+ghalf
4968 c          enddo
4969 c 9/28/08 AL Gradient compotents will be summed only at the end
4970           do k=1,3
4971             gelc_long(k,j)=gelc(k,j)+ggg(k)
4972             gelc_long(k,i)=gelc(k,i)-ggg(k)
4973           enddo
4974 *
4975 * Loop over residues i+1 thru j-1.
4976 *
4977 cgrad          do k=i+1,j-1
4978 cgrad            do l=1,3
4979 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4980 cgrad            enddo
4981 cgrad          enddo
4982 c 9/28/08 AL Gradient compotents will be summed only at the end
4983           ggg(1)=facvdw*xj
4984           ggg(2)=facvdw*yj
4985           ggg(3)=facvdw*zj
4986           do k=1,3
4987             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4988             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4989           enddo
4990 #endif
4991 *
4992 * Angular part
4993 *
4994           ecosa=2.0D0*fac3*fac1+fac4
4995           fac4=-3.0D0*fac4
4996           fac3=-6.0D0*fac3
4997           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4998           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4999           do k=1,3
5000             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
5001             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
5002           enddo
5003 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
5004 cd   &          (dcosg(k),k=1,3)
5005           do k=1,3
5006             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
5007           enddo
5008 c          do k=1,3
5009 c            ghalf=0.5D0*ggg(k)
5010 c            gelc(k,i)=gelc(k,i)+ghalf
5011 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
5012 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
5013 c            gelc(k,j)=gelc(k,j)+ghalf
5014 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
5015 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
5016 c          enddo
5017 cgrad          do k=i+1,j-1
5018 cgrad            do l=1,3
5019 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
5020 cgrad            enddo
5021 cgrad          enddo
5022           do k=1,3
5023             gelc(k,i)=gelc(k,i)
5024      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
5025      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
5026             gelc(k,j)=gelc(k,j)
5027      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
5028      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
5029             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
5030             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
5031           enddo
5032           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
5033      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
5034      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
5035 C
5036 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
5037 C   energy of a peptide unit is assumed in the form of a second-order
5038 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
5039 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
5040 C   are computed for EVERY pair of non-contiguous peptide groups.
5041 C
5042           if (j.lt.nres-1) then
5043             j1=j+1
5044             j2=j-1
5045           else
5046             j1=j-1
5047             j2=j-2
5048           endif
5049           kkk=0
5050           do k=1,2
5051             do l=1,2
5052               kkk=kkk+1
5053               muij(kkk)=mu(k,i)*mu(l,j)
5054             enddo
5055           enddo
5056 cd         write (iout,*) 'EELEC: i',i,' j',j
5057 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
5058 cd          write(iout,*) 'muij',muij
5059           ury=scalar(uy(1,i),erij)
5060           urz=scalar(uz(1,i),erij)
5061           vry=scalar(uy(1,j),erij)
5062           vrz=scalar(uz(1,j),erij)
5063           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
5064           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
5065           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
5066           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
5067           fac=dsqrt(-ael6i)*r3ij
5068           a22=a22*fac
5069           a23=a23*fac
5070           a32=a32*fac
5071           a33=a33*fac
5072 cd          write (iout,'(4i5,4f10.5)')
5073 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
5074 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
5075 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
5076 cd     &      uy(:,j),uz(:,j)
5077 cd          write (iout,'(4f10.5)')
5078 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
5079 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
5080 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
5081 cd           write (iout,'(9f10.5/)')
5082 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
5083 C Derivatives of the elements of A in virtual-bond vectors
5084           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
5085           do k=1,3
5086             uryg(k,1)=scalar(erder(1,k),uy(1,i))
5087             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
5088             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
5089             urzg(k,1)=scalar(erder(1,k),uz(1,i))
5090             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
5091             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
5092             vryg(k,1)=scalar(erder(1,k),uy(1,j))
5093             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
5094             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
5095             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
5096             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
5097             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
5098           enddo
5099 C Compute radial contributions to the gradient
5100           facr=-3.0d0*rrmij
5101           a22der=a22*facr
5102           a23der=a23*facr
5103           a32der=a32*facr
5104           a33der=a33*facr
5105           agg(1,1)=a22der*xj
5106           agg(2,1)=a22der*yj
5107           agg(3,1)=a22der*zj
5108           agg(1,2)=a23der*xj
5109           agg(2,2)=a23der*yj
5110           agg(3,2)=a23der*zj
5111           agg(1,3)=a32der*xj
5112           agg(2,3)=a32der*yj
5113           agg(3,3)=a32der*zj
5114           agg(1,4)=a33der*xj
5115           agg(2,4)=a33der*yj
5116           agg(3,4)=a33der*zj
5117 C Add the contributions coming from er
5118           fac3=-3.0d0*fac
5119           do k=1,3
5120             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
5121             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
5122             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
5123             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
5124           enddo
5125           do k=1,3
5126 C Derivatives in DC(i)
5127 cgrad            ghalf1=0.5d0*agg(k,1)
5128 cgrad            ghalf2=0.5d0*agg(k,2)
5129 cgrad            ghalf3=0.5d0*agg(k,3)
5130 cgrad            ghalf4=0.5d0*agg(k,4)
5131             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
5132      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
5133             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
5134      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
5135             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
5136      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
5137             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
5138      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
5139 C Derivatives in DC(i+1)
5140             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
5141      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
5142             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
5143      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
5144             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
5145      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
5146             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
5147      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
5148 C Derivatives in DC(j)
5149             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
5150      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
5151             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
5152      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
5153             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
5154      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
5155             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
5156      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
5157 C Derivatives in DC(j+1) or DC(nres-1)
5158             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
5159      &      -3.0d0*vryg(k,3)*ury)
5160             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
5161      &      -3.0d0*vrzg(k,3)*ury)
5162             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
5163      &      -3.0d0*vryg(k,3)*urz)
5164             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
5165      &      -3.0d0*vrzg(k,3)*urz)
5166 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
5167 cgrad              do l=1,4
5168 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
5169 cgrad              enddo
5170 cgrad            endif
5171           enddo
5172           acipa(1,1)=a22
5173           acipa(1,2)=a23
5174           acipa(2,1)=a32
5175           acipa(2,2)=a33
5176           a22=-a22
5177           a23=-a23
5178           do l=1,2
5179             do k=1,3
5180               agg(k,l)=-agg(k,l)
5181               aggi(k,l)=-aggi(k,l)
5182               aggi1(k,l)=-aggi1(k,l)
5183               aggj(k,l)=-aggj(k,l)
5184               aggj1(k,l)=-aggj1(k,l)
5185             enddo
5186           enddo
5187           if (j.lt.nres-1) then
5188             a22=-a22
5189             a32=-a32
5190             do l=1,3,2
5191               do k=1,3
5192                 agg(k,l)=-agg(k,l)
5193                 aggi(k,l)=-aggi(k,l)
5194                 aggi1(k,l)=-aggi1(k,l)
5195                 aggj(k,l)=-aggj(k,l)
5196                 aggj1(k,l)=-aggj1(k,l)
5197               enddo
5198             enddo
5199           else
5200             a22=-a22
5201             a23=-a23
5202             a32=-a32
5203             a33=-a33
5204             do l=1,4
5205               do k=1,3
5206                 agg(k,l)=-agg(k,l)
5207                 aggi(k,l)=-aggi(k,l)
5208                 aggi1(k,l)=-aggi1(k,l)
5209                 aggj(k,l)=-aggj(k,l)
5210                 aggj1(k,l)=-aggj1(k,l)
5211               enddo
5212             enddo
5213           endif
5214           ENDIF ! WCORR
5215           IF (wel_loc.gt.0.0d0) THEN
5216 C Contribution to the local-electrostatic energy coming from the i-j pair
5217           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
5218      &     +a33*muij(4)
5219 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
5220
5221           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5222      &            'eelloc',i,j,eel_loc_ij
5223
5224           eel_loc=eel_loc+eel_loc_ij
5225 C Partial derivatives in virtual-bond dihedral angles gamma
5226           if (i.gt.1)
5227      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
5228      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
5229      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
5230           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
5231      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
5232      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
5233 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
5234           do l=1,3
5235             ggg(l)=agg(l,1)*muij(1)+
5236      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
5237             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
5238             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
5239 cgrad            ghalf=0.5d0*ggg(l)
5240 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
5241 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
5242           enddo
5243 cgrad          do k=i+1,j2
5244 cgrad            do l=1,3
5245 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
5246 cgrad            enddo
5247 cgrad          enddo
5248 C Remaining derivatives of eello
5249           do l=1,3
5250             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
5251      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
5252             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
5253      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
5254             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
5255      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
5256             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
5257      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
5258           enddo
5259           ENDIF
5260 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
5261 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
5262           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
5263      &       .and. num_conti.le.maxconts) then
5264 c            write (iout,*) i,j," entered corr"
5265 C
5266 C Calculate the contact function. The ith column of the array JCONT will
5267 C contain the numbers of atoms that make contacts with the atom I (of numbers
5268 C greater than I). The arrays FACONT and GACONT will contain the values of
5269 C the contact function and its derivative.
5270 c           r0ij=1.02D0*rpp(iteli,itelj)
5271 c           r0ij=1.11D0*rpp(iteli,itelj)
5272             r0ij=2.20D0*rpp(iteli,itelj)
5273 c           r0ij=1.55D0*rpp(iteli,itelj)
5274             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
5275             if (fcont.gt.0.0D0) then
5276               num_conti=num_conti+1
5277               if (num_conti.gt.maxconts) then
5278                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
5279      &                         ' will skip next contacts for this conf.'
5280               else
5281                 jcont_hb(num_conti,i)=j
5282 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
5283 cd     &           " jcont_hb",jcont_hb(num_conti,i)
5284                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
5285      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
5286 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
5287 C  terms.
5288                 d_cont(num_conti,i)=rij
5289 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
5290 C     --- Electrostatic-interaction matrix ---
5291                 a_chuj(1,1,num_conti,i)=a22
5292                 a_chuj(1,2,num_conti,i)=a23
5293                 a_chuj(2,1,num_conti,i)=a32
5294                 a_chuj(2,2,num_conti,i)=a33
5295 C     --- Gradient of rij
5296                 do kkk=1,3
5297                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
5298                 enddo
5299                 kkll=0
5300                 do k=1,2
5301                   do l=1,2
5302                     kkll=kkll+1
5303                     do m=1,3
5304                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
5305                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
5306                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
5307                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
5308                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
5309                     enddo
5310                   enddo
5311                 enddo
5312                 ENDIF
5313                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
5314 C Calculate contact energies
5315                 cosa4=4.0D0*cosa
5316                 wij=cosa-3.0D0*cosb*cosg
5317                 cosbg1=cosb+cosg
5318                 cosbg2=cosb-cosg
5319 c               fac3=dsqrt(-ael6i)/r0ij**3
5320                 fac3=dsqrt(-ael6i)*r3ij
5321 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
5322                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
5323                 if (ees0tmp.gt.0) then
5324                   ees0pij=dsqrt(ees0tmp)
5325                 else
5326                   ees0pij=0
5327                 endif
5328 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
5329                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
5330                 if (ees0tmp.gt.0) then
5331                   ees0mij=dsqrt(ees0tmp)
5332                 else
5333                   ees0mij=0
5334                 endif
5335 c               ees0mij=0.0D0
5336                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
5337                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
5338 C Diagnostics. Comment out or remove after debugging!
5339 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
5340 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
5341 c               ees0m(num_conti,i)=0.0D0
5342 C End diagnostics.
5343 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
5344 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
5345 C Angular derivatives of the contact function
5346                 ees0pij1=fac3/ees0pij
5347                 ees0mij1=fac3/ees0mij
5348                 fac3p=-3.0D0*fac3*rrmij
5349                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
5350                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
5351 c               ees0mij1=0.0D0
5352                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
5353                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
5354                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
5355                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
5356                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
5357                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
5358                 ecosap=ecosa1+ecosa2
5359                 ecosbp=ecosb1+ecosb2
5360                 ecosgp=ecosg1+ecosg2
5361                 ecosam=ecosa1-ecosa2
5362                 ecosbm=ecosb1-ecosb2
5363                 ecosgm=ecosg1-ecosg2
5364 C Diagnostics
5365 c               ecosap=ecosa1
5366 c               ecosbp=ecosb1
5367 c               ecosgp=ecosg1
5368 c               ecosam=0.0D0
5369 c               ecosbm=0.0D0
5370 c               ecosgm=0.0D0
5371 C End diagnostics
5372                 facont_hb(num_conti,i)=fcont
5373                 fprimcont=fprimcont/rij
5374 cd              facont_hb(num_conti,i)=1.0D0
5375 C Following line is for diagnostics.
5376 cd              fprimcont=0.0D0
5377                 do k=1,3
5378                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
5379                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
5380                 enddo
5381                 do k=1,3
5382                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
5383                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
5384                 enddo
5385                 gggp(1)=gggp(1)+ees0pijp*xj
5386                 gggp(2)=gggp(2)+ees0pijp*yj
5387                 gggp(3)=gggp(3)+ees0pijp*zj
5388                 gggm(1)=gggm(1)+ees0mijp*xj
5389                 gggm(2)=gggm(2)+ees0mijp*yj
5390                 gggm(3)=gggm(3)+ees0mijp*zj
5391 C Derivatives due to the contact function
5392                 gacont_hbr(1,num_conti,i)=fprimcont*xj
5393                 gacont_hbr(2,num_conti,i)=fprimcont*yj
5394                 gacont_hbr(3,num_conti,i)=fprimcont*zj
5395                 do k=1,3
5396 c
5397 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
5398 c          following the change of gradient-summation algorithm.
5399 c
5400 cgrad                  ghalfp=0.5D0*gggp(k)
5401 cgrad                  ghalfm=0.5D0*gggm(k)
5402                   gacontp_hb1(k,num_conti,i)=!ghalfp
5403      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
5404      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
5405                   gacontp_hb2(k,num_conti,i)=!ghalfp
5406      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
5407      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
5408                   gacontp_hb3(k,num_conti,i)=gggp(k)
5409                   gacontm_hb1(k,num_conti,i)=!ghalfm
5410      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
5411      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
5412                   gacontm_hb2(k,num_conti,i)=!ghalfm
5413      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
5414      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
5415                   gacontm_hb3(k,num_conti,i)=gggm(k)
5416                 enddo
5417 C Diagnostics. Comment out or remove after debugging!
5418 cdiag           do k=1,3
5419 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
5420 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
5421 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
5422 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
5423 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
5424 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
5425 cdiag           enddo
5426               ENDIF ! wcorr
5427               endif  ! num_conti.le.maxconts
5428             endif  ! fcont.gt.0
5429           endif    ! j.gt.i+1
5430           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
5431             do k=1,4
5432               do l=1,3
5433                 ghalf=0.5d0*agg(l,k)
5434                 aggi(l,k)=aggi(l,k)+ghalf
5435                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
5436                 aggj(l,k)=aggj(l,k)+ghalf
5437               enddo
5438             enddo
5439             if (j.eq.nres-1 .and. i.lt.j-2) then
5440               do k=1,4
5441                 do l=1,3
5442                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
5443                 enddo
5444               enddo
5445             endif
5446           endif
5447 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
5448       return
5449       end
5450 C-----------------------------------------------------------------------------
5451       subroutine eturn3(i,eello_turn3)
5452 C Third- and fourth-order contributions from turns
5453       implicit real*8 (a-h,o-z)
5454       include 'DIMENSIONS'
5455       include 'COMMON.IOUNITS'
5456       include 'COMMON.GEO'
5457       include 'COMMON.VAR'
5458       include 'COMMON.LOCAL'
5459       include 'COMMON.CHAIN'
5460       include 'COMMON.DERIV'
5461       include 'COMMON.INTERACT'
5462       include 'COMMON.CONTACTS'
5463       include 'COMMON.TORSION'
5464       include 'COMMON.VECTORS'
5465       include 'COMMON.FFIELD'
5466       include 'COMMON.CONTROL'
5467       dimension ggg(3)
5468       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5469      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5470      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
5471       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5472      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5473       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5474      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5475      &    num_conti,j1,j2
5476       j=i+2
5477 c      write (iout,*) "eturn3",i,j,j1,j2
5478       a_temp(1,1)=a22
5479       a_temp(1,2)=a23
5480       a_temp(2,1)=a32
5481       a_temp(2,2)=a33
5482 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5483 C
5484 C               Third-order contributions
5485 C
5486 C                 (i+2)o----(i+3)
5487 C                      | |
5488 C                      | |
5489 C                 (i+1)o----i
5490 C
5491 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5492 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5493         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5494         call transpose2(auxmat(1,1),auxmat1(1,1))
5495         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5496         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5497         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5498      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
5499 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5500 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5501 cd     &    ' eello_turn3_num',4*eello_turn3_num
5502 C Derivatives in gamma(i)
5503         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5504         call transpose2(auxmat2(1,1),auxmat3(1,1))
5505         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5506         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5507 C Derivatives in gamma(i+1)
5508         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5509         call transpose2(auxmat2(1,1),auxmat3(1,1))
5510         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5511         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5512      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5513 C Cartesian derivatives
5514         do l=1,3
5515 c            ghalf1=0.5d0*agg(l,1)
5516 c            ghalf2=0.5d0*agg(l,2)
5517 c            ghalf3=0.5d0*agg(l,3)
5518 c            ghalf4=0.5d0*agg(l,4)
5519           a_temp(1,1)=aggi(l,1)!+ghalf1
5520           a_temp(1,2)=aggi(l,2)!+ghalf2
5521           a_temp(2,1)=aggi(l,3)!+ghalf3
5522           a_temp(2,2)=aggi(l,4)!+ghalf4
5523           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5524           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5525      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5526           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5527           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5528           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5529           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5530           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5531           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5532      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5533           a_temp(1,1)=aggj(l,1)!+ghalf1
5534           a_temp(1,2)=aggj(l,2)!+ghalf2
5535           a_temp(2,1)=aggj(l,3)!+ghalf3
5536           a_temp(2,2)=aggj(l,4)!+ghalf4
5537           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5538           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5539      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5540           a_temp(1,1)=aggj1(l,1)
5541           a_temp(1,2)=aggj1(l,2)
5542           a_temp(2,1)=aggj1(l,3)
5543           a_temp(2,2)=aggj1(l,4)
5544           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5545           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5546      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5547         enddo
5548       return
5549       end
5550 C-------------------------------------------------------------------------------
5551       subroutine eturn4(i,eello_turn4)
5552 C Third- and fourth-order contributions from turns
5553       implicit real*8 (a-h,o-z)
5554       include 'DIMENSIONS'
5555       include 'COMMON.IOUNITS'
5556       include 'COMMON.GEO'
5557       include 'COMMON.VAR'
5558       include 'COMMON.LOCAL'
5559       include 'COMMON.CHAIN'
5560       include 'COMMON.DERIV'
5561       include 'COMMON.INTERACT'
5562       include 'COMMON.CONTACTS'
5563       include 'COMMON.TORSION'
5564       include 'COMMON.VECTORS'
5565       include 'COMMON.FFIELD'
5566       include 'COMMON.CONTROL'
5567       dimension ggg(3)
5568       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5569      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5570      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
5571       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5572      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5573       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5574      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5575      &    num_conti,j1,j2
5576       j=i+3
5577 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5578 C
5579 C               Fourth-order contributions
5580 C
5581 C                 (i+3)o----(i+4)
5582 C                     /  |
5583 C               (i+2)o   |
5584 C                     \  |
5585 C                 (i+1)o----i
5586 C
5587 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5588 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5589 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5590         a_temp(1,1)=a22
5591         a_temp(1,2)=a23
5592         a_temp(2,1)=a32
5593         a_temp(2,2)=a33
5594         iti1=itortyp(itype(i+1))
5595         iti2=itortyp(itype(i+2))
5596         iti3=itortyp(itype(i+3))
5597 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5598         call transpose2(EUg(1,1,i+1),e1t(1,1))
5599         call transpose2(Eug(1,1,i+2),e2t(1,1))
5600         call transpose2(Eug(1,1,i+3),e3t(1,1))
5601         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5602         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5603         s1=scalar2(b1(1,iti2),auxvec(1))
5604         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5605         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5606         s2=scalar2(b1(1,iti1),auxvec(1))
5607         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5608         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5609         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5610         eello_turn4=eello_turn4-(s1+s2+s3)
5611         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5612      &      'eturn4',i,j,-(s1+s2+s3)
5613 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5614 cd     &    ' eello_turn4_num',8*eello_turn4_num
5615 C Derivatives in gamma(i)
5616         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5617         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5618         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5619         s1=scalar2(b1(1,iti2),auxvec(1))
5620         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5621         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5622         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5623 C Derivatives in gamma(i+1)
5624         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5625         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5626         s2=scalar2(b1(1,iti1),auxvec(1))
5627         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5628         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5629         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5630         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5631 C Derivatives in gamma(i+2)
5632         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5633         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5634         s1=scalar2(b1(1,iti2),auxvec(1))
5635         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5636         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5637         s2=scalar2(b1(1,iti1),auxvec(1))
5638         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5639         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5640         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5641         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5642 C Cartesian derivatives
5643 C Derivatives of this turn contributions in DC(i+2)
5644         if (j.lt.nres-1) then
5645           do l=1,3
5646             a_temp(1,1)=agg(l,1)
5647             a_temp(1,2)=agg(l,2)
5648             a_temp(2,1)=agg(l,3)
5649             a_temp(2,2)=agg(l,4)
5650             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5651             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5652             s1=scalar2(b1(1,iti2),auxvec(1))
5653             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5654             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5655             s2=scalar2(b1(1,iti1),auxvec(1))
5656             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5657             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5658             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5659             ggg(l)=-(s1+s2+s3)
5660             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5661           enddo
5662         endif
5663 C Remaining derivatives of this turn contribution
5664         do l=1,3
5665           a_temp(1,1)=aggi(l,1)
5666           a_temp(1,2)=aggi(l,2)
5667           a_temp(2,1)=aggi(l,3)
5668           a_temp(2,2)=aggi(l,4)
5669           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5670           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5671           s1=scalar2(b1(1,iti2),auxvec(1))
5672           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5673           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5674           s2=scalar2(b1(1,iti1),auxvec(1))
5675           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5676           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5677           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5678           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5679           a_temp(1,1)=aggi1(l,1)
5680           a_temp(1,2)=aggi1(l,2)
5681           a_temp(2,1)=aggi1(l,3)
5682           a_temp(2,2)=aggi1(l,4)
5683           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5684           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5685           s1=scalar2(b1(1,iti2),auxvec(1))
5686           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5687           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5688           s2=scalar2(b1(1,iti1),auxvec(1))
5689           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5690           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5691           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5692           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5693           a_temp(1,1)=aggj(l,1)
5694           a_temp(1,2)=aggj(l,2)
5695           a_temp(2,1)=aggj(l,3)
5696           a_temp(2,2)=aggj(l,4)
5697           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5698           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5699           s1=scalar2(b1(1,iti2),auxvec(1))
5700           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5701           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5702           s2=scalar2(b1(1,iti1),auxvec(1))
5703           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5704           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5705           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5706           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5707           a_temp(1,1)=aggj1(l,1)
5708           a_temp(1,2)=aggj1(l,2)
5709           a_temp(2,1)=aggj1(l,3)
5710           a_temp(2,2)=aggj1(l,4)
5711           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5712           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5713           s1=scalar2(b1(1,iti2),auxvec(1))
5714           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5715           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5716           s2=scalar2(b1(1,iti1),auxvec(1))
5717           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5718           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5719           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5720 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5721           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5722         enddo
5723       return
5724       end
5725 C-----------------------------------------------------------------------------
5726       subroutine vecpr(u,v,w)
5727       implicit real*8(a-h,o-z)
5728       dimension u(3),v(3),w(3)
5729       w(1)=u(2)*v(3)-u(3)*v(2)
5730       w(2)=-u(1)*v(3)+u(3)*v(1)
5731       w(3)=u(1)*v(2)-u(2)*v(1)
5732       return
5733       end
5734 C-----------------------------------------------------------------------------
5735       subroutine unormderiv(u,ugrad,unorm,ungrad)
5736 C This subroutine computes the derivatives of a normalized vector u, given
5737 C the derivatives computed without normalization conditions, ugrad. Returns
5738 C ungrad.
5739       implicit none
5740       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5741       double precision vec(3)
5742       double precision scalar
5743       integer i,j
5744 c      write (2,*) 'ugrad',ugrad
5745 c      write (2,*) 'u',u
5746       do i=1,3
5747         vec(i)=scalar(ugrad(1,i),u(1))
5748       enddo
5749 c      write (2,*) 'vec',vec
5750       do i=1,3
5751         do j=1,3
5752           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5753         enddo
5754       enddo
5755 c      write (2,*) 'ungrad',ungrad
5756       return
5757       end
5758 C-----------------------------------------------------------------------------
5759       subroutine escp_soft_sphere(evdw2,evdw2_14)
5760 C
5761 C This subroutine calculates the excluded-volume interaction energy between
5762 C peptide-group centers and side chains and its gradient in virtual-bond and
5763 C side-chain vectors.
5764 C
5765       implicit real*8 (a-h,o-z)
5766       include 'DIMENSIONS'
5767       include 'COMMON.GEO'
5768       include 'COMMON.VAR'
5769       include 'COMMON.LOCAL'
5770       include 'COMMON.CHAIN'
5771       include 'COMMON.DERIV'
5772       include 'COMMON.INTERACT'
5773       include 'COMMON.FFIELD'
5774       include 'COMMON.IOUNITS'
5775       include 'COMMON.CONTROL'
5776       dimension ggg(3)
5777       evdw2=0.0D0
5778       evdw2_14=0.0d0
5779       r0_scp=4.5d0
5780 cd    print '(a)','Enter ESCP'
5781 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5782       do i=iatscp_s,iatscp_e
5783         iteli=itel(i)
5784         xi=0.5D0*(c(1,i)+c(1,i+1))
5785         yi=0.5D0*(c(2,i)+c(2,i+1))
5786         zi=0.5D0*(c(3,i)+c(3,i+1))
5787
5788         do iint=1,nscp_gr(i)
5789
5790         do j=iscpstart(i,iint),iscpend(i,iint)
5791           itypj=itype(j)
5792 C Uncomment following three lines for SC-p interactions
5793 c         xj=c(1,nres+j)-xi
5794 c         yj=c(2,nres+j)-yi
5795 c         zj=c(3,nres+j)-zi
5796 C Uncomment following three lines for Ca-p interactions
5797           xj=c(1,j)-xi
5798           yj=c(2,j)-yi
5799           zj=c(3,j)-zi
5800           rij=xj*xj+yj*yj+zj*zj
5801           r0ij=r0_scp
5802           r0ijsq=r0ij*r0ij
5803           if (rij.lt.r0ijsq) then
5804             evdwij=0.25d0*(rij-r0ijsq)**2
5805             fac=rij-r0ijsq
5806           else
5807             evdwij=0.0d0
5808             fac=0.0d0
5809           endif
5810           evdw2=evdw2+evdwij
5811 C
5812 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5813 C
5814           ggg(1)=xj*fac
5815           ggg(2)=yj*fac
5816           ggg(3)=zj*fac
5817 cgrad          if (j.lt.i) then
5818 cd          write (iout,*) 'j<i'
5819 C Uncomment following three lines for SC-p interactions
5820 c           do k=1,3
5821 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5822 c           enddo
5823 cgrad          else
5824 cd          write (iout,*) 'j>i'
5825 cgrad            do k=1,3
5826 cgrad              ggg(k)=-ggg(k)
5827 C Uncomment following line for SC-p interactions
5828 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5829 cgrad            enddo
5830 cgrad          endif
5831 cgrad          do k=1,3
5832 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5833 cgrad          enddo
5834 cgrad          kstart=min0(i+1,j)
5835 cgrad          kend=max0(i-1,j-1)
5836 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5837 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5838 cgrad          do k=kstart,kend
5839 cgrad            do l=1,3
5840 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5841 cgrad            enddo
5842 cgrad          enddo
5843           do k=1,3
5844             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5845             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5846           enddo
5847         enddo
5848
5849         enddo ! iint
5850       enddo ! i
5851       return
5852       end
5853 C-----------------------------------------------------------------------------
5854       subroutine escp(evdw2,evdw2_14)
5855 C
5856 C This subroutine calculates the excluded-volume interaction energy between
5857 C peptide-group centers and side chains and its gradient in virtual-bond and
5858 C side-chain vectors.
5859 C
5860       implicit real*8 (a-h,o-z)
5861       include 'DIMENSIONS'
5862       include 'COMMON.GEO'
5863       include 'COMMON.VAR'
5864       include 'COMMON.LOCAL'
5865       include 'COMMON.CHAIN'
5866       include 'COMMON.DERIV'
5867       include 'COMMON.INTERACT'
5868       include 'COMMON.FFIELD'
5869       include 'COMMON.IOUNITS'
5870       include 'COMMON.CONTROL'
5871       dimension ggg(3)
5872       evdw2=0.0D0
5873       evdw2_14=0.0d0
5874 cd    print '(a)','Enter ESCP'
5875 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5876       do i=iatscp_s,iatscp_e
5877         iteli=itel(i)
5878         xi=0.5D0*(c(1,i)+c(1,i+1))
5879         yi=0.5D0*(c(2,i)+c(2,i+1))
5880         zi=0.5D0*(c(3,i)+c(3,i+1))
5881
5882         do iint=1,nscp_gr(i)
5883
5884         do j=iscpstart(i,iint),iscpend(i,iint)
5885           itypj=itype(j)
5886 C Uncomment following three lines for SC-p interactions
5887 c         xj=c(1,nres+j)-xi
5888 c         yj=c(2,nres+j)-yi
5889 c         zj=c(3,nres+j)-zi
5890 C Uncomment following three lines for Ca-p interactions
5891           xj=c(1,j)-xi
5892           yj=c(2,j)-yi
5893           zj=c(3,j)-zi
5894           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5895           fac=rrij**expon2
5896           e1=fac*fac*aad(itypj,iteli)
5897           e2=fac*bad(itypj,iteli)
5898           if (iabs(j-i) .le. 2) then
5899             e1=scal14*e1
5900             e2=scal14*e2
5901             evdw2_14=evdw2_14+e1+e2
5902           endif
5903           evdwij=e1+e2
5904           evdw2=evdw2+evdwij
5905           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5906      &        'evdw2',i,j,evdwij
5907 C
5908 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5909 C
5910           fac=-(evdwij+e1)*rrij
5911           ggg(1)=xj*fac
5912           ggg(2)=yj*fac
5913           ggg(3)=zj*fac
5914 cgrad          if (j.lt.i) then
5915 cd          write (iout,*) 'j<i'
5916 C Uncomment following three lines for SC-p interactions
5917 c           do k=1,3
5918 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5919 c           enddo
5920 cgrad          else
5921 cd          write (iout,*) 'j>i'
5922 cgrad            do k=1,3
5923 cgrad              ggg(k)=-ggg(k)
5924 C Uncomment following line for SC-p interactions
5925 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5926 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5927 cgrad            enddo
5928 cgrad          endif
5929 cgrad          do k=1,3
5930 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5931 cgrad          enddo
5932 cgrad          kstart=min0(i+1,j)
5933 cgrad          kend=max0(i-1,j-1)
5934 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5935 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5936 cgrad          do k=kstart,kend
5937 cgrad            do l=1,3
5938 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5939 cgrad            enddo
5940 cgrad          enddo
5941           do k=1,3
5942             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5943             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5944           enddo
5945         enddo
5946
5947         enddo ! iint
5948       enddo ! i
5949       do i=1,nct
5950         do j=1,3
5951           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5952           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5953           gradx_scp(j,i)=expon*gradx_scp(j,i)
5954         enddo
5955       enddo
5956 C******************************************************************************
5957 C
5958 C                              N O T E !!!
5959 C
5960 C To save time the factor EXPON has been extracted from ALL components
5961 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5962 C use!
5963 C
5964 C******************************************************************************
5965       return
5966       end
5967 C--------------------------------------------------------------------------
5968       subroutine edis(ehpb)
5969 C
5970 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5971 C
5972       implicit real*8 (a-h,o-z)
5973       include 'DIMENSIONS'
5974       include 'COMMON.SBRIDGE'
5975       include 'COMMON.CHAIN'
5976       include 'COMMON.DERIV'
5977       include 'COMMON.VAR'
5978       include 'COMMON.INTERACT'
5979       include 'COMMON.IOUNITS'
5980       dimension ggg(3)
5981       ehpb=0.0D0
5982 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5983 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5984       if (link_end.eq.0) return
5985       do i=link_start,link_end
5986 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5987 C CA-CA distance used in regularization of structure.
5988         ii=ihpb(i)
5989         jj=jhpb(i)
5990 C iii and jjj point to the residues for which the distance is assigned.
5991         if (ii.gt.nres) then
5992           iii=ii-nres
5993           jjj=jj-nres
5994         else
5995           iii=ii
5996           jjj=jj
5997         endif
5998 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5999 c     &    dhpb(i),dhpb1(i),forcon(i)
6000 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6001 C    distance and angle dependent SS bond potential.
6002 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6003 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6004         if (.not.dyn_ss .and. i.le.nss) then
6005 C 15/02/13 CC dynamic SSbond - additional check
6006          if (ii.gt.nres
6007      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6008           call ssbond_ene(iii,jjj,eij)
6009           ehpb=ehpb+2*eij
6010          endif
6011 cd          write (iout,*) "eij",eij
6012         else if (ii.gt.nres .and. jj.gt.nres) then
6013 c Restraints from contact prediction
6014           dd=dist(ii,jj)
6015           if (dhpb1(i).gt.0.0d0) then
6016             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6017             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6018 c            write (iout,*) "beta nmr",
6019 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6020           else
6021             dd=dist(ii,jj)
6022             rdis=dd-dhpb(i)
6023 C Get the force constant corresponding to this distance.
6024             waga=forcon(i)
6025 C Calculate the contribution to energy.
6026             ehpb=ehpb+waga*rdis*rdis
6027 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
6028 C
6029 C Evaluate gradient.
6030 C
6031             fac=waga*rdis/dd
6032           endif
6033           do j=1,3
6034             ggg(j)=fac*(c(j,jj)-c(j,ii))
6035           enddo
6036           do j=1,3
6037             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6038             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6039           enddo
6040           do k=1,3
6041             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6042             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6043           enddo
6044         else
6045 C Calculate the distance between the two points and its difference from the
6046 C target distance.
6047           dd=dist(ii,jj)
6048           if (dhpb1(i).gt.0.0d0) then
6049             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6050             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6051 c            write (iout,*) "alph nmr",
6052 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6053           else
6054             rdis=dd-dhpb(i)
6055 C Get the force constant corresponding to this distance.
6056             waga=forcon(i)
6057 C Calculate the contribution to energy.
6058             ehpb=ehpb+waga*rdis*rdis
6059 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
6060 C
6061 C Evaluate gradient.
6062 C
6063             fac=waga*rdis/dd
6064           endif
6065 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
6066 cd   &   ' waga=',waga,' fac=',fac
6067             do j=1,3
6068               ggg(j)=fac*(c(j,jj)-c(j,ii))
6069             enddo
6070 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6071 C If this is a SC-SC distance, we need to calculate the contributions to the
6072 C Cartesian gradient in the SC vectors (ghpbx).
6073           if (iii.lt.ii) then
6074           do j=1,3
6075             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6076             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6077           enddo
6078           endif
6079 cgrad        do j=iii,jjj-1
6080 cgrad          do k=1,3
6081 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6082 cgrad          enddo
6083 cgrad        enddo
6084           do k=1,3
6085             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6086             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6087           enddo
6088         endif
6089       enddo
6090       ehpb=0.5D0*ehpb
6091       return
6092       end
6093 C--------------------------------------------------------------------------
6094       subroutine ssbond_ene(i,j,eij)
6095 C
6096 C Calculate the distance and angle dependent SS-bond potential energy
6097 C using a free-energy function derived based on RHF/6-31G** ab initio
6098 C calculations of diethyl disulfide.
6099 C
6100 C A. Liwo and U. Kozlowska, 11/24/03
6101 C
6102       implicit real*8 (a-h,o-z)
6103       include 'DIMENSIONS'
6104       include 'COMMON.SBRIDGE'
6105       include 'COMMON.CHAIN'
6106       include 'COMMON.DERIV'
6107       include 'COMMON.LOCAL'
6108       include 'COMMON.INTERACT'
6109       include 'COMMON.VAR'
6110       include 'COMMON.IOUNITS'
6111       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6112       itypi=itype(i)
6113       xi=c(1,nres+i)
6114       yi=c(2,nres+i)
6115       zi=c(3,nres+i)
6116       dxi=dc_norm(1,nres+i)
6117       dyi=dc_norm(2,nres+i)
6118       dzi=dc_norm(3,nres+i)
6119 c      dsci_inv=dsc_inv(itypi)
6120       dsci_inv=vbld_inv(nres+i)
6121       itypj=itype(j)
6122 c      dscj_inv=dsc_inv(itypj)
6123       dscj_inv=vbld_inv(nres+j)
6124       xj=c(1,nres+j)-xi
6125       yj=c(2,nres+j)-yi
6126       zj=c(3,nres+j)-zi
6127       dxj=dc_norm(1,nres+j)
6128       dyj=dc_norm(2,nres+j)
6129       dzj=dc_norm(3,nres+j)
6130       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6131       rij=dsqrt(rrij)
6132       erij(1)=xj*rij
6133       erij(2)=yj*rij
6134       erij(3)=zj*rij
6135       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6136       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6137       om12=dxi*dxj+dyi*dyj+dzi*dzj
6138       do k=1,3
6139         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6140         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6141       enddo
6142       rij=1.0d0/rij
6143       deltad=rij-d0cm
6144       deltat1=1.0d0-om1
6145       deltat2=1.0d0+om2
6146       deltat12=om2-om1+2.0d0
6147       cosphi=om12-om1*om2
6148       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6149      &  +akct*deltad*deltat12+ebr
6150      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
6151 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6152 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6153 c     &  " deltat12",deltat12," eij",eij
6154       ed=2*akcm*deltad+akct*deltat12
6155       pom1=akct*deltad
6156       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6157       eom1=-2*akth*deltat1-pom1-om2*pom2
6158       eom2= 2*akth*deltat2+pom1-om1*pom2
6159       eom12=pom2
6160       do k=1,3
6161         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6162         ghpbx(k,i)=ghpbx(k,i)-ggk
6163      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6164      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6165         ghpbx(k,j)=ghpbx(k,j)+ggk
6166      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6167      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6168         ghpbc(k,i)=ghpbc(k,i)-ggk
6169         ghpbc(k,j)=ghpbc(k,j)+ggk
6170       enddo
6171 C
6172 C Calculate the components of the gradient in DC and X
6173 C
6174 cgrad      do k=i,j-1
6175 cgrad        do l=1,3
6176 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6177 cgrad        enddo
6178 cgrad      enddo
6179       return
6180       end
6181 C--------------------------------------------------------------------------
6182       subroutine ebond(estr)
6183 c
6184 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6185 c
6186       implicit real*8 (a-h,o-z)
6187       include 'DIMENSIONS'
6188       include 'COMMON.LOCAL'
6189       include 'COMMON.GEO'
6190       include 'COMMON.INTERACT'
6191       include 'COMMON.DERIV'
6192       include 'COMMON.VAR'
6193       include 'COMMON.CHAIN'
6194       include 'COMMON.IOUNITS'
6195       include 'COMMON.NAMES'
6196       include 'COMMON.FFIELD'
6197       include 'COMMON.CONTROL'
6198       include 'COMMON.SETUP'
6199       double precision u(3),ud(3)
6200       estr=0.0d0
6201       do i=ibondp_start,ibondp_end
6202         diff = vbld(i)-vbldp0
6203 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
6204         estr=estr+diff*diff
6205         do j=1,3
6206           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6207         enddo
6208 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6209       enddo
6210       estr=0.5d0*AKP*estr
6211 c
6212 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6213 c
6214       do i=ibond_start,ibond_end
6215         iti=itype(i)
6216         if (iti.ne.10) then
6217           nbi=nbondterm(iti)
6218           if (nbi.eq.1) then
6219             diff=vbld(i+nres)-vbldsc0(1,iti)
6220 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6221 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6222             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6223             do j=1,3
6224               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6225             enddo
6226           else
6227             do j=1,nbi
6228               diff=vbld(i+nres)-vbldsc0(j,iti)
6229               ud(j)=aksc(j,iti)*diff
6230               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6231             enddo
6232             uprod=u(1)
6233             do j=2,nbi
6234               uprod=uprod*u(j)
6235             enddo
6236             usum=0.0d0
6237             usumsqder=0.0d0
6238             do j=1,nbi
6239               uprod1=1.0d0
6240               uprod2=1.0d0
6241               do k=1,nbi
6242                 if (k.ne.j) then
6243                   uprod1=uprod1*u(k)
6244                   uprod2=uprod2*u(k)*u(k)
6245                 endif
6246               enddo
6247               usum=usum+uprod1
6248               usumsqder=usumsqder+ud(j)*uprod2
6249             enddo
6250             estr=estr+uprod/usum
6251             do j=1,3
6252              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6253             enddo
6254           endif
6255         endif
6256       enddo
6257       return
6258       end
6259 #ifdef CRYST_THETA
6260 C--------------------------------------------------------------------------
6261       subroutine ebend(etheta)
6262 C
6263 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6264 C angles gamma and its derivatives in consecutive thetas and gammas.
6265 C
6266       implicit real*8 (a-h,o-z)
6267       include 'DIMENSIONS'
6268       include 'COMMON.LOCAL'
6269       include 'COMMON.GEO'
6270       include 'COMMON.INTERACT'
6271       include 'COMMON.DERIV'
6272       include 'COMMON.VAR'
6273       include 'COMMON.CHAIN'
6274       include 'COMMON.IOUNITS'
6275       include 'COMMON.NAMES'
6276       include 'COMMON.FFIELD'
6277       include 'COMMON.CONTROL'
6278       common /calcthet/ term1,term2,termm,diffak,ratak,
6279      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6280      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6281       double precision y(2),z(2)
6282       delta=0.02d0*pi
6283 c      time11=dexp(-2*time)
6284 c      time12=1.0d0
6285       etheta=0.0D0
6286 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6287       do i=ithet_start,ithet_end
6288 C Zero the energy function and its derivative at 0 or pi.
6289         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6290         it=itype(i-1)
6291         if (i.gt.3) then
6292 #ifdef OSF
6293           phii=phi(i)
6294           if (phii.ne.phii) phii=150.0
6295 #else
6296           phii=phi(i)
6297 #endif
6298           y(1)=dcos(phii)
6299           y(2)=dsin(phii)
6300         else
6301           y(1)=0.0D0
6302           y(2)=0.0D0
6303         endif
6304         if (i.lt.nres) then
6305 #ifdef OSF
6306           phii1=phi(i+1)
6307           if (phii1.ne.phii1) phii1=150.0
6308           phii1=pinorm(phii1)
6309           z(1)=cos(phii1)
6310 #else
6311           phii1=phi(i+1)
6312           z(1)=dcos(phii1)
6313 #endif
6314           z(2)=dsin(phii1)
6315         else
6316           z(1)=0.0D0
6317           z(2)=0.0D0
6318         endif
6319 C Calculate the "mean" value of theta from the part of the distribution
6320 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6321 C In following comments this theta will be referred to as t_c.
6322         thet_pred_mean=0.0d0
6323         do k=1,2
6324           athetk=athet(k,it)
6325           bthetk=bthet(k,it)
6326           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6327         enddo
6328         dthett=thet_pred_mean*ssd
6329         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6330 C Derivatives of the "mean" values in gamma1 and gamma2.
6331         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
6332         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
6333         if (theta(i).gt.pi-delta) then
6334           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6335      &         E_tc0)
6336           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6337           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6338           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6339      &        E_theta)
6340           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6341      &        E_tc)
6342         else if (theta(i).lt.delta) then
6343           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6344           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6345           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6346      &        E_theta)
6347           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6348           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6349      &        E_tc)
6350         else
6351           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6352      &        E_theta,E_tc)
6353         endif
6354         etheta=etheta+ethetai
6355         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6356      &      'ebend',i,ethetai
6357         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6358         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6359         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6360       enddo
6361 C Ufff.... We've done all this!!!
6362       return
6363       end
6364 C---------------------------------------------------------------------------
6365       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6366      &     E_tc)
6367       implicit real*8 (a-h,o-z)
6368       include 'DIMENSIONS'
6369       include 'COMMON.LOCAL'
6370       include 'COMMON.IOUNITS'
6371       common /calcthet/ term1,term2,termm,diffak,ratak,
6372      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6373      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6374 C Calculate the contributions to both Gaussian lobes.
6375 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6376 C The "polynomial part" of the "standard deviation" of this part of
6377 C the distribution.
6378         sig=polthet(3,it)
6379         do j=2,0,-1
6380           sig=sig*thet_pred_mean+polthet(j,it)
6381         enddo
6382 C Derivative of the "interior part" of the "standard deviation of the"
6383 C gamma-dependent Gaussian lobe in t_c.
6384         sigtc=3*polthet(3,it)
6385         do j=2,1,-1
6386           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6387         enddo
6388         sigtc=sig*sigtc
6389 C Set the parameters of both Gaussian lobes of the distribution.
6390 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6391         fac=sig*sig+sigc0(it)
6392         sigcsq=fac+fac
6393         sigc=1.0D0/sigcsq
6394 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6395         sigsqtc=-4.0D0*sigcsq*sigtc
6396 c       print *,i,sig,sigtc,sigsqtc
6397 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6398         sigtc=-sigtc/(fac*fac)
6399 C Following variable is sigma(t_c)**(-2)
6400         sigcsq=sigcsq*sigcsq
6401         sig0i=sig0(it)
6402         sig0inv=1.0D0/sig0i**2
6403         delthec=thetai-thet_pred_mean
6404         delthe0=thetai-theta0i
6405         term1=-0.5D0*sigcsq*delthec*delthec
6406         term2=-0.5D0*sig0inv*delthe0*delthe0
6407 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6408 C NaNs in taking the logarithm. We extract the largest exponent which is added
6409 C to the energy (this being the log of the distribution) at the end of energy
6410 C term evaluation for this virtual-bond angle.
6411         if (term1.gt.term2) then
6412           termm=term1
6413           term2=dexp(term2-termm)
6414           term1=1.0d0
6415         else
6416           termm=term2
6417           term1=dexp(term1-termm)
6418           term2=1.0d0
6419         endif
6420 C The ratio between the gamma-independent and gamma-dependent lobes of
6421 C the distribution is a Gaussian function of thet_pred_mean too.
6422         diffak=gthet(2,it)-thet_pred_mean
6423         ratak=diffak/gthet(3,it)**2
6424         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6425 C Let's differentiate it in thet_pred_mean NOW.
6426         aktc=ak*ratak
6427 C Now put together the distribution terms to make complete distribution.
6428         termexp=term1+ak*term2
6429         termpre=sigc+ak*sig0i
6430 C Contribution of the bending energy from this theta is just the -log of
6431 C the sum of the contributions from the two lobes and the pre-exponential
6432 C factor. Simple enough, isn't it?
6433         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6434 C NOW the derivatives!!!
6435 C 6/6/97 Take into account the deformation.
6436         E_theta=(delthec*sigcsq*term1
6437      &       +ak*delthe0*sig0inv*term2)/termexp
6438         E_tc=((sigtc+aktc*sig0i)/termpre
6439      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6440      &       aktc*term2)/termexp)
6441       return
6442       end
6443 c-----------------------------------------------------------------------------
6444       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6445       implicit real*8 (a-h,o-z)
6446       include 'DIMENSIONS'
6447       include 'COMMON.LOCAL'
6448       include 'COMMON.IOUNITS'
6449       common /calcthet/ term1,term2,termm,diffak,ratak,
6450      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6451      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6452       delthec=thetai-thet_pred_mean
6453       delthe0=thetai-theta0i
6454 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6455       t3 = thetai-thet_pred_mean
6456       t6 = t3**2
6457       t9 = term1
6458       t12 = t3*sigcsq
6459       t14 = t12+t6*sigsqtc
6460       t16 = 1.0d0
6461       t21 = thetai-theta0i
6462       t23 = t21**2
6463       t26 = term2
6464       t27 = t21*t26
6465       t32 = termexp
6466       t40 = t32**2
6467       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6468      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6469      & *(-t12*t9-ak*sig0inv*t27)
6470       return
6471       end
6472 #else
6473 C--------------------------------------------------------------------------
6474       subroutine ebend(etheta)
6475 C
6476 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6477 C angles gamma and its derivatives in consecutive thetas and gammas.
6478 C ab initio-derived potentials from
6479 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6480 C
6481       implicit real*8 (a-h,o-z)
6482       include 'DIMENSIONS'
6483       include 'COMMON.LOCAL'
6484       include 'COMMON.GEO'
6485       include 'COMMON.INTERACT'
6486       include 'COMMON.DERIV'
6487       include 'COMMON.VAR'
6488       include 'COMMON.CHAIN'
6489       include 'COMMON.IOUNITS'
6490       include 'COMMON.NAMES'
6491       include 'COMMON.FFIELD'
6492       include 'COMMON.CONTROL'
6493       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6494      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6495      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6496      & sinph1ph2(maxdouble,maxdouble)
6497       logical lprn /.false./, lprn1 /.false./
6498       etheta=0.0D0
6499       do i=ithet_start,ithet_end
6500         dethetai=0.0d0
6501         dephii=0.0d0
6502         dephii1=0.0d0
6503         theti2=0.5d0*theta(i)
6504         ityp2=ithetyp(itype(i-1))
6505         do k=1,nntheterm
6506           coskt(k)=dcos(k*theti2)
6507           sinkt(k)=dsin(k*theti2)
6508         enddo
6509         if (i.gt.3) then
6510 #ifdef OSF
6511           phii=phi(i)
6512           if (phii.ne.phii) phii=150.0
6513 #else
6514           phii=phi(i)
6515 #endif
6516           ityp1=ithetyp(itype(i-2))
6517           do k=1,nsingle
6518             cosph1(k)=dcos(k*phii)
6519             sinph1(k)=dsin(k*phii)
6520           enddo
6521         else
6522           phii=0.0d0
6523           ityp1=nthetyp+1
6524           do k=1,nsingle
6525             cosph1(k)=0.0d0
6526             sinph1(k)=0.0d0
6527           enddo
6528         endif
6529         if (i.lt.nres) then
6530 #ifdef OSF
6531           phii1=phi(i+1)
6532           if (phii1.ne.phii1) phii1=150.0
6533           phii1=pinorm(phii1)
6534 #else
6535           phii1=phi(i+1)
6536 #endif
6537           ityp3=ithetyp(itype(i))
6538           do k=1,nsingle
6539             cosph2(k)=dcos(k*phii1)
6540             sinph2(k)=dsin(k*phii1)
6541           enddo
6542         else
6543           phii1=0.0d0
6544           ityp3=nthetyp+1
6545           do k=1,nsingle
6546             cosph2(k)=0.0d0
6547             sinph2(k)=0.0d0
6548           enddo
6549         endif
6550         ethetai=aa0thet(ityp1,ityp2,ityp3)
6551         do k=1,ndouble
6552           do l=1,k-1
6553             ccl=cosph1(l)*cosph2(k-l)
6554             ssl=sinph1(l)*sinph2(k-l)
6555             scl=sinph1(l)*cosph2(k-l)
6556             csl=cosph1(l)*sinph2(k-l)
6557             cosph1ph2(l,k)=ccl-ssl
6558             cosph1ph2(k,l)=ccl+ssl
6559             sinph1ph2(l,k)=scl+csl
6560             sinph1ph2(k,l)=scl-csl
6561           enddo
6562         enddo
6563         if (lprn) then
6564         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6565      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6566         write (iout,*) "coskt and sinkt"
6567         do k=1,nntheterm
6568           write (iout,*) k,coskt(k),sinkt(k)
6569         enddo
6570         endif
6571         do k=1,ntheterm
6572           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
6573           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
6574      &      *coskt(k)
6575           if (lprn)
6576      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
6577      &     " ethetai",ethetai
6578         enddo
6579         if (lprn) then
6580         write (iout,*) "cosph and sinph"
6581         do k=1,nsingle
6582           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6583         enddo
6584         write (iout,*) "cosph1ph2 and sinph2ph2"
6585         do k=2,ndouble
6586           do l=1,k-1
6587             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6588      &         sinph1ph2(l,k),sinph1ph2(k,l)
6589           enddo
6590         enddo
6591         write(iout,*) "ethetai",ethetai
6592         endif
6593         do m=1,ntheterm2
6594           do k=1,nsingle
6595             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
6596      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
6597      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
6598      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
6599             ethetai=ethetai+sinkt(m)*aux
6600             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6601             dephii=dephii+k*sinkt(m)*(
6602      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
6603      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
6604             dephii1=dephii1+k*sinkt(m)*(
6605      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
6606      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
6607             if (lprn)
6608      &      write (iout,*) "m",m," k",k," bbthet",
6609      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
6610      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
6611      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
6612      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
6613           enddo
6614         enddo
6615         if (lprn)
6616      &  write(iout,*) "ethetai",ethetai
6617         do m=1,ntheterm3
6618           do k=2,ndouble
6619             do l=1,k-1
6620               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
6621      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
6622      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
6623      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
6624               ethetai=ethetai+sinkt(m)*aux
6625               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6626               dephii=dephii+l*sinkt(m)*(
6627      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
6628      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
6629      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
6630      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
6631               dephii1=dephii1+(k-l)*sinkt(m)*(
6632      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
6633      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
6634      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
6635      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
6636               if (lprn) then
6637               write (iout,*) "m",m," k",k," l",l," ffthet",
6638      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
6639      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
6640      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
6641      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
6642               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6643      &            cosph1ph2(k,l)*sinkt(m),
6644      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6645               endif
6646             enddo
6647           enddo
6648         enddo
6649 10      continue
6650         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6651      &   i,theta(i)*rad2deg,phii*rad2deg,
6652      &   phii1*rad2deg,ethetai
6653         etheta=etheta+ethetai
6654         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6655         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6656         gloc(nphi+i-2,icg)=wang*dethetai
6657       enddo
6658       return
6659       end
6660 #endif
6661 #ifdef CRYST_SC
6662 c-----------------------------------------------------------------------------
6663       subroutine esc(escloc)
6664 C Calculate the local energy of a side chain and its derivatives in the
6665 C corresponding virtual-bond valence angles THETA and the spherical angles
6666 C ALPHA and OMEGA.
6667       implicit real*8 (a-h,o-z)
6668       include 'DIMENSIONS'
6669       include 'COMMON.GEO'
6670       include 'COMMON.LOCAL'
6671       include 'COMMON.VAR'
6672       include 'COMMON.INTERACT'
6673       include 'COMMON.DERIV'
6674       include 'COMMON.CHAIN'
6675       include 'COMMON.IOUNITS'
6676       include 'COMMON.NAMES'
6677       include 'COMMON.FFIELD'
6678       include 'COMMON.CONTROL'
6679       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6680      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6681       common /sccalc/ time11,time12,time112,theti,it,nlobit
6682       delta=0.02d0*pi
6683       escloc=0.0D0
6684 c     write (iout,'(a)') 'ESC'
6685       do i=loc_start,loc_end
6686         it=itype(i)
6687         if (it.eq.10) goto 1
6688         nlobit=nlob(it)
6689 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6690 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6691         theti=theta(i+1)-pipol
6692         x(1)=dtan(theti)
6693         x(2)=alph(i)
6694         x(3)=omeg(i)
6695
6696         if (x(2).gt.pi-delta) then
6697           xtemp(1)=x(1)
6698           xtemp(2)=pi-delta
6699           xtemp(3)=x(3)
6700           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6701           xtemp(2)=pi
6702           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6703           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6704      &        escloci,dersc(2))
6705           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6706      &        ddersc0(1),dersc(1))
6707           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6708      &        ddersc0(3),dersc(3))
6709           xtemp(2)=pi-delta
6710           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6711           xtemp(2)=pi
6712           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6713           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6714      &            dersc0(2),esclocbi,dersc02)
6715           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6716      &            dersc12,dersc01)
6717           call splinthet(x(2),0.5d0*delta,ss,ssd)
6718           dersc0(1)=dersc01
6719           dersc0(2)=dersc02
6720           dersc0(3)=0.0d0
6721           do k=1,3
6722             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6723           enddo
6724           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6725 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6726 c    &             esclocbi,ss,ssd
6727           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6728 c         escloci=esclocbi
6729 c         write (iout,*) escloci
6730         else if (x(2).lt.delta) then
6731           xtemp(1)=x(1)
6732           xtemp(2)=delta
6733           xtemp(3)=x(3)
6734           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6735           xtemp(2)=0.0d0
6736           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6737           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6738      &        escloci,dersc(2))
6739           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6740      &        ddersc0(1),dersc(1))
6741           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6742      &        ddersc0(3),dersc(3))
6743           xtemp(2)=delta
6744           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6745           xtemp(2)=0.0d0
6746           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6747           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6748      &            dersc0(2),esclocbi,dersc02)
6749           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6750      &            dersc12,dersc01)
6751           dersc0(1)=dersc01
6752           dersc0(2)=dersc02
6753           dersc0(3)=0.0d0
6754           call splinthet(x(2),0.5d0*delta,ss,ssd)
6755           do k=1,3
6756             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6757           enddo
6758           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6759 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6760 c    &             esclocbi,ss,ssd
6761           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6762 c         write (iout,*) escloci
6763         else
6764           call enesc(x,escloci,dersc,ddummy,.false.)
6765         endif
6766
6767         escloc=escloc+escloci
6768         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6769      &     'escloc',i,escloci
6770 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6771
6772         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6773      &   wscloc*dersc(1)
6774         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6775         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6776     1   continue
6777       enddo
6778       return
6779       end
6780 C---------------------------------------------------------------------------
6781       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6782       implicit real*8 (a-h,o-z)
6783       include 'DIMENSIONS'
6784       include 'COMMON.GEO'
6785       include 'COMMON.LOCAL'
6786       include 'COMMON.IOUNITS'
6787       common /sccalc/ time11,time12,time112,theti,it,nlobit
6788       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6789       double precision contr(maxlob,-1:1)
6790       logical mixed
6791 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6792         escloc_i=0.0D0
6793         do j=1,3
6794           dersc(j)=0.0D0
6795           if (mixed) ddersc(j)=0.0d0
6796         enddo
6797         x3=x(3)
6798
6799 C Because of periodicity of the dependence of the SC energy in omega we have
6800 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6801 C To avoid underflows, first compute & store the exponents.
6802
6803         do iii=-1,1
6804
6805           x(3)=x3+iii*dwapi
6806
6807           do j=1,nlobit
6808             do k=1,3
6809               z(k)=x(k)-censc(k,j,it)
6810             enddo
6811             do k=1,3
6812               Axk=0.0D0
6813               do l=1,3
6814                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6815               enddo
6816               Ax(k,j,iii)=Axk
6817             enddo
6818             expfac=0.0D0
6819             do k=1,3
6820               expfac=expfac+Ax(k,j,iii)*z(k)
6821             enddo
6822             contr(j,iii)=expfac
6823           enddo ! j
6824
6825         enddo ! iii
6826
6827         x(3)=x3
6828 C As in the case of ebend, we want to avoid underflows in exponentiation and
6829 C subsequent NaNs and INFs in energy calculation.
6830 C Find the largest exponent
6831         emin=contr(1,-1)
6832         do iii=-1,1
6833           do j=1,nlobit
6834             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6835           enddo
6836         enddo
6837         emin=0.5D0*emin
6838 cd      print *,'it=',it,' emin=',emin
6839
6840 C Compute the contribution to SC energy and derivatives
6841         do iii=-1,1
6842
6843           do j=1,nlobit
6844 #ifdef OSF
6845             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
6846             if(adexp.ne.adexp) adexp=1.0
6847             expfac=dexp(adexp)
6848 #else
6849             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
6850 #endif
6851 cd          print *,'j=',j,' expfac=',expfac
6852             escloc_i=escloc_i+expfac
6853             do k=1,3
6854               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6855             enddo
6856             if (mixed) then
6857               do k=1,3,2
6858                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6859      &            +gaussc(k,2,j,it))*expfac
6860               enddo
6861             endif
6862           enddo
6863
6864         enddo ! iii
6865
6866         dersc(1)=dersc(1)/cos(theti)**2
6867         ddersc(1)=ddersc(1)/cos(theti)**2
6868         ddersc(3)=ddersc(3)
6869
6870         escloci=-(dlog(escloc_i)-emin)
6871         do j=1,3
6872           dersc(j)=dersc(j)/escloc_i
6873         enddo
6874         if (mixed) then
6875           do j=1,3,2
6876             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6877           enddo
6878         endif
6879       return
6880       end
6881 C------------------------------------------------------------------------------
6882       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6883       implicit real*8 (a-h,o-z)
6884       include 'DIMENSIONS'
6885       include 'COMMON.GEO'
6886       include 'COMMON.LOCAL'
6887       include 'COMMON.IOUNITS'
6888       common /sccalc/ time11,time12,time112,theti,it,nlobit
6889       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6890       double precision contr(maxlob)
6891       logical mixed
6892
6893       escloc_i=0.0D0
6894
6895       do j=1,3
6896         dersc(j)=0.0D0
6897       enddo
6898
6899       do j=1,nlobit
6900         do k=1,2
6901           z(k)=x(k)-censc(k,j,it)
6902         enddo
6903         z(3)=dwapi
6904         do k=1,3
6905           Axk=0.0D0
6906           do l=1,3
6907             Axk=Axk+gaussc(l,k,j,it)*z(l)
6908           enddo
6909           Ax(k,j)=Axk
6910         enddo
6911         expfac=0.0D0
6912         do k=1,3
6913           expfac=expfac+Ax(k,j)*z(k)
6914         enddo
6915         contr(j)=expfac
6916       enddo ! j
6917
6918 C As in the case of ebend, we want to avoid underflows in exponentiation and
6919 C subsequent NaNs and INFs in energy calculation.
6920 C Find the largest exponent
6921       emin=contr(1)
6922       do j=1,nlobit
6923         if (emin.gt.contr(j)) emin=contr(j)
6924       enddo
6925       emin=0.5D0*emin
6926
6927 C Compute the contribution to SC energy and derivatives
6928
6929       dersc12=0.0d0
6930       do j=1,nlobit
6931         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
6932         escloc_i=escloc_i+expfac
6933         do k=1,2
6934           dersc(k)=dersc(k)+Ax(k,j)*expfac
6935         enddo
6936         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6937      &            +gaussc(1,2,j,it))*expfac
6938         dersc(3)=0.0d0
6939       enddo
6940
6941       dersc(1)=dersc(1)/cos(theti)**2
6942       dersc12=dersc12/cos(theti)**2
6943       escloci=-(dlog(escloc_i)-emin)
6944       do j=1,2
6945         dersc(j)=dersc(j)/escloc_i
6946       enddo
6947       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6948       return
6949       end
6950 #else
6951 c----------------------------------------------------------------------------------
6952       subroutine esc(escloc)
6953 C Calculate the local energy of a side chain and its derivatives in the
6954 C corresponding virtual-bond valence angles THETA and the spherical angles
6955 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6956 C added by Urszula Kozlowska. 07/11/2007
6957 C
6958       implicit real*8 (a-h,o-z)
6959       include 'DIMENSIONS'
6960       include 'COMMON.GEO'
6961       include 'COMMON.LOCAL'
6962       include 'COMMON.VAR'
6963       include 'COMMON.SCROT'
6964       include 'COMMON.INTERACT'
6965       include 'COMMON.DERIV'
6966       include 'COMMON.CHAIN'
6967       include 'COMMON.IOUNITS'
6968       include 'COMMON.NAMES'
6969       include 'COMMON.FFIELD'
6970       include 'COMMON.CONTROL'
6971       include 'COMMON.VECTORS'
6972       double precision x_prime(3),y_prime(3),z_prime(3)
6973      &    , sumene,dsc_i,dp2_i,x(65),
6974      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6975      &    de_dxx,de_dyy,de_dzz,de_dt
6976       double precision s1_t,s1_6_t,s2_t,s2_6_t
6977       double precision
6978      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6979      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6980      & dt_dCi(3),dt_dCi1(3)
6981       common /sccalc/ time11,time12,time112,theti,it,nlobit
6982       delta=0.02d0*pi
6983       escloc=0.0D0
6984       do i=loc_start,loc_end
6985         costtab(i+1) =dcos(theta(i+1))
6986         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6987         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6988         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6989         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6990         cosfac=dsqrt(cosfac2)
6991         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6992         sinfac=dsqrt(sinfac2)
6993         it=itype(i)
6994         if (it.eq.10) goto 1
6995 c
6996 C  Compute the axes of tghe local cartesian coordinates system; store in
6997 c   x_prime, y_prime and z_prime
6998 c
6999         do j=1,3
7000           x_prime(j) = 0.00
7001           y_prime(j) = 0.00
7002           z_prime(j) = 0.00
7003         enddo
7004 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7005 C     &   dc_norm(3,i+nres)
7006         do j = 1,3
7007           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7008           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7009         enddo
7010         do j = 1,3
7011           z_prime(j) = -uz(j,i-1)
7012         enddo
7013 c       write (2,*) "i",i
7014 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7015 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7016 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7017 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7018 c      & " xy",scalar(x_prime(1),y_prime(1)),
7019 c      & " xz",scalar(x_prime(1),z_prime(1)),
7020 c      & " yy",scalar(y_prime(1),y_prime(1)),
7021 c      & " yz",scalar(y_prime(1),z_prime(1)),
7022 c      & " zz",scalar(z_prime(1),z_prime(1))
7023 c
7024 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7025 C to local coordinate system. Store in xx, yy, zz.
7026 c
7027         xx=0.0d0
7028         yy=0.0d0
7029         zz=0.0d0
7030         do j = 1,3
7031           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7032           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7033           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7034         enddo
7035
7036         xxtab(i)=xx
7037         yytab(i)=yy
7038         zztab(i)=zz
7039 C
7040 C Compute the energy of the ith side cbain
7041 C
7042 c        write (2,*) "xx",xx," yy",yy," zz",zz
7043         it=itype(i)
7044         do j = 1,65
7045           x(j) = sc_parmin(j,it)
7046         enddo
7047 #ifdef CHECK_COORD
7048 Cc diagnostics - remove later
7049         xx1 = dcos(alph(2))
7050         yy1 = dsin(alph(2))*dcos(omeg(2))
7051         zz1 = -dsin(alph(2))*dsin(omeg(2))
7052         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7053      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7054      &    xx1,yy1,zz1
7055 C,"  --- ", xx_w,yy_w,zz_w
7056 c end diagnostics
7057 #endif
7058         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7059      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7060      &   + x(10)*yy*zz
7061         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7062      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7063      & + x(20)*yy*zz
7064         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7065      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7066      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7067      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7068      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7069      &  +x(40)*xx*yy*zz
7070         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7071      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7072      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7073      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7074      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7075      &  +x(60)*xx*yy*zz
7076         dsc_i   = 0.743d0+x(61)
7077         dp2_i   = 1.9d0+x(62)
7078         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7079      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7080         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7081      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7082         s1=(1+x(63))/(0.1d0 + dscp1)
7083         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7084         s2=(1+x(65))/(0.1d0 + dscp2)
7085         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7086         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7087      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7088 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7089 c     &   sumene4,
7090 c     &   dscp1,dscp2,sumene
7091 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7092         escloc = escloc + sumene
7093 c        write (2,*) "i",i," escloc",sumene,escloc
7094 #ifdef DEBUG
7095 C
7096 C This section to check the numerical derivatives of the energy of ith side
7097 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7098 C #define DEBUG in the code to turn it on.
7099 C
7100         write (2,*) "sumene               =",sumene
7101         aincr=1.0d-7
7102         xxsave=xx
7103         xx=xx+aincr
7104         write (2,*) xx,yy,zz
7105         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7106         de_dxx_num=(sumenep-sumene)/aincr
7107         xx=xxsave
7108         write (2,*) "xx+ sumene from enesc=",sumenep
7109         yysave=yy
7110         yy=yy+aincr
7111         write (2,*) xx,yy,zz
7112         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7113         de_dyy_num=(sumenep-sumene)/aincr
7114         yy=yysave
7115         write (2,*) "yy+ sumene from enesc=",sumenep
7116         zzsave=zz
7117         zz=zz+aincr
7118         write (2,*) xx,yy,zz
7119         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7120         de_dzz_num=(sumenep-sumene)/aincr
7121         zz=zzsave
7122         write (2,*) "zz+ sumene from enesc=",sumenep
7123         costsave=cost2tab(i+1)
7124         sintsave=sint2tab(i+1)
7125         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7126         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7127         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7128         de_dt_num=(sumenep-sumene)/aincr
7129         write (2,*) " t+ sumene from enesc=",sumenep
7130         cost2tab(i+1)=costsave
7131         sint2tab(i+1)=sintsave
7132 C End of diagnostics section.
7133 #endif
7134 C
7135 C Compute the gradient of esc
7136 C
7137         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7138         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7139         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7140         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7141         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7142         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7143         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7144         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7145         pom1=(sumene3*sint2tab(i+1)+sumene1)
7146      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7147         pom2=(sumene4*cost2tab(i+1)+sumene2)
7148      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7149         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7150         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7151      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7152      &  +x(40)*yy*zz
7153         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7154         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7155      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7156      &  +x(60)*yy*zz
7157         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7158      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7159      &        +(pom1+pom2)*pom_dx
7160 #ifdef DEBUG
7161         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
7162 #endif
7163 C
7164         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7165         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7166      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7167      &  +x(40)*xx*zz
7168         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7169         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7170      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7171      &  +x(59)*zz**2 +x(60)*xx*zz
7172         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7173      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7174      &        +(pom1-pom2)*pom_dy
7175 #ifdef DEBUG
7176         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
7177 #endif
7178 C
7179         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7180      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7181      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7182      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7183      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7184      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7185      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7186      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7187 #ifdef DEBUG
7188         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
7189 #endif
7190 C
7191         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7192      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7193      &  +pom1*pom_dt1+pom2*pom_dt2
7194 #ifdef DEBUG
7195         write(2,*), "de_dt = ", de_dt,de_dt_num
7196 #endif
7197 c
7198 C
7199        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7200        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7201        cosfac2xx=cosfac2*xx
7202        sinfac2yy=sinfac2*yy
7203        do k = 1,3
7204          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7205      &      vbld_inv(i+1)
7206          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7207      &      vbld_inv(i)
7208          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7209          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7210 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7211 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7212 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7213 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7214          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7215          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7216          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7217          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7218          dZZ_Ci1(k)=0.0d0
7219          dZZ_Ci(k)=0.0d0
7220          do j=1,3
7221            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
7222            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
7223          enddo
7224
7225          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7226          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7227          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
7228 c
7229          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7230          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7231        enddo
7232
7233        do k=1,3
7234          dXX_Ctab(k,i)=dXX_Ci(k)
7235          dXX_C1tab(k,i)=dXX_Ci1(k)
7236          dYY_Ctab(k,i)=dYY_Ci(k)
7237          dYY_C1tab(k,i)=dYY_Ci1(k)
7238          dZZ_Ctab(k,i)=dZZ_Ci(k)
7239          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7240          dXX_XYZtab(k,i)=dXX_XYZ(k)
7241          dYY_XYZtab(k,i)=dYY_XYZ(k)
7242          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7243        enddo
7244
7245        do k = 1,3
7246 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7247 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7248 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7249 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7250 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7251 c     &    dt_dci(k)
7252 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7253 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7254          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7255      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7256          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7257      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7258          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7259      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7260        enddo
7261 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7262 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7263
7264 C to check gradient call subroutine check_grad
7265
7266     1 continue
7267       enddo
7268       return
7269       end
7270 c------------------------------------------------------------------------------
7271       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7272       implicit none
7273       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7274      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7275       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7276      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7277      &   + x(10)*yy*zz
7278       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7279      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7280      & + x(20)*yy*zz
7281       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7282      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7283      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7284      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7285      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7286      &  +x(40)*xx*yy*zz
7287       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7288      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7289      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7290      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7291      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7292      &  +x(60)*xx*yy*zz
7293       dsc_i   = 0.743d0+x(61)
7294       dp2_i   = 1.9d0+x(62)
7295       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7296      &          *(xx*cost2+yy*sint2))
7297       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7298      &          *(xx*cost2-yy*sint2))
7299       s1=(1+x(63))/(0.1d0 + dscp1)
7300       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7301       s2=(1+x(65))/(0.1d0 + dscp2)
7302       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7303       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7304      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7305       enesc=sumene
7306       return
7307       end
7308 #endif
7309 c------------------------------------------------------------------------------
7310       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7311 C
7312 C This procedure calculates two-body contact function g(rij) and its derivative:
7313 C
7314 C           eps0ij                                     !       x < -1
7315 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7316 C            0                                         !       x > 1
7317 C
7318 C where x=(rij-r0ij)/delta
7319 C
7320 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7321 C
7322       implicit none
7323       double precision rij,r0ij,eps0ij,fcont,fprimcont
7324       double precision x,x2,x4,delta
7325 c     delta=0.02D0*r0ij
7326 c      delta=0.2D0*r0ij
7327       x=(rij-r0ij)/delta
7328       if (x.lt.-1.0D0) then
7329         fcont=eps0ij
7330         fprimcont=0.0D0
7331       else if (x.le.1.0D0) then
7332         x2=x*x
7333         x4=x2*x2
7334         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7335         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7336       else
7337         fcont=0.0D0
7338         fprimcont=0.0D0
7339       endif
7340       return
7341       end
7342 c------------------------------------------------------------------------------
7343       subroutine splinthet(theti,delta,ss,ssder)
7344       implicit real*8 (a-h,o-z)
7345       include 'DIMENSIONS'
7346       include 'COMMON.VAR'
7347       include 'COMMON.GEO'
7348       thetup=pi-delta
7349       thetlow=delta
7350       if (theti.gt.pipol) then
7351         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7352       else
7353         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7354         ssder=-ssder
7355       endif
7356       return
7357       end
7358 c------------------------------------------------------------------------------
7359       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7360       implicit none
7361       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7362       double precision ksi,ksi2,ksi3,a1,a2,a3
7363       a1=fprim0*delta/(f1-f0)
7364       a2=3.0d0-2.0d0*a1
7365       a3=a1-2.0d0
7366       ksi=(x-x0)/delta
7367       ksi2=ksi*ksi
7368       ksi3=ksi2*ksi
7369       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7370       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7371       return
7372       end
7373 c------------------------------------------------------------------------------
7374       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7375       implicit none
7376       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7377       double precision ksi,ksi2,ksi3,a1,a2,a3
7378       ksi=(x-x0)/delta
7379       ksi2=ksi*ksi
7380       ksi3=ksi2*ksi
7381       a1=fprim0x*delta
7382       a2=3*(f1x-f0x)-2*fprim0x*delta
7383       a3=fprim0x*delta-2*(f1x-f0x)
7384       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7385       return
7386       end
7387 C-----------------------------------------------------------------------------
7388 #ifdef CRYST_TOR
7389 C-----------------------------------------------------------------------------
7390       subroutine etor(etors,edihcnstr)
7391       implicit real*8 (a-h,o-z)
7392       include 'DIMENSIONS'
7393       include 'COMMON.VAR'
7394       include 'COMMON.GEO'
7395       include 'COMMON.LOCAL'
7396       include 'COMMON.TORSION'
7397       include 'COMMON.INTERACT'
7398       include 'COMMON.DERIV'
7399       include 'COMMON.CHAIN'
7400       include 'COMMON.NAMES'
7401       include 'COMMON.IOUNITS'
7402       include 'COMMON.FFIELD'
7403       include 'COMMON.TORCNSTR'
7404       include 'COMMON.CONTROL'
7405       logical lprn
7406 C Set lprn=.true. for debugging
7407       lprn=.false.
7408 c      lprn=.true.
7409       etors=0.0D0
7410       do i=iphi_start,iphi_end
7411       etors_ii=0.0D0
7412         itori=itortyp(itype(i-2))
7413         itori1=itortyp(itype(i-1))
7414         phii=phi(i)
7415         gloci=0.0D0
7416 C Proline-Proline pair is a special case...
7417         if (itori.eq.3 .and. itori1.eq.3) then
7418           if (phii.gt.-dwapi3) then
7419             cosphi=dcos(3*phii)
7420             fac=1.0D0/(1.0D0-cosphi)
7421             etorsi=v1(1,3,3)*fac
7422             etorsi=etorsi+etorsi
7423             etors=etors+etorsi-v1(1,3,3)
7424             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7425             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7426           endif
7427           do j=1,3
7428             v1ij=v1(j+1,itori,itori1)
7429             v2ij=v2(j+1,itori,itori1)
7430             cosphi=dcos(j*phii)
7431             sinphi=dsin(j*phii)
7432             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7433             if (energy_dec) etors_ii=etors_ii+
7434      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7435             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7436           enddo
7437         else
7438           do j=1,nterm_old
7439             v1ij=v1(j,itori,itori1)
7440             v2ij=v2(j,itori,itori1)
7441             cosphi=dcos(j*phii)
7442             sinphi=dsin(j*phii)
7443             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7444             if (energy_dec) etors_ii=etors_ii+
7445      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7446             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7447           enddo
7448         endif
7449         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7450      &        'etor',i,etors_ii
7451         if (lprn)
7452      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7453      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7454      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7455         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7456         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7457       enddo
7458 ! 6/20/98 - dihedral angle constraints
7459       edihcnstr=0.0d0
7460       do i=1,ndih_constr
7461         itori=idih_constr(i)
7462         phii=phi(itori)
7463         difi=phii-phi0(i)
7464         if (difi.gt.drange(i)) then
7465           difi=difi-drange(i)
7466           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
7467           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
7468         else if (difi.lt.-drange(i)) then
7469           difi=difi+drange(i)
7470           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
7471           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
7472         endif
7473 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7474 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7475       enddo
7476 !      write (iout,*) 'edihcnstr',edihcnstr
7477       return
7478       end
7479 c------------------------------------------------------------------------------
7480       subroutine etor_d(etors_d)
7481       etors_d=0.0d0
7482       return
7483       end
7484 c----------------------------------------------------------------------------
7485 #else
7486       subroutine etor(etors,edihcnstr)
7487       implicit real*8 (a-h,o-z)
7488       include 'DIMENSIONS'
7489       include 'COMMON.VAR'
7490       include 'COMMON.GEO'
7491       include 'COMMON.LOCAL'
7492       include 'COMMON.TORSION'
7493       include 'COMMON.INTERACT'
7494       include 'COMMON.DERIV'
7495       include 'COMMON.CHAIN'
7496       include 'COMMON.NAMES'
7497       include 'COMMON.IOUNITS'
7498       include 'COMMON.FFIELD'
7499       include 'COMMON.TORCNSTR'
7500       include 'COMMON.CONTROL'
7501       logical lprn
7502 C Set lprn=.true. for debugging
7503       lprn=.false.
7504 c     lprn=.true.
7505       etors=0.0D0
7506       do i=iphi_start,iphi_end
7507       etors_ii=0.0D0
7508         itori=itortyp(itype(i-2))
7509         itori1=itortyp(itype(i-1))
7510         phii=phi(i)
7511         gloci=0.0D0
7512 C Regular cosine and sine terms
7513         do j=1,nterm(itori,itori1)
7514           v1ij=v1(j,itori,itori1)
7515           v2ij=v2(j,itori,itori1)
7516           cosphi=dcos(j*phii)
7517           sinphi=dsin(j*phii)
7518           etors=etors+v1ij*cosphi+v2ij*sinphi
7519           if (energy_dec) etors_ii=etors_ii+
7520      &                v1ij*cosphi+v2ij*sinphi
7521           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7522         enddo
7523 C Lorentz terms
7524 C                         v1
7525 C  E = SUM ----------------------------------- - v1
7526 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7527 C
7528         cosphi=dcos(0.5d0*phii)
7529         sinphi=dsin(0.5d0*phii)
7530         do j=1,nlor(itori,itori1)
7531           vl1ij=vlor1(j,itori,itori1)
7532           vl2ij=vlor2(j,itori,itori1)
7533           vl3ij=vlor3(j,itori,itori1)
7534           pom=vl2ij*cosphi+vl3ij*sinphi
7535           pom1=1.0d0/(pom*pom+1.0d0)
7536           etors=etors+vl1ij*pom1
7537           if (energy_dec) etors_ii=etors_ii+
7538      &                vl1ij*pom1
7539           pom=-pom*pom1*pom1
7540           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7541         enddo
7542 C Subtract the constant term
7543         etors=etors-v0(itori,itori1)
7544           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7545      &         'etor',i,etors_ii-v0(itori,itori1)
7546         if (lprn)
7547      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7548      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7549      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7550         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7551 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7552       enddo
7553 ! 6/20/98 - dihedral angle constraints
7554       edihcnstr=0.0d0
7555 c      do i=1,ndih_constr
7556       do i=idihconstr_start,idihconstr_end
7557         itori=idih_constr(i)
7558         phii=phi(itori)
7559         difi=pinorm(phii-phi0(i))
7560         if (difi.gt.drange(i)) then
7561           difi=difi-drange(i)
7562           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
7563           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
7564         else if (difi.lt.-drange(i)) then
7565           difi=difi+drange(i)
7566           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
7567           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
7568         else
7569           difi=0.0
7570         endif
7571 c        write (iout,*) "gloci", gloc(i-3,icg)
7572 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
7573 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
7574 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7575       enddo
7576 cd       write (iout,*) 'edihcnstr',edihcnstr
7577       return
7578       end
7579 c----------------------------------------------------------------------------
7580       subroutine etor_d(etors_d)
7581 C 6/23/01 Compute double torsional energy
7582       implicit real*8 (a-h,o-z)
7583       include 'DIMENSIONS'
7584       include 'COMMON.VAR'
7585       include 'COMMON.GEO'
7586       include 'COMMON.LOCAL'
7587       include 'COMMON.TORSION'
7588       include 'COMMON.INTERACT'
7589       include 'COMMON.DERIV'
7590       include 'COMMON.CHAIN'
7591       include 'COMMON.NAMES'
7592       include 'COMMON.IOUNITS'
7593       include 'COMMON.FFIELD'
7594       include 'COMMON.TORCNSTR'
7595       logical lprn
7596 C Set lprn=.true. for debugging
7597       lprn=.false.
7598 c     lprn=.true.
7599       etors_d=0.0D0
7600       do i=iphid_start,iphid_end
7601         itori=itortyp(itype(i-2))
7602         itori1=itortyp(itype(i-1))
7603         itori2=itortyp(itype(i))
7604         phii=phi(i)
7605         phii1=phi(i+1)
7606         gloci1=0.0D0
7607         gloci2=0.0D0
7608         do j=1,ntermd_1(itori,itori1,itori2)
7609           v1cij=v1c(1,j,itori,itori1,itori2)
7610           v1sij=v1s(1,j,itori,itori1,itori2)
7611           v2cij=v1c(2,j,itori,itori1,itori2)
7612           v2sij=v1s(2,j,itori,itori1,itori2)
7613           cosphi1=dcos(j*phii)
7614           sinphi1=dsin(j*phii)
7615           cosphi2=dcos(j*phii1)
7616           sinphi2=dsin(j*phii1)
7617           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7618      &     v2cij*cosphi2+v2sij*sinphi2
7619           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7620           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7621         enddo
7622         do k=2,ntermd_2(itori,itori1,itori2)
7623           do l=1,k-1
7624             v1cdij = v2c(k,l,itori,itori1,itori2)
7625             v2cdij = v2c(l,k,itori,itori1,itori2)
7626             v1sdij = v2s(k,l,itori,itori1,itori2)
7627             v2sdij = v2s(l,k,itori,itori1,itori2)
7628             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7629             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7630             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7631             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7632             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7633      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7634             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7635      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7636             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7637      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7638           enddo
7639         enddo
7640         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7641         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7642 c        write (iout,*) "gloci", gloc(i-3,icg)
7643       enddo
7644       return
7645       end
7646 #endif
7647 c------------------------------------------------------------------------------
7648       subroutine eback_sc_corr(esccor)
7649 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7650 c        conformational states; temporarily implemented as differences
7651 c        between UNRES torsional potentials (dependent on three types of
7652 c        residues) and the torsional potentials dependent on all 20 types
7653 c        of residues computed from AM1  energy surfaces of terminally-blocked
7654 c        amino-acid residues.
7655       implicit real*8 (a-h,o-z)
7656       include 'DIMENSIONS'
7657       include 'COMMON.VAR'
7658       include 'COMMON.GEO'
7659       include 'COMMON.LOCAL'
7660       include 'COMMON.TORSION'
7661       include 'COMMON.SCCOR'
7662       include 'COMMON.INTERACT'
7663       include 'COMMON.DERIV'
7664       include 'COMMON.CHAIN'
7665       include 'COMMON.NAMES'
7666       include 'COMMON.IOUNITS'
7667       include 'COMMON.FFIELD'
7668       include 'COMMON.CONTROL'
7669       logical lprn
7670 C Set lprn=.true. for debugging
7671       lprn=.false.
7672 c      lprn=.true.
7673 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7674       esccor=0.0D0
7675       do i=itau_start,itau_end
7676         esccor_ii=0.0D0
7677         isccori=isccortyp(itype(i-2))
7678         isccori1=isccortyp(itype(i-1))
7679         phii=phi(i)
7680 cccc  Added 9 May 2012
7681 cc Tauangle is torsional engle depending on the value of first digit
7682 c(see comment below)
7683 cc Omicron is flat angle depending on the value of first digit
7684 c(see comment below)
7685
7686
7687         do intertyp=1,3 !intertyp
7688 cc Added 09 May 2012 (Adasko)
7689 cc  Intertyp means interaction type of backbone mainchain correlation:
7690 c   1 = SC...Ca...Ca...Ca
7691 c   2 = Ca...Ca...Ca...SC
7692 c   3 = SC...Ca...Ca...SCi
7693         gloci=0.0D0
7694         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7695      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
7696      &      (itype(i-1).eq.21)))
7697      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7698      &     .or.(itype(i-2).eq.21)))
7699      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7700      &      (itype(i-1).eq.21)))) cycle
7701         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
7702         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
7703      & cycle
7704         do j=1,nterm_sccor(isccori,isccori1)
7705           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7706           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7707           cosphi=dcos(j*tauangle(intertyp,i))
7708           sinphi=dsin(j*tauangle(intertyp,i))
7709           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7710           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7711         enddo
7712         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7713 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
7714 c     &gloc_sc(intertyp,i-3,icg)
7715         if (lprn)
7716      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7717      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7718      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
7719      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
7720         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7721        enddo !intertyp
7722       enddo
7723 c        do i=1,nres
7724 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
7725 c        enddo
7726       return
7727       end
7728 c----------------------------------------------------------------------------
7729       subroutine multibody(ecorr)
7730 C This subroutine calculates multi-body contributions to energy following
7731 C the idea of Skolnick et al. If side chains I and J make a contact and
7732 C at the same time side chains I+1 and J+1 make a contact, an extra
7733 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7734       implicit real*8 (a-h,o-z)
7735       include 'DIMENSIONS'
7736       include 'COMMON.IOUNITS'
7737       include 'COMMON.DERIV'
7738       include 'COMMON.INTERACT'
7739       include 'COMMON.CONTACTS'
7740       double precision gx(3),gx1(3)
7741       logical lprn
7742
7743 C Set lprn=.true. for debugging
7744       lprn=.false.
7745
7746       if (lprn) then
7747         write (iout,'(a)') 'Contact function values:'
7748         do i=nnt,nct-2
7749           write (iout,'(i2,20(1x,i2,f10.5))')
7750      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7751         enddo
7752       endif
7753       ecorr=0.0D0
7754       do i=nnt,nct
7755         do j=1,3
7756           gradcorr(j,i)=0.0D0
7757           gradxorr(j,i)=0.0D0
7758         enddo
7759       enddo
7760       do i=nnt,nct-2
7761
7762         DO ISHIFT = 3,4
7763
7764         i1=i+ishift
7765         num_conti=num_cont(i)
7766         num_conti1=num_cont(i1)
7767         do jj=1,num_conti
7768           j=jcont(jj,i)
7769           do kk=1,num_conti1
7770             j1=jcont(kk,i1)
7771             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7772 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7773 cd   &                   ' ishift=',ishift
7774 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7775 C The system gains extra energy.
7776               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7777             endif   ! j1==j+-ishift
7778           enddo     ! kk
7779         enddo       ! jj
7780
7781         ENDDO ! ISHIFT
7782
7783       enddo         ! i
7784       return
7785       end
7786 c------------------------------------------------------------------------------
7787       double precision function esccorr(i,j,k,l,jj,kk)
7788       implicit real*8 (a-h,o-z)
7789       include 'DIMENSIONS'
7790       include 'COMMON.IOUNITS'
7791       include 'COMMON.DERIV'
7792       include 'COMMON.INTERACT'
7793       include 'COMMON.CONTACTS'
7794       double precision gx(3),gx1(3)
7795       logical lprn
7796       lprn=.false.
7797       eij=facont(jj,i)
7798       ekl=facont(kk,k)
7799 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7800 C Calculate the multi-body contribution to energy.
7801 C Calculate multi-body contributions to the gradient.
7802 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7803 cd   & k,l,(gacont(m,kk,k),m=1,3)
7804       do m=1,3
7805         gx(m) =ekl*gacont(m,jj,i)
7806         gx1(m)=eij*gacont(m,kk,k)
7807         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7808         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7809         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7810         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7811       enddo
7812       do m=i,j-1
7813         do ll=1,3
7814           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7815         enddo
7816       enddo
7817       do m=k,l-1
7818         do ll=1,3
7819           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7820         enddo
7821       enddo
7822       esccorr=-eij*ekl
7823       return
7824       end
7825 c------------------------------------------------------------------------------
7826       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7827 C This subroutine calculates multi-body contributions to hydrogen-bonding
7828       implicit real*8 (a-h,o-z)
7829       include 'DIMENSIONS'
7830       include 'COMMON.IOUNITS'
7831 #ifdef MPI
7832       include "mpif.h"
7833       parameter (max_cont=maxconts)
7834       parameter (max_dim=26)
7835       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7836       double precision zapas(max_dim,maxconts,max_fg_procs),
7837      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7838       common /przechowalnia/ zapas
7839       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7840      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7841 #endif
7842       include 'COMMON.SETUP'
7843       include 'COMMON.FFIELD'
7844       include 'COMMON.DERIV'
7845       include 'COMMON.INTERACT'
7846       include 'COMMON.CONTACTS'
7847       include 'COMMON.CONTROL'
7848       include 'COMMON.LOCAL'
7849       double precision gx(3),gx1(3),time00
7850       logical lprn,ldone
7851
7852 C Set lprn=.true. for debugging
7853       lprn=.false.
7854 #ifdef MPI
7855       n_corr=0
7856       n_corr1=0
7857       if (nfgtasks.le.1) goto 30
7858       if (lprn) then
7859         write (iout,'(a)') 'Contact function values before RECEIVE:'
7860         do i=nnt,nct-2
7861           write (iout,'(2i3,50(1x,i2,f5.2))')
7862      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7863      &    j=1,num_cont_hb(i))
7864         enddo
7865       endif
7866       call flush(iout)
7867       do i=1,ntask_cont_from
7868         ncont_recv(i)=0
7869       enddo
7870       do i=1,ntask_cont_to
7871         ncont_sent(i)=0
7872       enddo
7873 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7874 c     & ntask_cont_to
7875 C Make the list of contacts to send to send to other procesors
7876 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7877 c      call flush(iout)
7878       do i=iturn3_start,iturn3_end
7879 c        write (iout,*) "make contact list turn3",i," num_cont",
7880 c     &    num_cont_hb(i)
7881         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7882       enddo
7883       do i=iturn4_start,iturn4_end
7884 c        write (iout,*) "make contact list turn4",i," num_cont",
7885 c     &   num_cont_hb(i)
7886         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7887       enddo
7888       do ii=1,nat_sent
7889         i=iat_sent(ii)
7890 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7891 c     &    num_cont_hb(i)
7892         do j=1,num_cont_hb(i)
7893         do k=1,4
7894           jjc=jcont_hb(j,i)
7895           iproc=iint_sent_local(k,jjc,ii)
7896 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7897           if (iproc.gt.0) then
7898             ncont_sent(iproc)=ncont_sent(iproc)+1
7899             nn=ncont_sent(iproc)
7900             zapas(1,nn,iproc)=i
7901             zapas(2,nn,iproc)=jjc
7902             zapas(3,nn,iproc)=facont_hb(j,i)
7903             zapas(4,nn,iproc)=ees0p(j,i)
7904             zapas(5,nn,iproc)=ees0m(j,i)
7905             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7906             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7907             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7908             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7909             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7910             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7911             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7912             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7913             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7914             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7915             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7916             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7917             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7918             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7919             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7920             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7921             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7922             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7923             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7924             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7925             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7926           endif
7927         enddo
7928         enddo
7929       enddo
7930       if (lprn) then
7931       write (iout,*)
7932      &  "Numbers of contacts to be sent to other processors",
7933      &  (ncont_sent(i),i=1,ntask_cont_to)
7934       write (iout,*) "Contacts sent"
7935       do ii=1,ntask_cont_to
7936         nn=ncont_sent(ii)
7937         iproc=itask_cont_to(ii)
7938         write (iout,*) nn," contacts to processor",iproc,
7939      &   " of CONT_TO_COMM group"
7940         do i=1,nn
7941           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7942         enddo
7943       enddo
7944       call flush(iout)
7945       endif
7946       CorrelType=477
7947       CorrelID=fg_rank+1
7948       CorrelType1=478
7949       CorrelID1=nfgtasks+fg_rank+1
7950       ireq=0
7951 C Receive the numbers of needed contacts from other processors
7952       do ii=1,ntask_cont_from
7953         iproc=itask_cont_from(ii)
7954         ireq=ireq+1
7955         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7956      &    FG_COMM,req(ireq),IERR)
7957       enddo
7958 c      write (iout,*) "IRECV ended"
7959 c      call flush(iout)
7960 C Send the number of contacts needed by other processors
7961       do ii=1,ntask_cont_to
7962         iproc=itask_cont_to(ii)
7963         ireq=ireq+1
7964         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7965      &    FG_COMM,req(ireq),IERR)
7966       enddo
7967 c      write (iout,*) "ISEND ended"
7968 c      write (iout,*) "number of requests (nn)",ireq
7969       call flush(iout)
7970       if (ireq.gt.0)
7971      &  call MPI_Waitall(ireq,req,status_array,ierr)
7972 c      write (iout,*)
7973 c     &  "Numbers of contacts to be received from other processors",
7974 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7975 c      call flush(iout)
7976 C Receive contacts
7977       ireq=0
7978       do ii=1,ntask_cont_from
7979         iproc=itask_cont_from(ii)
7980         nn=ncont_recv(ii)
7981 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7982 c     &   " of CONT_TO_COMM group"
7983         call flush(iout)
7984         if (nn.gt.0) then
7985           ireq=ireq+1
7986           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7987      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7988 c          write (iout,*) "ireq,req",ireq,req(ireq)
7989         endif
7990       enddo
7991 C Send the contacts to processors that need them
7992       do ii=1,ntask_cont_to
7993         iproc=itask_cont_to(ii)
7994         nn=ncont_sent(ii)
7995 c        write (iout,*) nn," contacts to processor",iproc,
7996 c     &   " of CONT_TO_COMM group"
7997         if (nn.gt.0) then
7998           ireq=ireq+1
7999           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8000      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8001 c          write (iout,*) "ireq,req",ireq,req(ireq)
8002 c          do i=1,nn
8003 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8004 c          enddo
8005         endif
8006       enddo
8007 c      write (iout,*) "number of requests (contacts)",ireq
8008 c      write (iout,*) "req",(req(i),i=1,4)
8009 c      call flush(iout)
8010       if (ireq.gt.0)
8011      & call MPI_Waitall(ireq,req,status_array,ierr)
8012       do iii=1,ntask_cont_from
8013         iproc=itask_cont_from(iii)
8014         nn=ncont_recv(iii)
8015         if (lprn) then
8016         write (iout,*) "Received",nn," contacts from processor",iproc,
8017      &   " of CONT_FROM_COMM group"
8018         call flush(iout)
8019         do i=1,nn
8020           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8021         enddo
8022         call flush(iout)
8023         endif
8024         do i=1,nn
8025           ii=zapas_recv(1,i,iii)
8026 c Flag the received contacts to prevent double-counting
8027           jj=-zapas_recv(2,i,iii)
8028 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8029 c          call flush(iout)
8030           nnn=num_cont_hb(ii)+1
8031           num_cont_hb(ii)=nnn
8032           jcont_hb(nnn,ii)=jj
8033           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8034           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8035           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8036           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8037           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8038           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8039           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8040           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8041           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8042           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8043           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8044           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8045           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8046           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8047           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8048           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8049           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8050           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8051           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8052           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8053           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8054           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8055           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8056           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8057         enddo
8058       enddo
8059       call flush(iout)
8060       if (lprn) then
8061         write (iout,'(a)') 'Contact function values after receive:'
8062         do i=nnt,nct-2
8063           write (iout,'(2i3,50(1x,i3,f5.2))')
8064      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8065      &    j=1,num_cont_hb(i))
8066         enddo
8067         call flush(iout)
8068       endif
8069    30 continue
8070 #endif
8071       if (lprn) then
8072         write (iout,'(a)') 'Contact function values:'
8073         do i=nnt,nct-2
8074           write (iout,'(2i3,50(1x,i3,f5.2))')
8075      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8076      &    j=1,num_cont_hb(i))
8077         enddo
8078       endif
8079       ecorr=0.0D0
8080 C Remove the loop below after debugging !!!
8081       do i=nnt,nct
8082         do j=1,3
8083           gradcorr(j,i)=0.0D0
8084           gradxorr(j,i)=0.0D0
8085         enddo
8086       enddo
8087 C Calculate the local-electrostatic correlation terms
8088       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8089         i1=i+1
8090         num_conti=num_cont_hb(i)
8091         num_conti1=num_cont_hb(i+1)
8092         do jj=1,num_conti
8093           j=jcont_hb(jj,i)
8094           jp=iabs(j)
8095           do kk=1,num_conti1
8096             j1=jcont_hb(kk,i1)
8097             jp1=iabs(j1)
8098 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8099 c     &         ' jj=',jj,' kk=',kk
8100             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8101      &          .or. j.lt.0 .and. j1.gt.0) .and.
8102      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8103 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8104 C The system gains extra energy.
8105               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8106               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8107      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8108               n_corr=n_corr+1
8109             else if (j1.eq.j) then
8110 C Contacts I-J and I-(J+1) occur simultaneously.
8111 C The system loses extra energy.
8112 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8113             endif
8114           enddo ! kk
8115           do kk=1,num_conti
8116             j1=jcont_hb(kk,i)
8117 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8118 c    &         ' jj=',jj,' kk=',kk
8119             if (j1.eq.j+1) then
8120 C Contacts I-J and (I+1)-J occur simultaneously.
8121 C The system loses extra energy.
8122 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8123             endif ! j1==j+1
8124           enddo ! kk
8125         enddo ! jj
8126       enddo ! i
8127       return
8128       end
8129 c------------------------------------------------------------------------------
8130       subroutine add_hb_contact(ii,jj,itask)
8131       implicit real*8 (a-h,o-z)
8132       include "DIMENSIONS"
8133       include "COMMON.IOUNITS"
8134       integer max_cont
8135       integer max_dim
8136       parameter (max_cont=maxconts)
8137       parameter (max_dim=26)
8138       include "COMMON.CONTACTS"
8139       double precision zapas(max_dim,maxconts,max_fg_procs),
8140      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8141       common /przechowalnia/ zapas
8142       integer i,j,ii,jj,iproc,itask(4),nn
8143 c      write (iout,*) "itask",itask
8144       do i=1,2
8145         iproc=itask(i)
8146         if (iproc.gt.0) then
8147           do j=1,num_cont_hb(ii)
8148             jjc=jcont_hb(j,ii)
8149 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8150             if (jjc.eq.jj) then
8151               ncont_sent(iproc)=ncont_sent(iproc)+1
8152               nn=ncont_sent(iproc)
8153               zapas(1,nn,iproc)=ii
8154               zapas(2,nn,iproc)=jjc
8155               zapas(3,nn,iproc)=facont_hb(j,ii)
8156               zapas(4,nn,iproc)=ees0p(j,ii)
8157               zapas(5,nn,iproc)=ees0m(j,ii)
8158               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8159               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8160               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8161               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8162               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8163               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8164               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8165               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8166               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8167               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8168               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8169               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8170               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8171               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8172               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8173               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8174               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8175               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8176               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8177               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8178               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8179               exit
8180             endif
8181           enddo
8182         endif
8183       enddo
8184       return
8185       end
8186 c------------------------------------------------------------------------------
8187       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8188      &  n_corr1)
8189 C This subroutine calculates multi-body contributions to hydrogen-bonding
8190       implicit real*8 (a-h,o-z)
8191       include 'DIMENSIONS'
8192       include 'COMMON.IOUNITS'
8193 #ifdef MPI
8194       include "mpif.h"
8195       parameter (max_cont=maxconts)
8196       parameter (max_dim=70)
8197       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8198       double precision zapas(max_dim,maxconts,max_fg_procs),
8199      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8200       common /przechowalnia/ zapas
8201       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8202      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8203 #endif
8204       include 'COMMON.SETUP'
8205       include 'COMMON.FFIELD'
8206       include 'COMMON.DERIV'
8207       include 'COMMON.LOCAL'
8208       include 'COMMON.INTERACT'
8209       include 'COMMON.CONTACTS'
8210       include 'COMMON.CHAIN'
8211       include 'COMMON.CONTROL'
8212       double precision gx(3),gx1(3)
8213       integer num_cont_hb_old(maxres)
8214       logical lprn,ldone
8215       double precision eello4,eello5,eelo6,eello_turn6
8216       external eello4,eello5,eello6,eello_turn6
8217 C Set lprn=.true. for debugging
8218       lprn=.false.
8219       eturn6=0.0d0
8220 #ifdef MPI
8221       do i=1,nres
8222         num_cont_hb_old(i)=num_cont_hb(i)
8223       enddo
8224       n_corr=0
8225       n_corr1=0
8226       if (nfgtasks.le.1) goto 30
8227       if (lprn) then
8228         write (iout,'(a)') 'Contact function values before RECEIVE:'
8229         do i=nnt,nct-2
8230           write (iout,'(2i3,50(1x,i2,f5.2))')
8231      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8232      &    j=1,num_cont_hb(i))
8233         enddo
8234       endif
8235       call flush(iout)
8236       do i=1,ntask_cont_from
8237         ncont_recv(i)=0
8238       enddo
8239       do i=1,ntask_cont_to
8240         ncont_sent(i)=0
8241       enddo
8242 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8243 c     & ntask_cont_to
8244 C Make the list of contacts to send to send to other procesors
8245       do i=iturn3_start,iturn3_end
8246 c        write (iout,*) "make contact list turn3",i," num_cont",
8247 c     &    num_cont_hb(i)
8248         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8249       enddo
8250       do i=iturn4_start,iturn4_end
8251 c        write (iout,*) "make contact list turn4",i," num_cont",
8252 c     &   num_cont_hb(i)
8253         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8254       enddo
8255       do ii=1,nat_sent
8256         i=iat_sent(ii)
8257 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8258 c     &    num_cont_hb(i)
8259         do j=1,num_cont_hb(i)
8260         do k=1,4
8261           jjc=jcont_hb(j,i)
8262           iproc=iint_sent_local(k,jjc,ii)
8263 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8264           if (iproc.ne.0) then
8265             ncont_sent(iproc)=ncont_sent(iproc)+1
8266             nn=ncont_sent(iproc)
8267             zapas(1,nn,iproc)=i
8268             zapas(2,nn,iproc)=jjc
8269             zapas(3,nn,iproc)=d_cont(j,i)
8270             ind=3
8271             do kk=1,3
8272               ind=ind+1
8273               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8274             enddo
8275             do kk=1,2
8276               do ll=1,2
8277                 ind=ind+1
8278                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8279               enddo
8280             enddo
8281             do jj=1,5
8282               do kk=1,3
8283                 do ll=1,2
8284                   do mm=1,2
8285                     ind=ind+1
8286                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8287                   enddo
8288                 enddo
8289               enddo
8290             enddo
8291           endif
8292         enddo
8293         enddo
8294       enddo
8295       if (lprn) then
8296       write (iout,*)
8297      &  "Numbers of contacts to be sent to other processors",
8298      &  (ncont_sent(i),i=1,ntask_cont_to)
8299       write (iout,*) "Contacts sent"
8300       do ii=1,ntask_cont_to
8301         nn=ncont_sent(ii)
8302         iproc=itask_cont_to(ii)
8303         write (iout,*) nn," contacts to processor",iproc,
8304      &   " of CONT_TO_COMM group"
8305         do i=1,nn
8306           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8307         enddo
8308       enddo
8309       call flush(iout)
8310       endif
8311       CorrelType=477
8312       CorrelID=fg_rank+1
8313       CorrelType1=478
8314       CorrelID1=nfgtasks+fg_rank+1
8315       ireq=0
8316 C Receive the numbers of needed contacts from other processors
8317       do ii=1,ntask_cont_from
8318         iproc=itask_cont_from(ii)
8319         ireq=ireq+1
8320         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8321      &    FG_COMM,req(ireq),IERR)
8322       enddo
8323 c      write (iout,*) "IRECV ended"
8324 c      call flush(iout)
8325 C Send the number of contacts needed by other processors
8326       do ii=1,ntask_cont_to
8327         iproc=itask_cont_to(ii)
8328         ireq=ireq+1
8329         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8330      &    FG_COMM,req(ireq),IERR)
8331       enddo
8332 c      write (iout,*) "ISEND ended"
8333 c      write (iout,*) "number of requests (nn)",ireq
8334       call flush(iout)
8335       if (ireq.gt.0)
8336      &  call MPI_Waitall(ireq,req,status_array,ierr)
8337 c      write (iout,*)
8338 c     &  "Numbers of contacts to be received from other processors",
8339 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8340 c      call flush(iout)
8341 C Receive contacts
8342       ireq=0
8343       do ii=1,ntask_cont_from
8344         iproc=itask_cont_from(ii)
8345         nn=ncont_recv(ii)
8346 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8347 c     &   " of CONT_TO_COMM group"
8348         call flush(iout)
8349         if (nn.gt.0) then
8350           ireq=ireq+1
8351           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8352      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8353 c          write (iout,*) "ireq,req",ireq,req(ireq)
8354         endif
8355       enddo
8356 C Send the contacts to processors that need them
8357       do ii=1,ntask_cont_to
8358         iproc=itask_cont_to(ii)
8359         nn=ncont_sent(ii)
8360 c        write (iout,*) nn," contacts to processor",iproc,
8361 c     &   " of CONT_TO_COMM group"
8362         if (nn.gt.0) then
8363           ireq=ireq+1
8364           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8365      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8366 c          write (iout,*) "ireq,req",ireq,req(ireq)
8367 c          do i=1,nn
8368 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8369 c          enddo
8370         endif
8371       enddo
8372 c      write (iout,*) "number of requests (contacts)",ireq
8373 c      write (iout,*) "req",(req(i),i=1,4)
8374 c      call flush(iout)
8375       if (ireq.gt.0)
8376      & call MPI_Waitall(ireq,req,status_array,ierr)
8377       do iii=1,ntask_cont_from
8378         iproc=itask_cont_from(iii)
8379         nn=ncont_recv(iii)
8380         if (lprn) then
8381         write (iout,*) "Received",nn," contacts from processor",iproc,
8382      &   " of CONT_FROM_COMM group"
8383         call flush(iout)
8384         do i=1,nn
8385           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8386         enddo
8387         call flush(iout)
8388         endif
8389         do i=1,nn
8390           ii=zapas_recv(1,i,iii)
8391 c Flag the received contacts to prevent double-counting
8392           jj=-zapas_recv(2,i,iii)
8393 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8394 c          call flush(iout)
8395           nnn=num_cont_hb(ii)+1
8396           num_cont_hb(ii)=nnn
8397           jcont_hb(nnn,ii)=jj
8398           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8399           ind=3
8400           do kk=1,3
8401             ind=ind+1
8402             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8403           enddo
8404           do kk=1,2
8405             do ll=1,2
8406               ind=ind+1
8407               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8408             enddo
8409           enddo
8410           do jj=1,5
8411             do kk=1,3
8412               do ll=1,2
8413                 do mm=1,2
8414                   ind=ind+1
8415                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8416                 enddo
8417               enddo
8418             enddo
8419           enddo
8420         enddo
8421       enddo
8422       call flush(iout)
8423       if (lprn) then
8424         write (iout,'(a)') 'Contact function values after receive:'
8425         do i=nnt,nct-2
8426           write (iout,'(2i3,50(1x,i3,5f6.3))')
8427      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8428      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8429         enddo
8430         call flush(iout)
8431       endif
8432    30 continue
8433 #endif
8434       if (lprn) then
8435         write (iout,'(a)') 'Contact function values:'
8436         do i=nnt,nct-2
8437           write (iout,'(2i3,50(1x,i2,5f6.3))')
8438      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8439      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8440         enddo
8441       endif
8442       ecorr=0.0D0
8443       ecorr5=0.0d0
8444       ecorr6=0.0d0
8445 C Remove the loop below after debugging !!!
8446       do i=nnt,nct
8447         do j=1,3
8448           gradcorr(j,i)=0.0D0
8449           gradxorr(j,i)=0.0D0
8450         enddo
8451       enddo
8452 C Calculate the dipole-dipole interaction energies
8453       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8454       do i=iatel_s,iatel_e+1
8455         num_conti=num_cont_hb(i)
8456         do jj=1,num_conti
8457           j=jcont_hb(jj,i)
8458 #ifdef MOMENT
8459           call dipole(i,j,jj)
8460 #endif
8461         enddo
8462       enddo
8463       endif
8464 C Calculate the local-electrostatic correlation terms
8465 c                write (iout,*) "gradcorr5 in eello5 before loop"
8466 c                do iii=1,nres
8467 c                  write (iout,'(i5,3f10.5)')
8468 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8469 c                enddo
8470       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8471 c        write (iout,*) "corr loop i",i
8472         i1=i+1
8473         num_conti=num_cont_hb(i)
8474         num_conti1=num_cont_hb(i+1)
8475         do jj=1,num_conti
8476           j=jcont_hb(jj,i)
8477           jp=iabs(j)
8478           do kk=1,num_conti1
8479             j1=jcont_hb(kk,i1)
8480             jp1=iabs(j1)
8481 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8482 c     &         ' jj=',jj,' kk=',kk
8483 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8484             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8485      &          .or. j.lt.0 .and. j1.gt.0) .and.
8486      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8487 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8488 C The system gains extra energy.
8489               n_corr=n_corr+1
8490               sqd1=dsqrt(d_cont(jj,i))
8491               sqd2=dsqrt(d_cont(kk,i1))
8492               sred_geom = sqd1*sqd2
8493               IF (sred_geom.lt.cutoff_corr) THEN
8494                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8495      &            ekont,fprimcont)
8496 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8497 cd     &         ' jj=',jj,' kk=',kk
8498                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8499                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8500                 do l=1,3
8501                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8502                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8503                 enddo
8504                 n_corr1=n_corr1+1
8505 cd               write (iout,*) 'sred_geom=',sred_geom,
8506 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8507 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8508 cd               write (iout,*) "g_contij",g_contij
8509 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8510 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8511                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8512                 if (wcorr4.gt.0.0d0)
8513      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8514                   if (energy_dec.and.wcorr4.gt.0.0d0)
8515      1                 write (iout,'(a6,4i5,0pf7.3)')
8516      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8517 c                write (iout,*) "gradcorr5 before eello5"
8518 c                do iii=1,nres
8519 c                  write (iout,'(i5,3f10.5)')
8520 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8521 c                enddo
8522                 if (wcorr5.gt.0.0d0)
8523      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8524 c                write (iout,*) "gradcorr5 after eello5"
8525 c                do iii=1,nres
8526 c                  write (iout,'(i5,3f10.5)')
8527 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8528 c                enddo
8529                   if (energy_dec.and.wcorr5.gt.0.0d0)
8530      1                 write (iout,'(a6,4i5,0pf7.3)')
8531      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8532 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8533 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8534                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8535      &               .or. wturn6.eq.0.0d0))then
8536 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8537                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8538                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8539      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8540 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8541 cd     &            'ecorr6=',ecorr6
8542 cd                write (iout,'(4e15.5)') sred_geom,
8543 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8544 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8545 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8546                 else if (wturn6.gt.0.0d0
8547      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8548 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8549                   eturn6=eturn6+eello_turn6(i,jj,kk)
8550                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8551      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8552 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8553                 endif
8554               ENDIF
8555 1111          continue
8556             endif
8557           enddo ! kk
8558         enddo ! jj
8559       enddo ! i
8560       do i=1,nres
8561         num_cont_hb(i)=num_cont_hb_old(i)
8562       enddo
8563 c                write (iout,*) "gradcorr5 in eello5"
8564 c                do iii=1,nres
8565 c                  write (iout,'(i5,3f10.5)')
8566 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8567 c                enddo
8568       return
8569       end
8570 c------------------------------------------------------------------------------
8571       subroutine add_hb_contact_eello(ii,jj,itask)
8572       implicit real*8 (a-h,o-z)
8573       include "DIMENSIONS"
8574       include "COMMON.IOUNITS"
8575       integer max_cont
8576       integer max_dim
8577       parameter (max_cont=maxconts)
8578       parameter (max_dim=70)
8579       include "COMMON.CONTACTS"
8580       double precision zapas(max_dim,maxconts,max_fg_procs),
8581      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8582       common /przechowalnia/ zapas
8583       integer i,j,ii,jj,iproc,itask(4),nn
8584 c      write (iout,*) "itask",itask
8585       do i=1,2
8586         iproc=itask(i)
8587         if (iproc.gt.0) then
8588           do j=1,num_cont_hb(ii)
8589             jjc=jcont_hb(j,ii)
8590 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8591             if (jjc.eq.jj) then
8592               ncont_sent(iproc)=ncont_sent(iproc)+1
8593               nn=ncont_sent(iproc)
8594               zapas(1,nn,iproc)=ii
8595               zapas(2,nn,iproc)=jjc
8596               zapas(3,nn,iproc)=d_cont(j,ii)
8597               ind=3
8598               do kk=1,3
8599                 ind=ind+1
8600                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8601               enddo
8602               do kk=1,2
8603                 do ll=1,2
8604                   ind=ind+1
8605                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8606                 enddo
8607               enddo
8608               do jj=1,5
8609                 do kk=1,3
8610                   do ll=1,2
8611                     do mm=1,2
8612                       ind=ind+1
8613                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8614                     enddo
8615                   enddo
8616                 enddo
8617               enddo
8618               exit
8619             endif
8620           enddo
8621         endif
8622       enddo
8623       return
8624       end
8625 c------------------------------------------------------------------------------
8626       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8627       implicit real*8 (a-h,o-z)
8628       include 'DIMENSIONS'
8629       include 'COMMON.IOUNITS'
8630       include 'COMMON.DERIV'
8631       include 'COMMON.INTERACT'
8632       include 'COMMON.CONTACTS'
8633       double precision gx(3),gx1(3)
8634       logical lprn
8635       lprn=.false.
8636       eij=facont_hb(jj,i)
8637       ekl=facont_hb(kk,k)
8638       ees0pij=ees0p(jj,i)
8639       ees0pkl=ees0p(kk,k)
8640       ees0mij=ees0m(jj,i)
8641       ees0mkl=ees0m(kk,k)
8642       ekont=eij*ekl
8643       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8644 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8645 C Following 4 lines for diagnostics.
8646 cd    ees0pkl=0.0D0
8647 cd    ees0pij=1.0D0
8648 cd    ees0mkl=0.0D0
8649 cd    ees0mij=1.0D0
8650 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8651 c     & 'Contacts ',i,j,
8652 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8653 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8654 c     & 'gradcorr_long'
8655 C Calculate the multi-body contribution to energy.
8656 c      ecorr=ecorr+ekont*ees
8657 C Calculate multi-body contributions to the gradient.
8658       coeffpees0pij=coeffp*ees0pij
8659       coeffmees0mij=coeffm*ees0mij
8660       coeffpees0pkl=coeffp*ees0pkl
8661       coeffmees0mkl=coeffm*ees0mkl
8662       do ll=1,3
8663 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8664         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8665      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8666      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8667         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8668      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8669      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8670 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8671         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8672      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8673      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8674         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8675      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8676      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8677         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8678      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8679      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8680         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8681         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8682         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8683      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8684      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8685         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8686         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8687 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8688       enddo
8689 c      write (iout,*)
8690 cgrad      do m=i+1,j-1
8691 cgrad        do ll=1,3
8692 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8693 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8694 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8695 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8696 cgrad        enddo
8697 cgrad      enddo
8698 cgrad      do m=k+1,l-1
8699 cgrad        do ll=1,3
8700 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8701 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8702 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8703 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8704 cgrad        enddo
8705 cgrad      enddo
8706 c      write (iout,*) "ehbcorr",ekont*ees
8707       ehbcorr=ekont*ees
8708       return
8709       end
8710 #ifdef MOMENT
8711 C---------------------------------------------------------------------------
8712       subroutine dipole(i,j,jj)
8713       implicit real*8 (a-h,o-z)
8714       include 'DIMENSIONS'
8715       include 'COMMON.IOUNITS'
8716       include 'COMMON.CHAIN'
8717       include 'COMMON.FFIELD'
8718       include 'COMMON.DERIV'
8719       include 'COMMON.INTERACT'
8720       include 'COMMON.CONTACTS'
8721       include 'COMMON.TORSION'
8722       include 'COMMON.VAR'
8723       include 'COMMON.GEO'
8724       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8725      &  auxmat(2,2)
8726       iti1 = itortyp(itype(i+1))
8727       if (j.lt.nres-1) then
8728         itj1 = itortyp(itype(j+1))
8729       else
8730         itj1=ntortyp+1
8731       endif
8732       do iii=1,2
8733         dipi(iii,1)=Ub2(iii,i)
8734         dipderi(iii)=Ub2der(iii,i)
8735         dipi(iii,2)=b1(iii,iti1)
8736         dipj(iii,1)=Ub2(iii,j)
8737         dipderj(iii)=Ub2der(iii,j)
8738         dipj(iii,2)=b1(iii,itj1)
8739       enddo
8740       kkk=0
8741       do iii=1,2
8742         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8743         do jjj=1,2
8744           kkk=kkk+1
8745           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8746         enddo
8747       enddo
8748       do kkk=1,5
8749         do lll=1,3
8750           mmm=0
8751           do iii=1,2
8752             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8753      &        auxvec(1))
8754             do jjj=1,2
8755               mmm=mmm+1
8756               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8757             enddo
8758           enddo
8759         enddo
8760       enddo
8761       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8762       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8763       do iii=1,2
8764         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8765       enddo
8766       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8767       do iii=1,2
8768         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8769       enddo
8770       return
8771       end
8772 #endif
8773 C---------------------------------------------------------------------------
8774       subroutine calc_eello(i,j,k,l,jj,kk)
8775 C
8776 C This subroutine computes matrices and vectors needed to calculate
8777 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8778 C
8779       implicit real*8 (a-h,o-z)
8780       include 'DIMENSIONS'
8781       include 'COMMON.IOUNITS'
8782       include 'COMMON.CHAIN'
8783       include 'COMMON.DERIV'
8784       include 'COMMON.INTERACT'
8785       include 'COMMON.CONTACTS'
8786       include 'COMMON.TORSION'
8787       include 'COMMON.VAR'
8788       include 'COMMON.GEO'
8789       include 'COMMON.FFIELD'
8790       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8791      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8792       logical lprn
8793       common /kutas/ lprn
8794 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8795 cd     & ' jj=',jj,' kk=',kk
8796 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8797 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8798 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8799       do iii=1,2
8800         do jjj=1,2
8801           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8802           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8803         enddo
8804       enddo
8805       call transpose2(aa1(1,1),aa1t(1,1))
8806       call transpose2(aa2(1,1),aa2t(1,1))
8807       do kkk=1,5
8808         do lll=1,3
8809           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8810      &      aa1tder(1,1,lll,kkk))
8811           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8812      &      aa2tder(1,1,lll,kkk))
8813         enddo
8814       enddo
8815       if (l.eq.j+1) then
8816 C parallel orientation of the two CA-CA-CA frames.
8817         if (i.gt.1) then
8818           iti=itortyp(itype(i))
8819         else
8820           iti=ntortyp+1
8821         endif
8822         itk1=itortyp(itype(k+1))
8823         itj=itortyp(itype(j))
8824         if (l.lt.nres-1) then
8825           itl1=itortyp(itype(l+1))
8826         else
8827           itl1=ntortyp+1
8828         endif
8829 C A1 kernel(j+1) A2T
8830 cd        do iii=1,2
8831 cd          write (iout,'(3f10.5,5x,3f10.5)')
8832 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8833 cd        enddo
8834         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8835      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8836      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8837 C Following matrices are needed only for 6-th order cumulants
8838         IF (wcorr6.gt.0.0d0) THEN
8839         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8840      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8841      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8842         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8843      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8844      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8845      &   ADtEAderx(1,1,1,1,1,1))
8846         lprn=.false.
8847         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8848      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8849      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8850      &   ADtEA1derx(1,1,1,1,1,1))
8851         ENDIF
8852 C End 6-th order cumulants
8853 cd        lprn=.false.
8854 cd        if (lprn) then
8855 cd        write (2,*) 'In calc_eello6'
8856 cd        do iii=1,2
8857 cd          write (2,*) 'iii=',iii
8858 cd          do kkk=1,5
8859 cd            write (2,*) 'kkk=',kkk
8860 cd            do jjj=1,2
8861 cd              write (2,'(3(2f10.5),5x)')
8862 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8863 cd            enddo
8864 cd          enddo
8865 cd        enddo
8866 cd        endif
8867         call transpose2(EUgder(1,1,k),auxmat(1,1))
8868         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8869         call transpose2(EUg(1,1,k),auxmat(1,1))
8870         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8871         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8872         do iii=1,2
8873           do kkk=1,5
8874             do lll=1,3
8875               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8876      &          EAEAderx(1,1,lll,kkk,iii,1))
8877             enddo
8878           enddo
8879         enddo
8880 C A1T kernel(i+1) A2
8881         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8882      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8883      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8884 C Following matrices are needed only for 6-th order cumulants
8885         IF (wcorr6.gt.0.0d0) THEN
8886         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8887      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8888      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8889         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8890      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8891      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8892      &   ADtEAderx(1,1,1,1,1,2))
8893         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8894      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8895      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8896      &   ADtEA1derx(1,1,1,1,1,2))
8897         ENDIF
8898 C End 6-th order cumulants
8899         call transpose2(EUgder(1,1,l),auxmat(1,1))
8900         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8901         call transpose2(EUg(1,1,l),auxmat(1,1))
8902         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8903         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8904         do iii=1,2
8905           do kkk=1,5
8906             do lll=1,3
8907               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8908      &          EAEAderx(1,1,lll,kkk,iii,2))
8909             enddo
8910           enddo
8911         enddo
8912 C AEAb1 and AEAb2
8913 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8914 C They are needed only when the fifth- or the sixth-order cumulants are
8915 C indluded.
8916         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8917         call transpose2(AEA(1,1,1),auxmat(1,1))
8918         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8919         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8920         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8921         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8922         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8923         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8924         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8925         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8926         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8927         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8928         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8929         call transpose2(AEA(1,1,2),auxmat(1,1))
8930         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8931         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8932         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8933         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8934         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8935         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8936         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8937         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8938         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8939         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8940         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8941 C Calculate the Cartesian derivatives of the vectors.
8942         do iii=1,2
8943           do kkk=1,5
8944             do lll=1,3
8945               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8946               call matvec2(auxmat(1,1),b1(1,iti),
8947      &          AEAb1derx(1,lll,kkk,iii,1,1))
8948               call matvec2(auxmat(1,1),Ub2(1,i),
8949      &          AEAb2derx(1,lll,kkk,iii,1,1))
8950               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8951      &          AEAb1derx(1,lll,kkk,iii,2,1))
8952               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8953      &          AEAb2derx(1,lll,kkk,iii,2,1))
8954               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8955               call matvec2(auxmat(1,1),b1(1,itj),
8956      &          AEAb1derx(1,lll,kkk,iii,1,2))
8957               call matvec2(auxmat(1,1),Ub2(1,j),
8958      &          AEAb2derx(1,lll,kkk,iii,1,2))
8959               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8960      &          AEAb1derx(1,lll,kkk,iii,2,2))
8961               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8962      &          AEAb2derx(1,lll,kkk,iii,2,2))
8963             enddo
8964           enddo
8965         enddo
8966         ENDIF
8967 C End vectors
8968       else
8969 C Antiparallel orientation of the two CA-CA-CA frames.
8970         if (i.gt.1) then
8971           iti=itortyp(itype(i))
8972         else
8973           iti=ntortyp+1
8974         endif
8975         itk1=itortyp(itype(k+1))
8976         itl=itortyp(itype(l))
8977         itj=itortyp(itype(j))
8978         if (j.lt.nres-1) then
8979           itj1=itortyp(itype(j+1))
8980         else
8981           itj1=ntortyp+1
8982         endif
8983 C A2 kernel(j-1)T A1T
8984         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8985      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8986      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8987 C Following matrices are needed only for 6-th order cumulants
8988         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8989      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8990         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8991      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8992      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8993         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8994      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8995      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8996      &   ADtEAderx(1,1,1,1,1,1))
8997         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8998      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8999      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9000      &   ADtEA1derx(1,1,1,1,1,1))
9001         ENDIF
9002 C End 6-th order cumulants
9003         call transpose2(EUgder(1,1,k),auxmat(1,1))
9004         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9005         call transpose2(EUg(1,1,k),auxmat(1,1))
9006         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9007         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9008         do iii=1,2
9009           do kkk=1,5
9010             do lll=1,3
9011               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9012      &          EAEAderx(1,1,lll,kkk,iii,1))
9013             enddo
9014           enddo
9015         enddo
9016 C A2T kernel(i+1)T A1
9017         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9018      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9019      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9020 C Following matrices are needed only for 6-th order cumulants
9021         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9022      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9023         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9024      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9025      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9026         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9027      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9028      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9029      &   ADtEAderx(1,1,1,1,1,2))
9030         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9031      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9032      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9033      &   ADtEA1derx(1,1,1,1,1,2))
9034         ENDIF
9035 C End 6-th order cumulants
9036         call transpose2(EUgder(1,1,j),auxmat(1,1))
9037         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9038         call transpose2(EUg(1,1,j),auxmat(1,1))
9039         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9040         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9041         do iii=1,2
9042           do kkk=1,5
9043             do lll=1,3
9044               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9045      &          EAEAderx(1,1,lll,kkk,iii,2))
9046             enddo
9047           enddo
9048         enddo
9049 C AEAb1 and AEAb2
9050 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9051 C They are needed only when the fifth- or the sixth-order cumulants are
9052 C indluded.
9053         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9054      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9055         call transpose2(AEA(1,1,1),auxmat(1,1))
9056         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9057         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9058         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9059         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9060         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9061         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9062         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9063         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9064         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9065         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9066         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9067         call transpose2(AEA(1,1,2),auxmat(1,1))
9068         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9069         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9070         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9071         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9072         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9073         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9074         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9075         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9076         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9077         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9078         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9079 C Calculate the Cartesian derivatives of the vectors.
9080         do iii=1,2
9081           do kkk=1,5
9082             do lll=1,3
9083               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9084               call matvec2(auxmat(1,1),b1(1,iti),
9085      &          AEAb1derx(1,lll,kkk,iii,1,1))
9086               call matvec2(auxmat(1,1),Ub2(1,i),
9087      &          AEAb2derx(1,lll,kkk,iii,1,1))
9088               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9089      &          AEAb1derx(1,lll,kkk,iii,2,1))
9090               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9091      &          AEAb2derx(1,lll,kkk,iii,2,1))
9092               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9093               call matvec2(auxmat(1,1),b1(1,itl),
9094      &          AEAb1derx(1,lll,kkk,iii,1,2))
9095               call matvec2(auxmat(1,1),Ub2(1,l),
9096      &          AEAb2derx(1,lll,kkk,iii,1,2))
9097               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
9098      &          AEAb1derx(1,lll,kkk,iii,2,2))
9099               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9100      &          AEAb2derx(1,lll,kkk,iii,2,2))
9101             enddo
9102           enddo
9103         enddo
9104         ENDIF
9105 C End vectors
9106       endif
9107       return
9108       end
9109 C---------------------------------------------------------------------------
9110       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9111      &  KK,KKderg,AKA,AKAderg,AKAderx)
9112       implicit none
9113       integer nderg
9114       logical transp
9115       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9116      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9117      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9118       integer iii,kkk,lll
9119       integer jjj,mmm
9120       logical lprn
9121       common /kutas/ lprn
9122       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9123       do iii=1,nderg
9124         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9125      &    AKAderg(1,1,iii))
9126       enddo
9127 cd      if (lprn) write (2,*) 'In kernel'
9128       do kkk=1,5
9129 cd        if (lprn) write (2,*) 'kkk=',kkk
9130         do lll=1,3
9131           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9132      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9133 cd          if (lprn) then
9134 cd            write (2,*) 'lll=',lll
9135 cd            write (2,*) 'iii=1'
9136 cd            do jjj=1,2
9137 cd              write (2,'(3(2f10.5),5x)')
9138 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9139 cd            enddo
9140 cd          endif
9141           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9142      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9143 cd          if (lprn) then
9144 cd            write (2,*) 'lll=',lll
9145 cd            write (2,*) 'iii=2'
9146 cd            do jjj=1,2
9147 cd              write (2,'(3(2f10.5),5x)')
9148 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9149 cd            enddo
9150 cd          endif
9151         enddo
9152       enddo
9153       return
9154       end
9155 C---------------------------------------------------------------------------
9156       double precision function eello4(i,j,k,l,jj,kk)
9157       implicit real*8 (a-h,o-z)
9158       include 'DIMENSIONS'
9159       include 'COMMON.IOUNITS'
9160       include 'COMMON.CHAIN'
9161       include 'COMMON.DERIV'
9162       include 'COMMON.INTERACT'
9163       include 'COMMON.CONTACTS'
9164       include 'COMMON.TORSION'
9165       include 'COMMON.VAR'
9166       include 'COMMON.GEO'
9167       double precision pizda(2,2),ggg1(3),ggg2(3)
9168 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9169 cd        eello4=0.0d0
9170 cd        return
9171 cd      endif
9172 cd      print *,'eello4:',i,j,k,l,jj,kk
9173 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9174 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9175 cold      eij=facont_hb(jj,i)
9176 cold      ekl=facont_hb(kk,k)
9177 cold      ekont=eij*ekl
9178       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9179 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9180       gcorr_loc(k-1)=gcorr_loc(k-1)
9181      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9182       if (l.eq.j+1) then
9183         gcorr_loc(l-1)=gcorr_loc(l-1)
9184      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9185       else
9186         gcorr_loc(j-1)=gcorr_loc(j-1)
9187      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9188       endif
9189       do iii=1,2
9190         do kkk=1,5
9191           do lll=1,3
9192             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9193      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9194 cd            derx(lll,kkk,iii)=0.0d0
9195           enddo
9196         enddo
9197       enddo
9198 cd      gcorr_loc(l-1)=0.0d0
9199 cd      gcorr_loc(j-1)=0.0d0
9200 cd      gcorr_loc(k-1)=0.0d0
9201 cd      eel4=1.0d0
9202 cd      write (iout,*)'Contacts have occurred for peptide groups',
9203 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9204 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9205       if (j.lt.nres-1) then
9206         j1=j+1
9207         j2=j-1
9208       else
9209         j1=j-1
9210         j2=j-2
9211       endif
9212       if (l.lt.nres-1) then
9213         l1=l+1
9214         l2=l-1
9215       else
9216         l1=l-1
9217         l2=l-2
9218       endif
9219       do ll=1,3
9220 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9221 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9222         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9223         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9224 cgrad        ghalf=0.5d0*ggg1(ll)
9225         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9226         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9227         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9228         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9229         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9230         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9231 cgrad        ghalf=0.5d0*ggg2(ll)
9232         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9233         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9234         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9235         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9236         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9237         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9238       enddo
9239 cgrad      do m=i+1,j-1
9240 cgrad        do ll=1,3
9241 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9242 cgrad        enddo
9243 cgrad      enddo
9244 cgrad      do m=k+1,l-1
9245 cgrad        do ll=1,3
9246 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9247 cgrad        enddo
9248 cgrad      enddo
9249 cgrad      do m=i+2,j2
9250 cgrad        do ll=1,3
9251 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9252 cgrad        enddo
9253 cgrad      enddo
9254 cgrad      do m=k+2,l2
9255 cgrad        do ll=1,3
9256 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9257 cgrad        enddo
9258 cgrad      enddo
9259 cd      do iii=1,nres-3
9260 cd        write (2,*) iii,gcorr_loc(iii)
9261 cd      enddo
9262       eello4=ekont*eel4
9263 cd      write (2,*) 'ekont',ekont
9264 cd      write (iout,*) 'eello4',ekont*eel4
9265       return
9266       end
9267 C---------------------------------------------------------------------------
9268       double precision function eello5(i,j,k,l,jj,kk)
9269       implicit real*8 (a-h,o-z)
9270       include 'DIMENSIONS'
9271       include 'COMMON.IOUNITS'
9272       include 'COMMON.CHAIN'
9273       include 'COMMON.DERIV'
9274       include 'COMMON.INTERACT'
9275       include 'COMMON.CONTACTS'
9276       include 'COMMON.TORSION'
9277       include 'COMMON.VAR'
9278       include 'COMMON.GEO'
9279       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9280       double precision ggg1(3),ggg2(3)
9281 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9282 C                                                                              C
9283 C                            Parallel chains                                   C
9284 C                                                                              C
9285 C          o             o                   o             o                   C
9286 C         /l\           / \             \   / \           / \   /              C
9287 C        /   \         /   \             \ /   \         /   \ /               C
9288 C       j| o |l1       | o |              o| o |         | o |o                C
9289 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9290 C      \i/   \         /   \ /             /   \         /   \                 C
9291 C       o    k1             o                                                  C
9292 C         (I)          (II)                (III)          (IV)                 C
9293 C                                                                              C
9294 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9295 C                                                                              C
9296 C                            Antiparallel chains                               C
9297 C                                                                              C
9298 C          o             o                   o             o                   C
9299 C         /j\           / \             \   / \           / \   /              C
9300 C        /   \         /   \             \ /   \         /   \ /               C
9301 C      j1| o |l        | o |              o| o |         | o |o                C
9302 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9303 C      \i/   \         /   \ /             /   \         /   \                 C
9304 C       o     k1            o                                                  C
9305 C         (I)          (II)                (III)          (IV)                 C
9306 C                                                                              C
9307 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9308 C                                                                              C
9309 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9310 C                                                                              C
9311 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9312 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9313 cd        eello5=0.0d0
9314 cd        return
9315 cd      endif
9316 cd      write (iout,*)
9317 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9318 cd     &   ' and',k,l
9319       itk=itortyp(itype(k))
9320       itl=itortyp(itype(l))
9321       itj=itortyp(itype(j))
9322       eello5_1=0.0d0
9323       eello5_2=0.0d0
9324       eello5_3=0.0d0
9325       eello5_4=0.0d0
9326 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9327 cd     &   eel5_3_num,eel5_4_num)
9328       do iii=1,2
9329         do kkk=1,5
9330           do lll=1,3
9331             derx(lll,kkk,iii)=0.0d0
9332           enddo
9333         enddo
9334       enddo
9335 cd      eij=facont_hb(jj,i)
9336 cd      ekl=facont_hb(kk,k)
9337 cd      ekont=eij*ekl
9338 cd      write (iout,*)'Contacts have occurred for peptide groups',
9339 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9340 cd      goto 1111
9341 C Contribution from the graph I.
9342 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9343 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9344       call transpose2(EUg(1,1,k),auxmat(1,1))
9345       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9346       vv(1)=pizda(1,1)-pizda(2,2)
9347       vv(2)=pizda(1,2)+pizda(2,1)
9348       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9349      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9350 C Explicit gradient in virtual-dihedral angles.
9351       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9352      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9353      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9354       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9355       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9356       vv(1)=pizda(1,1)-pizda(2,2)
9357       vv(2)=pizda(1,2)+pizda(2,1)
9358       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9359      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9360      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9361       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9362       vv(1)=pizda(1,1)-pizda(2,2)
9363       vv(2)=pizda(1,2)+pizda(2,1)
9364       if (l.eq.j+1) then
9365         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9366      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9367      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9368       else
9369         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9370      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9371      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9372       endif
9373 C Cartesian gradient
9374       do iii=1,2
9375         do kkk=1,5
9376           do lll=1,3
9377             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9378      &        pizda(1,1))
9379             vv(1)=pizda(1,1)-pizda(2,2)
9380             vv(2)=pizda(1,2)+pizda(2,1)
9381             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9382      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9383      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9384           enddo
9385         enddo
9386       enddo
9387 c      goto 1112
9388 c1111  continue
9389 C Contribution from graph II
9390       call transpose2(EE(1,1,itk),auxmat(1,1))
9391       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9392       vv(1)=pizda(1,1)+pizda(2,2)
9393       vv(2)=pizda(2,1)-pizda(1,2)
9394       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
9395      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9396 C Explicit gradient in virtual-dihedral angles.
9397       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9398      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9399       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9400       vv(1)=pizda(1,1)+pizda(2,2)
9401       vv(2)=pizda(2,1)-pizda(1,2)
9402       if (l.eq.j+1) then
9403         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9404      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
9405      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9406       else
9407         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9408      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
9409      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9410       endif
9411 C Cartesian gradient
9412       do iii=1,2
9413         do kkk=1,5
9414           do lll=1,3
9415             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9416      &        pizda(1,1))
9417             vv(1)=pizda(1,1)+pizda(2,2)
9418             vv(2)=pizda(2,1)-pizda(1,2)
9419             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9420      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
9421      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9422           enddo
9423         enddo
9424       enddo
9425 cd      goto 1112
9426 cd1111  continue
9427       if (l.eq.j+1) then
9428 cd        goto 1110
9429 C Parallel orientation
9430 C Contribution from graph III
9431         call transpose2(EUg(1,1,l),auxmat(1,1))
9432         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9433         vv(1)=pizda(1,1)-pizda(2,2)
9434         vv(2)=pizda(1,2)+pizda(2,1)
9435         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9436      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9437 C Explicit gradient in virtual-dihedral angles.
9438         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9439      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9440      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9441         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9442         vv(1)=pizda(1,1)-pizda(2,2)
9443         vv(2)=pizda(1,2)+pizda(2,1)
9444         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9445      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9446      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9447         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9448         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9449         vv(1)=pizda(1,1)-pizda(2,2)
9450         vv(2)=pizda(1,2)+pizda(2,1)
9451         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9452      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9453      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9454 C Cartesian gradient
9455         do iii=1,2
9456           do kkk=1,5
9457             do lll=1,3
9458               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9459      &          pizda(1,1))
9460               vv(1)=pizda(1,1)-pizda(2,2)
9461               vv(2)=pizda(1,2)+pizda(2,1)
9462               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9463      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9464      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9465             enddo
9466           enddo
9467         enddo
9468 cd        goto 1112
9469 C Contribution from graph IV
9470 cd1110    continue
9471         call transpose2(EE(1,1,itl),auxmat(1,1))
9472         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9473         vv(1)=pizda(1,1)+pizda(2,2)
9474         vv(2)=pizda(2,1)-pizda(1,2)
9475         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
9476      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9477 C Explicit gradient in virtual-dihedral angles.
9478         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9479      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9480         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9481         vv(1)=pizda(1,1)+pizda(2,2)
9482         vv(2)=pizda(2,1)-pizda(1,2)
9483         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9484      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
9485      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9486 C Cartesian gradient
9487         do iii=1,2
9488           do kkk=1,5
9489             do lll=1,3
9490               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9491      &          pizda(1,1))
9492               vv(1)=pizda(1,1)+pizda(2,2)
9493               vv(2)=pizda(2,1)-pizda(1,2)
9494               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9495      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
9496      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9497             enddo
9498           enddo
9499         enddo
9500       else
9501 C Antiparallel orientation
9502 C Contribution from graph III
9503 c        goto 1110
9504         call transpose2(EUg(1,1,j),auxmat(1,1))
9505         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9506         vv(1)=pizda(1,1)-pizda(2,2)
9507         vv(2)=pizda(1,2)+pizda(2,1)
9508         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9509      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9510 C Explicit gradient in virtual-dihedral angles.
9511         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9512      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9513      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9514         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9515         vv(1)=pizda(1,1)-pizda(2,2)
9516         vv(2)=pizda(1,2)+pizda(2,1)
9517         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9518      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9519      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9520         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9521         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9522         vv(1)=pizda(1,1)-pizda(2,2)
9523         vv(2)=pizda(1,2)+pizda(2,1)
9524         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9525      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9526      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9527 C Cartesian gradient
9528         do iii=1,2
9529           do kkk=1,5
9530             do lll=1,3
9531               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9532      &          pizda(1,1))
9533               vv(1)=pizda(1,1)-pizda(2,2)
9534               vv(2)=pizda(1,2)+pizda(2,1)
9535               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9536      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9537      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9538             enddo
9539           enddo
9540         enddo
9541 cd        goto 1112
9542 C Contribution from graph IV
9543 1110    continue
9544         call transpose2(EE(1,1,itj),auxmat(1,1))
9545         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9546         vv(1)=pizda(1,1)+pizda(2,2)
9547         vv(2)=pizda(2,1)-pizda(1,2)
9548         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
9549      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9550 C Explicit gradient in virtual-dihedral angles.
9551         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9552      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9553         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9554         vv(1)=pizda(1,1)+pizda(2,2)
9555         vv(2)=pizda(2,1)-pizda(1,2)
9556         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9557      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
9558      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9559 C Cartesian gradient
9560         do iii=1,2
9561           do kkk=1,5
9562             do lll=1,3
9563               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9564      &          pizda(1,1))
9565               vv(1)=pizda(1,1)+pizda(2,2)
9566               vv(2)=pizda(2,1)-pizda(1,2)
9567               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9568      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
9569      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9570             enddo
9571           enddo
9572         enddo
9573       endif
9574 1112  continue
9575       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9576 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9577 cd        write (2,*) 'ijkl',i,j,k,l
9578 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9579 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9580 cd      endif
9581 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9582 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9583 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9584 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9585       if (j.lt.nres-1) then
9586         j1=j+1
9587         j2=j-1
9588       else
9589         j1=j-1
9590         j2=j-2
9591       endif
9592       if (l.lt.nres-1) then
9593         l1=l+1
9594         l2=l-1
9595       else
9596         l1=l-1
9597         l2=l-2
9598       endif
9599 cd      eij=1.0d0
9600 cd      ekl=1.0d0
9601 cd      ekont=1.0d0
9602 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9603 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9604 C        summed up outside the subrouine as for the other subroutines
9605 C        handling long-range interactions. The old code is commented out
9606 C        with "cgrad" to keep track of changes.
9607       do ll=1,3
9608 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9609 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9610         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9611         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9612 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9613 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9614 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9615 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9616 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9617 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9618 c     &   gradcorr5ij,
9619 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9620 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9621 cgrad        ghalf=0.5d0*ggg1(ll)
9622 cd        ghalf=0.0d0
9623         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9624         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9625         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9626         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9627         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9628         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9629 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9630 cgrad        ghalf=0.5d0*ggg2(ll)
9631 cd        ghalf=0.0d0
9632         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9633         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9634         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9635         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9636         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9637         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9638       enddo
9639 cd      goto 1112
9640 cgrad      do m=i+1,j-1
9641 cgrad        do ll=1,3
9642 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9643 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9644 cgrad        enddo
9645 cgrad      enddo
9646 cgrad      do m=k+1,l-1
9647 cgrad        do ll=1,3
9648 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9649 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9650 cgrad        enddo
9651 cgrad      enddo
9652 c1112  continue
9653 cgrad      do m=i+2,j2
9654 cgrad        do ll=1,3
9655 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9656 cgrad        enddo
9657 cgrad      enddo
9658 cgrad      do m=k+2,l2
9659 cgrad        do ll=1,3
9660 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9661 cgrad        enddo
9662 cgrad      enddo
9663 cd      do iii=1,nres-3
9664 cd        write (2,*) iii,g_corr5_loc(iii)
9665 cd      enddo
9666       eello5=ekont*eel5
9667 cd      write (2,*) 'ekont',ekont
9668 cd      write (iout,*) 'eello5',ekont*eel5
9669       return
9670       end
9671 c--------------------------------------------------------------------------
9672       double precision function eello6(i,j,k,l,jj,kk)
9673       implicit real*8 (a-h,o-z)
9674       include 'DIMENSIONS'
9675       include 'COMMON.IOUNITS'
9676       include 'COMMON.CHAIN'
9677       include 'COMMON.DERIV'
9678       include 'COMMON.INTERACT'
9679       include 'COMMON.CONTACTS'
9680       include 'COMMON.TORSION'
9681       include 'COMMON.VAR'
9682       include 'COMMON.GEO'
9683       include 'COMMON.FFIELD'
9684       double precision ggg1(3),ggg2(3)
9685 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9686 cd        eello6=0.0d0
9687 cd        return
9688 cd      endif
9689 cd      write (iout,*)
9690 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9691 cd     &   ' and',k,l
9692       eello6_1=0.0d0
9693       eello6_2=0.0d0
9694       eello6_3=0.0d0
9695       eello6_4=0.0d0
9696       eello6_5=0.0d0
9697       eello6_6=0.0d0
9698 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9699 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9700       do iii=1,2
9701         do kkk=1,5
9702           do lll=1,3
9703             derx(lll,kkk,iii)=0.0d0
9704           enddo
9705         enddo
9706       enddo
9707 cd      eij=facont_hb(jj,i)
9708 cd      ekl=facont_hb(kk,k)
9709 cd      ekont=eij*ekl
9710 cd      eij=1.0d0
9711 cd      ekl=1.0d0
9712 cd      ekont=1.0d0
9713       if (l.eq.j+1) then
9714         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9715         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9716         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9717         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9718         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9719         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9720       else
9721         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9722         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9723         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9724         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9725         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9726           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9727         else
9728           eello6_5=0.0d0
9729         endif
9730         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9731       endif
9732 C If turn contributions are considered, they will be handled separately.
9733       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9734 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9735 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9736 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9737 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9738 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9739 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9740 cd      goto 1112
9741       if (j.lt.nres-1) then
9742         j1=j+1
9743         j2=j-1
9744       else
9745         j1=j-1
9746         j2=j-2
9747       endif
9748       if (l.lt.nres-1) then
9749         l1=l+1
9750         l2=l-1
9751       else
9752         l1=l-1
9753         l2=l-2
9754       endif
9755       do ll=1,3
9756 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9757 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9758 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9759 cgrad        ghalf=0.5d0*ggg1(ll)
9760 cd        ghalf=0.0d0
9761         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9762         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9763         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9764         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9765         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9766         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9767         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9768         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9769 cgrad        ghalf=0.5d0*ggg2(ll)
9770 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9771 cd        ghalf=0.0d0
9772         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9773         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9774         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9775         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9776         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9777         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9778       enddo
9779 cd      goto 1112
9780 cgrad      do m=i+1,j-1
9781 cgrad        do ll=1,3
9782 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9783 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9784 cgrad        enddo
9785 cgrad      enddo
9786 cgrad      do m=k+1,l-1
9787 cgrad        do ll=1,3
9788 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9789 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9790 cgrad        enddo
9791 cgrad      enddo
9792 cgrad1112  continue
9793 cgrad      do m=i+2,j2
9794 cgrad        do ll=1,3
9795 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9796 cgrad        enddo
9797 cgrad      enddo
9798 cgrad      do m=k+2,l2
9799 cgrad        do ll=1,3
9800 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9801 cgrad        enddo
9802 cgrad      enddo
9803 cd      do iii=1,nres-3
9804 cd        write (2,*) iii,g_corr6_loc(iii)
9805 cd      enddo
9806       eello6=ekont*eel6
9807 cd      write (2,*) 'ekont',ekont
9808 cd      write (iout,*) 'eello6',ekont*eel6
9809       return
9810       end
9811 c--------------------------------------------------------------------------
9812       double precision function eello6_graph1(i,j,k,l,imat,swap)
9813       implicit real*8 (a-h,o-z)
9814       include 'DIMENSIONS'
9815       include 'COMMON.IOUNITS'
9816       include 'COMMON.CHAIN'
9817       include 'COMMON.DERIV'
9818       include 'COMMON.INTERACT'
9819       include 'COMMON.CONTACTS'
9820       include 'COMMON.TORSION'
9821       include 'COMMON.VAR'
9822       include 'COMMON.GEO'
9823       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9824       logical swap
9825       logical lprn
9826       common /kutas/ lprn
9827 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9828 C
9829 C      Parallel       Antiparallel
9830 C
9831 C          o             o
9832 C         /l\           /j\
9833 C        /   \         /   \
9834 C       /| o |         | o |\
9835 C     \ j|/k\|  /   \  |/k\|l /
9836 C      \ /   \ /     \ /   \ /
9837 C       o     o       o     o
9838 C       i             i
9839 C
9840 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9841       itk=itortyp(itype(k))
9842       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9843       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9844       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9845       call transpose2(EUgC(1,1,k),auxmat(1,1))
9846       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9847       vv1(1)=pizda1(1,1)-pizda1(2,2)
9848       vv1(2)=pizda1(1,2)+pizda1(2,1)
9849       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9850       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9851       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9852       s5=scalar2(vv(1),Dtobr2(1,i))
9853 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9854       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9855       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9856      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9857      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9858      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9859      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9860      & +scalar2(vv(1),Dtobr2der(1,i)))
9861       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9862       vv1(1)=pizda1(1,1)-pizda1(2,2)
9863       vv1(2)=pizda1(1,2)+pizda1(2,1)
9864       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9865       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9866       if (l.eq.j+1) then
9867         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9868      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9869      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9870      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9871      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9872       else
9873         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9874      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9875      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9876      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9877      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9878       endif
9879       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9880       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9881       vv1(1)=pizda1(1,1)-pizda1(2,2)
9882       vv1(2)=pizda1(1,2)+pizda1(2,1)
9883       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9884      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9885      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9886      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9887       do iii=1,2
9888         if (swap) then
9889           ind=3-iii
9890         else
9891           ind=iii
9892         endif
9893         do kkk=1,5
9894           do lll=1,3
9895             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9896             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9897             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9898             call transpose2(EUgC(1,1,k),auxmat(1,1))
9899             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9900      &        pizda1(1,1))
9901             vv1(1)=pizda1(1,1)-pizda1(2,2)
9902             vv1(2)=pizda1(1,2)+pizda1(2,1)
9903             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9904             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
9905      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9906             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
9907      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9908             s5=scalar2(vv(1),Dtobr2(1,i))
9909             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9910           enddo
9911         enddo
9912       enddo
9913       return
9914       end
9915 c----------------------------------------------------------------------------
9916       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9917       implicit real*8 (a-h,o-z)
9918       include 'DIMENSIONS'
9919       include 'COMMON.IOUNITS'
9920       include 'COMMON.CHAIN'
9921       include 'COMMON.DERIV'
9922       include 'COMMON.INTERACT'
9923       include 'COMMON.CONTACTS'
9924       include 'COMMON.TORSION'
9925       include 'COMMON.VAR'
9926       include 'COMMON.GEO'
9927       logical swap
9928       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9929      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9930       logical lprn
9931       common /kutas/ lprn
9932 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9933 C                                                                              C
9934 C      Parallel       Antiparallel                                             C
9935 C                                                                              C
9936 C          o             o                                                     C
9937 C     \   /l\           /j\   /                                                C
9938 C      \ /   \         /   \ /                                                 C
9939 C       o| o |         | o |o                                                  C
9940 C     \ j|/k\|      \  |/k\|l                                                  C
9941 C      \ /   \       \ /   \                                                   C
9942 C       o             o                                                        C
9943 C       i             i                                                        C
9944 C                                                                              C
9945 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9946 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9947 C AL 7/4/01 s1 would occur in the sixth-order moment,
9948 C           but not in a cluster cumulant
9949 #ifdef MOMENT
9950       s1=dip(1,jj,i)*dip(1,kk,k)
9951 #endif
9952       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9953       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9954       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9955       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9956       call transpose2(EUg(1,1,k),auxmat(1,1))
9957       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9958       vv(1)=pizda(1,1)-pizda(2,2)
9959       vv(2)=pizda(1,2)+pizda(2,1)
9960       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9961 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9962 #ifdef MOMENT
9963       eello6_graph2=-(s1+s2+s3+s4)
9964 #else
9965       eello6_graph2=-(s2+s3+s4)
9966 #endif
9967 c      eello6_graph2=-s3
9968 C Derivatives in gamma(i-1)
9969       if (i.gt.1) then
9970 #ifdef MOMENT
9971         s1=dipderg(1,jj,i)*dip(1,kk,k)
9972 #endif
9973         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9974         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9975         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9976         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9977 #ifdef MOMENT
9978         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9979 #else
9980         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9981 #endif
9982 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9983       endif
9984 C Derivatives in gamma(k-1)
9985 #ifdef MOMENT
9986       s1=dip(1,jj,i)*dipderg(1,kk,k)
9987 #endif
9988       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9989       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9990       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9991       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9992       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9993       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9994       vv(1)=pizda(1,1)-pizda(2,2)
9995       vv(2)=pizda(1,2)+pizda(2,1)
9996       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9997 #ifdef MOMENT
9998       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9999 #else
10000       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10001 #endif
10002 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10003 C Derivatives in gamma(j-1) or gamma(l-1)
10004       if (j.gt.1) then
10005 #ifdef MOMENT
10006         s1=dipderg(3,jj,i)*dip(1,kk,k)
10007 #endif
10008         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10009         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10010         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10011         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10012         vv(1)=pizda(1,1)-pizda(2,2)
10013         vv(2)=pizda(1,2)+pizda(2,1)
10014         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10015 #ifdef MOMENT
10016         if (swap) then
10017           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10018         else
10019           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10020         endif
10021 #endif
10022         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10023 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10024       endif
10025 C Derivatives in gamma(l-1) or gamma(j-1)
10026       if (l.gt.1) then
10027 #ifdef MOMENT
10028         s1=dip(1,jj,i)*dipderg(3,kk,k)
10029 #endif
10030         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10031         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10032         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10033         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10034         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10035         vv(1)=pizda(1,1)-pizda(2,2)
10036         vv(2)=pizda(1,2)+pizda(2,1)
10037         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10038 #ifdef MOMENT
10039         if (swap) then
10040           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10041         else
10042           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10043         endif
10044 #endif
10045         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10046 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10047       endif
10048 C Cartesian derivatives.
10049       if (lprn) then
10050         write (2,*) 'In eello6_graph2'
10051         do iii=1,2
10052           write (2,*) 'iii=',iii
10053           do kkk=1,5
10054             write (2,*) 'kkk=',kkk
10055             do jjj=1,2
10056               write (2,'(3(2f10.5),5x)')
10057      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10058             enddo
10059           enddo
10060         enddo
10061       endif
10062       do iii=1,2
10063         do kkk=1,5
10064           do lll=1,3
10065 #ifdef MOMENT
10066             if (iii.eq.1) then
10067               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10068             else
10069               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10070             endif
10071 #endif
10072             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10073      &        auxvec(1))
10074             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10075             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10076      &        auxvec(1))
10077             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10078             call transpose2(EUg(1,1,k),auxmat(1,1))
10079             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10080      &        pizda(1,1))
10081             vv(1)=pizda(1,1)-pizda(2,2)
10082             vv(2)=pizda(1,2)+pizda(2,1)
10083             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10084 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10085 #ifdef MOMENT
10086             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10087 #else
10088             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10089 #endif
10090             if (swap) then
10091               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10092             else
10093               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10094             endif
10095           enddo
10096         enddo
10097       enddo
10098       return
10099       end
10100 c----------------------------------------------------------------------------
10101       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10102       implicit real*8 (a-h,o-z)
10103       include 'DIMENSIONS'
10104       include 'COMMON.IOUNITS'
10105       include 'COMMON.CHAIN'
10106       include 'COMMON.DERIV'
10107       include 'COMMON.INTERACT'
10108       include 'COMMON.CONTACTS'
10109       include 'COMMON.TORSION'
10110       include 'COMMON.VAR'
10111       include 'COMMON.GEO'
10112       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10113       logical swap
10114 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10115 C                                                                              C
10116 C      Parallel       Antiparallel                                             C
10117 C                                                                              C
10118 C          o             o                                                     C
10119 C         /l\   /   \   /j\                                                    C
10120 C        /   \ /     \ /   \                                                   C
10121 C       /| o |o       o| o |\                                                  C
10122 C       j|/k\|  /      |/k\|l /                                                C
10123 C        /   \ /       /   \ /                                                 C
10124 C       /     o       /     o                                                  C
10125 C       i             i                                                        C
10126 C                                                                              C
10127 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10128 C
10129 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10130 C           energy moment and not to the cluster cumulant.
10131       iti=itortyp(itype(i))
10132       if (j.lt.nres-1) then
10133         itj1=itortyp(itype(j+1))
10134       else
10135         itj1=ntortyp+1
10136       endif
10137       itk=itortyp(itype(k))
10138       itk1=itortyp(itype(k+1))
10139       if (l.lt.nres-1) then
10140         itl1=itortyp(itype(l+1))
10141       else
10142         itl1=ntortyp+1
10143       endif
10144 #ifdef MOMENT
10145       s1=dip(4,jj,i)*dip(4,kk,k)
10146 #endif
10147       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10148       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10149       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10150       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10151       call transpose2(EE(1,1,itk),auxmat(1,1))
10152       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10153       vv(1)=pizda(1,1)+pizda(2,2)
10154       vv(2)=pizda(2,1)-pizda(1,2)
10155       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10156 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10157 cd     & "sum",-(s2+s3+s4)
10158 #ifdef MOMENT
10159       eello6_graph3=-(s1+s2+s3+s4)
10160 #else
10161       eello6_graph3=-(s2+s3+s4)
10162 #endif
10163 c      eello6_graph3=-s4
10164 C Derivatives in gamma(k-1)
10165       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10166       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10167       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10168       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10169 C Derivatives in gamma(l-1)
10170       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10171       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10172       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10173       vv(1)=pizda(1,1)+pizda(2,2)
10174       vv(2)=pizda(2,1)-pizda(1,2)
10175       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10176       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10177 C Cartesian derivatives.
10178       do iii=1,2
10179         do kkk=1,5
10180           do lll=1,3
10181 #ifdef MOMENT
10182             if (iii.eq.1) then
10183               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10184             else
10185               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10186             endif
10187 #endif
10188             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
10189      &        auxvec(1))
10190             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10191             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
10192      &        auxvec(1))
10193             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10194             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10195      &        pizda(1,1))
10196             vv(1)=pizda(1,1)+pizda(2,2)
10197             vv(2)=pizda(2,1)-pizda(1,2)
10198             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10199 #ifdef MOMENT
10200             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10201 #else
10202             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10203 #endif
10204             if (swap) then
10205               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10206             else
10207               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10208             endif
10209 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10210           enddo
10211         enddo
10212       enddo
10213       return
10214       end
10215 c----------------------------------------------------------------------------
10216       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10217       implicit real*8 (a-h,o-z)
10218       include 'DIMENSIONS'
10219       include 'COMMON.IOUNITS'
10220       include 'COMMON.CHAIN'
10221       include 'COMMON.DERIV'
10222       include 'COMMON.INTERACT'
10223       include 'COMMON.CONTACTS'
10224       include 'COMMON.TORSION'
10225       include 'COMMON.VAR'
10226       include 'COMMON.GEO'
10227       include 'COMMON.FFIELD'
10228       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10229      & auxvec1(2),auxmat1(2,2)
10230       logical swap
10231 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10232 C                                                                              C
10233 C      Parallel       Antiparallel                                             C
10234 C                                                                              C
10235 C          o             o                                                     C
10236 C         /l\   /   \   /j\                                                    C
10237 C        /   \ /     \ /   \                                                   C
10238 C       /| o |o       o| o |\                                                  C
10239 C     \ j|/k\|      \  |/k\|l                                                  C
10240 C      \ /   \       \ /   \                                                   C
10241 C       o     \       o     \                                                  C
10242 C       i             i                                                        C
10243 C                                                                              C
10244 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10245 C
10246 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10247 C           energy moment and not to the cluster cumulant.
10248 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10249       iti=itortyp(itype(i))
10250       itj=itortyp(itype(j))
10251       if (j.lt.nres-1) then
10252         itj1=itortyp(itype(j+1))
10253       else
10254         itj1=ntortyp+1
10255       endif
10256       itk=itortyp(itype(k))
10257       if (k.lt.nres-1) then
10258         itk1=itortyp(itype(k+1))
10259       else
10260         itk1=ntortyp+1
10261       endif
10262       itl=itortyp(itype(l))
10263       if (l.lt.nres-1) then
10264         itl1=itortyp(itype(l+1))
10265       else
10266         itl1=ntortyp+1
10267       endif
10268 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10269 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10270 cd     & ' itl',itl,' itl1',itl1
10271 #ifdef MOMENT
10272       if (imat.eq.1) then
10273         s1=dip(3,jj,i)*dip(3,kk,k)
10274       else
10275         s1=dip(2,jj,j)*dip(2,kk,l)
10276       endif
10277 #endif
10278       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10279       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10280       if (j.eq.l+1) then
10281         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10282         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10283       else
10284         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10285         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10286       endif
10287       call transpose2(EUg(1,1,k),auxmat(1,1))
10288       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10289       vv(1)=pizda(1,1)-pizda(2,2)
10290       vv(2)=pizda(2,1)+pizda(1,2)
10291       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10292 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10293 #ifdef MOMENT
10294       eello6_graph4=-(s1+s2+s3+s4)
10295 #else
10296       eello6_graph4=-(s2+s3+s4)
10297 #endif
10298 C Derivatives in gamma(i-1)
10299       if (i.gt.1) then
10300 #ifdef MOMENT
10301         if (imat.eq.1) then
10302           s1=dipderg(2,jj,i)*dip(3,kk,k)
10303         else
10304           s1=dipderg(4,jj,j)*dip(2,kk,l)
10305         endif
10306 #endif
10307         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10308         if (j.eq.l+1) then
10309           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10310           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10311         else
10312           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10313           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10314         endif
10315         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10316         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10317 cd          write (2,*) 'turn6 derivatives'
10318 #ifdef MOMENT
10319           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10320 #else
10321           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10322 #endif
10323         else
10324 #ifdef MOMENT
10325           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10326 #else
10327           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10328 #endif
10329         endif
10330       endif
10331 C Derivatives in gamma(k-1)
10332 #ifdef MOMENT
10333       if (imat.eq.1) then
10334         s1=dip(3,jj,i)*dipderg(2,kk,k)
10335       else
10336         s1=dip(2,jj,j)*dipderg(4,kk,l)
10337       endif
10338 #endif
10339       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10340       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10341       if (j.eq.l+1) then
10342         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10343         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10344       else
10345         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10346         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10347       endif
10348       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10349       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10350       vv(1)=pizda(1,1)-pizda(2,2)
10351       vv(2)=pizda(2,1)+pizda(1,2)
10352       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10353       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10354 #ifdef MOMENT
10355         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10356 #else
10357         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10358 #endif
10359       else
10360 #ifdef MOMENT
10361         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10362 #else
10363         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10364 #endif
10365       endif
10366 C Derivatives in gamma(j-1) or gamma(l-1)
10367       if (l.eq.j+1 .and. l.gt.1) then
10368         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10369         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10370         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10371         vv(1)=pizda(1,1)-pizda(2,2)
10372         vv(2)=pizda(2,1)+pizda(1,2)
10373         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10374         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10375       else if (j.gt.1) then
10376         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10377         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10378         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10379         vv(1)=pizda(1,1)-pizda(2,2)
10380         vv(2)=pizda(2,1)+pizda(1,2)
10381         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10382         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10383           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10384         else
10385           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10386         endif
10387       endif
10388 C Cartesian derivatives.
10389       do iii=1,2
10390         do kkk=1,5
10391           do lll=1,3
10392 #ifdef MOMENT
10393             if (iii.eq.1) then
10394               if (imat.eq.1) then
10395                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10396               else
10397                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10398               endif
10399             else
10400               if (imat.eq.1) then
10401                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10402               else
10403                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10404               endif
10405             endif
10406 #endif
10407             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10408      &        auxvec(1))
10409             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10410             if (j.eq.l+1) then
10411               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10412      &          b1(1,itj1),auxvec(1))
10413               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10414             else
10415               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10416      &          b1(1,itl1),auxvec(1))
10417               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10418             endif
10419             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10420      &        pizda(1,1))
10421             vv(1)=pizda(1,1)-pizda(2,2)
10422             vv(2)=pizda(2,1)+pizda(1,2)
10423             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10424             if (swap) then
10425               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10426 #ifdef MOMENT
10427                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10428      &             -(s1+s2+s4)
10429 #else
10430                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10431      &             -(s2+s4)
10432 #endif
10433                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10434               else
10435 #ifdef MOMENT
10436                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10437 #else
10438                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10439 #endif
10440                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10441               endif
10442             else
10443 #ifdef MOMENT
10444               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10445 #else
10446               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10447 #endif
10448               if (l.eq.j+1) then
10449                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10450               else
10451                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10452               endif
10453             endif
10454           enddo
10455         enddo
10456       enddo
10457       return
10458       end
10459 c----------------------------------------------------------------------------
10460       double precision function eello_turn6(i,jj,kk)
10461       implicit real*8 (a-h,o-z)
10462       include 'DIMENSIONS'
10463       include 'COMMON.IOUNITS'
10464       include 'COMMON.CHAIN'
10465       include 'COMMON.DERIV'
10466       include 'COMMON.INTERACT'
10467       include 'COMMON.CONTACTS'
10468       include 'COMMON.TORSION'
10469       include 'COMMON.VAR'
10470       include 'COMMON.GEO'
10471       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10472      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10473      &  ggg1(3),ggg2(3)
10474       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10475      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10476 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10477 C           the respective energy moment and not to the cluster cumulant.
10478       s1=0.0d0
10479       s8=0.0d0
10480       s13=0.0d0
10481 c
10482       eello_turn6=0.0d0
10483       j=i+4
10484       k=i+1
10485       l=i+3
10486       iti=itortyp(itype(i))
10487       itk=itortyp(itype(k))
10488       itk1=itortyp(itype(k+1))
10489       itl=itortyp(itype(l))
10490       itj=itortyp(itype(j))
10491 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10492 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10493 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10494 cd        eello6=0.0d0
10495 cd        return
10496 cd      endif
10497 cd      write (iout,*)
10498 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10499 cd     &   ' and',k,l
10500 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10501       do iii=1,2
10502         do kkk=1,5
10503           do lll=1,3
10504             derx_turn(lll,kkk,iii)=0.0d0
10505           enddo
10506         enddo
10507       enddo
10508 cd      eij=1.0d0
10509 cd      ekl=1.0d0
10510 cd      ekont=1.0d0
10511       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10512 cd      eello6_5=0.0d0
10513 cd      write (2,*) 'eello6_5',eello6_5
10514 #ifdef MOMENT
10515       call transpose2(AEA(1,1,1),auxmat(1,1))
10516       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10517       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10518       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10519 #endif
10520       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10521       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10522       s2 = scalar2(b1(1,itk),vtemp1(1))
10523 #ifdef MOMENT
10524       call transpose2(AEA(1,1,2),atemp(1,1))
10525       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10526       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10527       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10528 #endif
10529       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10530       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10531       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10532 #ifdef MOMENT
10533       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10534       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10535       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10536       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10537       ss13 = scalar2(b1(1,itk),vtemp4(1))
10538       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10539 #endif
10540 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10541 c      s1=0.0d0
10542 c      s2=0.0d0
10543 c      s8=0.0d0
10544 c      s12=0.0d0
10545 c      s13=0.0d0
10546       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10547 C Derivatives in gamma(i+2)
10548       s1d =0.0d0
10549       s8d =0.0d0
10550 #ifdef MOMENT
10551       call transpose2(AEA(1,1,1),auxmatd(1,1))
10552       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10553       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10554       call transpose2(AEAderg(1,1,2),atempd(1,1))
10555       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10556       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10557 #endif
10558       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10559       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10560       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10561 c      s1d=0.0d0
10562 c      s2d=0.0d0
10563 c      s8d=0.0d0
10564 c      s12d=0.0d0
10565 c      s13d=0.0d0
10566       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10567 C Derivatives in gamma(i+3)
10568 #ifdef MOMENT
10569       call transpose2(AEA(1,1,1),auxmatd(1,1))
10570       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10571       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10572       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10573 #endif
10574       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10575       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10576       s2d = scalar2(b1(1,itk),vtemp1d(1))
10577 #ifdef MOMENT
10578       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10579       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10580 #endif
10581       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10582 #ifdef MOMENT
10583       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10584       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10585       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10586 #endif
10587 c      s1d=0.0d0
10588 c      s2d=0.0d0
10589 c      s8d=0.0d0
10590 c      s12d=0.0d0
10591 c      s13d=0.0d0
10592 #ifdef MOMENT
10593       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10594      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10595 #else
10596       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10597      &               -0.5d0*ekont*(s2d+s12d)
10598 #endif
10599 C Derivatives in gamma(i+4)
10600       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10601       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10602       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10603 #ifdef MOMENT
10604       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10605       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10606       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10607 #endif
10608 c      s1d=0.0d0
10609 c      s2d=0.0d0
10610 c      s8d=0.0d0
10611 C      s12d=0.0d0
10612 c      s13d=0.0d0
10613 #ifdef MOMENT
10614       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10615 #else
10616       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10617 #endif
10618 C Derivatives in gamma(i+5)
10619 #ifdef MOMENT
10620       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10621       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10622       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10623 #endif
10624       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10625       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10626       s2d = scalar2(b1(1,itk),vtemp1d(1))
10627 #ifdef MOMENT
10628       call transpose2(AEA(1,1,2),atempd(1,1))
10629       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10630       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10631 #endif
10632       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10633       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10634 #ifdef MOMENT
10635       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10636       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10637       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10638 #endif
10639 c      s1d=0.0d0
10640 c      s2d=0.0d0
10641 c      s8d=0.0d0
10642 c      s12d=0.0d0
10643 c      s13d=0.0d0
10644 #ifdef MOMENT
10645       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10646      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10647 #else
10648       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10649      &               -0.5d0*ekont*(s2d+s12d)
10650 #endif
10651 C Cartesian derivatives
10652       do iii=1,2
10653         do kkk=1,5
10654           do lll=1,3
10655 #ifdef MOMENT
10656             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10657             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10658             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10659 #endif
10660             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10661             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10662      &          vtemp1d(1))
10663             s2d = scalar2(b1(1,itk),vtemp1d(1))
10664 #ifdef MOMENT
10665             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10666             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10667             s8d = -(atempd(1,1)+atempd(2,2))*
10668      &           scalar2(cc(1,1,itl),vtemp2(1))
10669 #endif
10670             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10671      &           auxmatd(1,1))
10672             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10673             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10674 c      s1d=0.0d0
10675 c      s2d=0.0d0
10676 c      s8d=0.0d0
10677 c      s12d=0.0d0
10678 c      s13d=0.0d0
10679 #ifdef MOMENT
10680             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10681      &        - 0.5d0*(s1d+s2d)
10682 #else
10683             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10684      &        - 0.5d0*s2d
10685 #endif
10686 #ifdef MOMENT
10687             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10688      &        - 0.5d0*(s8d+s12d)
10689 #else
10690             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10691      &        - 0.5d0*s12d
10692 #endif
10693           enddo
10694         enddo
10695       enddo
10696 #ifdef MOMENT
10697       do kkk=1,5
10698         do lll=1,3
10699           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10700      &      achuj_tempd(1,1))
10701           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10702           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10703           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10704           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10705           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10706      &      vtemp4d(1))
10707           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10708           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10709           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10710         enddo
10711       enddo
10712 #endif
10713 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10714 cd     &  16*eel_turn6_num
10715 cd      goto 1112
10716       if (j.lt.nres-1) then
10717         j1=j+1
10718         j2=j-1
10719       else
10720         j1=j-1
10721         j2=j-2
10722       endif
10723       if (l.lt.nres-1) then
10724         l1=l+1
10725         l2=l-1
10726       else
10727         l1=l-1
10728         l2=l-2
10729       endif
10730       do ll=1,3
10731 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10732 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10733 cgrad        ghalf=0.5d0*ggg1(ll)
10734 cd        ghalf=0.0d0
10735         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10736         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10737         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10738      &    +ekont*derx_turn(ll,2,1)
10739         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10740         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10741      &    +ekont*derx_turn(ll,4,1)
10742         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10743         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10744         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10745 cgrad        ghalf=0.5d0*ggg2(ll)
10746 cd        ghalf=0.0d0
10747         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10748      &    +ekont*derx_turn(ll,2,2)
10749         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10750         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10751      &    +ekont*derx_turn(ll,4,2)
10752         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10753         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10754         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10755       enddo
10756 cd      goto 1112
10757 cgrad      do m=i+1,j-1
10758 cgrad        do ll=1,3
10759 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10760 cgrad        enddo
10761 cgrad      enddo
10762 cgrad      do m=k+1,l-1
10763 cgrad        do ll=1,3
10764 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10765 cgrad        enddo
10766 cgrad      enddo
10767 cgrad1112  continue
10768 cgrad      do m=i+2,j2
10769 cgrad        do ll=1,3
10770 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10771 cgrad        enddo
10772 cgrad      enddo
10773 cgrad      do m=k+2,l2
10774 cgrad        do ll=1,3
10775 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10776 cgrad        enddo
10777 cgrad      enddo
10778 cd      do iii=1,nres-3
10779 cd        write (2,*) iii,g_corr6_loc(iii)
10780 cd      enddo
10781       eello_turn6=ekont*eel_turn6
10782 cd      write (2,*) 'ekont',ekont
10783 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10784       return
10785       end
10786
10787 C-----------------------------------------------------------------------------
10788       double precision function scalar(u,v)
10789 !DIR$ INLINEALWAYS scalar
10790 #ifndef OSF
10791 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10792 #endif
10793       implicit none
10794       double precision u(3),v(3)
10795 cd      double precision sc
10796 cd      integer i
10797 cd      sc=0.0d0
10798 cd      do i=1,3
10799 cd        sc=sc+u(i)*v(i)
10800 cd      enddo
10801 cd      scalar=sc
10802
10803       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10804       return
10805       end
10806 crc-------------------------------------------------
10807       SUBROUTINE MATVEC2(A1,V1,V2)
10808 !DIR$ INLINEALWAYS MATVEC2
10809 #ifndef OSF
10810 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10811 #endif
10812       implicit real*8 (a-h,o-z)
10813       include 'DIMENSIONS'
10814       DIMENSION A1(2,2),V1(2),V2(2)
10815 c      DO 1 I=1,2
10816 c        VI=0.0
10817 c        DO 3 K=1,2
10818 c    3     VI=VI+A1(I,K)*V1(K)
10819 c        Vaux(I)=VI
10820 c    1 CONTINUE
10821
10822       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10823       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10824
10825       v2(1)=vaux1
10826       v2(2)=vaux2
10827       END
10828 C---------------------------------------
10829       SUBROUTINE MATMAT2(A1,A2,A3)
10830 #ifndef OSF
10831 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10832 #endif
10833       implicit real*8 (a-h,o-z)
10834       include 'DIMENSIONS'
10835       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10836 c      DIMENSION AI3(2,2)
10837 c        DO  J=1,2
10838 c          A3IJ=0.0
10839 c          DO K=1,2
10840 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10841 c          enddo
10842 c          A3(I,J)=A3IJ
10843 c       enddo
10844 c      enddo
10845
10846       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10847       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10848       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10849       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10850
10851       A3(1,1)=AI3_11
10852       A3(2,1)=AI3_21
10853       A3(1,2)=AI3_12
10854       A3(2,2)=AI3_22
10855       END
10856
10857 c-------------------------------------------------------------------------
10858       double precision function scalar2(u,v)
10859 !DIR$ INLINEALWAYS scalar2
10860       implicit none
10861       double precision u(2),v(2)
10862       double precision sc
10863       integer i
10864       scalar2=u(1)*v(1)+u(2)*v(2)
10865       return
10866       end
10867
10868 C-----------------------------------------------------------------------------
10869
10870       subroutine transpose2(a,at)
10871 !DIR$ INLINEALWAYS transpose2
10872 #ifndef OSF
10873 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10874 #endif
10875       implicit none
10876       double precision a(2,2),at(2,2)
10877       at(1,1)=a(1,1)
10878       at(1,2)=a(2,1)
10879       at(2,1)=a(1,2)
10880       at(2,2)=a(2,2)
10881       return
10882       end
10883 c--------------------------------------------------------------------------
10884       subroutine transpose(n,a,at)
10885       implicit none
10886       integer n,i,j
10887       double precision a(n,n),at(n,n)
10888       do i=1,n
10889         do j=1,n
10890           at(j,i)=a(i,j)
10891         enddo
10892       enddo
10893       return
10894       end
10895 C---------------------------------------------------------------------------
10896       subroutine prodmat3(a1,a2,kk,transp,prod)
10897 !DIR$ INLINEALWAYS prodmat3
10898 #ifndef OSF
10899 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10900 #endif
10901       implicit none
10902       integer i,j
10903       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10904       logical transp
10905 crc      double precision auxmat(2,2),prod_(2,2)
10906
10907       if (transp) then
10908 crc        call transpose2(kk(1,1),auxmat(1,1))
10909 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10910 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10911
10912            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10913      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10914            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10915      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10916            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10917      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10918            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10919      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10920
10921       else
10922 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10923 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10924
10925            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10926      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10927            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10928      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10929            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10930      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10931            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10932      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10933
10934       endif
10935 c      call transpose2(a2(1,1),a2t(1,1))
10936
10937 crc      print *,transp
10938 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10939 crc      print *,((prod(i,j),i=1,2),j=1,2)
10940
10941       return
10942       end
10943