source/unres/src_MD-NEWSC-NEWC/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 NEWCORR
4213       do i=3,nres+1
4214         if (i.gt. nnt+2 .and. i.lt.nct+2) then
4215           iti = itortyp(itype(i-2))
4216         else
4217           iti=ntortyp+1
4218         endif
4219         if (i.gt. nnt+1 .and. i.lt.nct+1) then
4220           iti1 = itortyp(itype(i-1))
4221         else
4222           iti1=ntortyp+1
4223         endif
4224         b1(1,i-2)=bnew1(1,1,iti)*sin(theta(i-1)/2.0)
4225      &           +bnew1(2,1,iti)*sin(theta(i-1))
4226      &           +bnew1(3,1,iti)*cos(theta(i-1)/2.0)
4227         b2(1,i-2)=bnew2(1,1,iti)*sin(theta(i-1)/2.0)
4228      &           +bnew2(2,1,iti)*sin(theta(i-1))
4229      &           +bnew2(3,1,iti)*cos(theta(i-1)/2.0)
4230         b1(2,i-2)=bnew1(1,2,iti)
4231         b2(2,i-2)=bnew2(1,2,iti)
4232 #ifdef DEBUG
4233         write (iout,*) "i",i," iti",iti," theta",theta(i-1)
4234         write (iout,*) "bnew1",bnew1(1,1,iti),bnew1(2,1,iti),
4235      &                  bnew1(3,1,iti),bnew1(1,2,iti)
4236         write (iout,*) "bnew2",bnew2(1,1,iti),bnew2(2,1,iti),
4237      &                  bnew2(3,1,iti),bnew2(1,2,iti)
4238 #endif
4239         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
4240         EE(1,2,i-2)=eeold(1,2,iti)
4241         EE(2,1,i-2)=eeold(2,1,iti)
4242         EE(2,2,i-2)=eeold(2,2,iti)
4243         b1tilde(1,i-2)=b1(1,i-2)
4244         b1tilde(2,i-2)=-b1(2,i-2)
4245       enddo
4246 #endif
4247
4248 #ifdef PARMAT
4249       do i=ivec_start+2,ivec_end+2
4250 #else
4251       do i=3,nres+1
4252 #endif
4253         if (i .lt. nres+1) then
4254           sin1=dsin(phi(i))
4255           cos1=dcos(phi(i))
4256           sintab(i-2)=sin1
4257           costab(i-2)=cos1
4258           obrot(1,i-2)=cos1
4259           obrot(2,i-2)=sin1
4260           sin2=dsin(2*phi(i))
4261           cos2=dcos(2*phi(i))
4262           sintab2(i-2)=sin2
4263           costab2(i-2)=cos2
4264           obrot2(1,i-2)=cos2
4265           obrot2(2,i-2)=sin2
4266           Ug(1,1,i-2)=-cos1
4267           Ug(1,2,i-2)=-sin1
4268           Ug(2,1,i-2)=-sin1
4269           Ug(2,2,i-2)= cos1
4270           Ug2(1,1,i-2)=-cos2
4271           Ug2(1,2,i-2)=-sin2
4272           Ug2(2,1,i-2)=-sin2
4273           Ug2(2,2,i-2)= cos2
4274         else
4275           costab(i-2)=1.0d0
4276           sintab(i-2)=0.0d0
4277           obrot(1,i-2)=1.0d0
4278           obrot(2,i-2)=0.0d0
4279           obrot2(1,i-2)=0.0d0
4280           obrot2(2,i-2)=0.0d0
4281           Ug(1,1,i-2)=1.0d0
4282           Ug(1,2,i-2)=0.0d0
4283           Ug(2,1,i-2)=0.0d0
4284           Ug(2,2,i-2)=1.0d0
4285           Ug2(1,1,i-2)=0.0d0
4286           Ug2(1,2,i-2)=0.0d0
4287           Ug2(2,1,i-2)=0.0d0
4288           Ug2(2,2,i-2)=0.0d0
4289         endif
4290         if (i .gt. 3 .and. i .lt. nres+1) then
4291           obrot_der(1,i-2)=-sin1
4292           obrot_der(2,i-2)= cos1
4293           Ugder(1,1,i-2)= sin1
4294           Ugder(1,2,i-2)=-cos1
4295           Ugder(2,1,i-2)=-cos1
4296           Ugder(2,2,i-2)=-sin1
4297           dwacos2=cos2+cos2
4298           dwasin2=sin2+sin2
4299           obrot2_der(1,i-2)=-dwasin2
4300           obrot2_der(2,i-2)= dwacos2
4301           Ug2der(1,1,i-2)= dwasin2
4302           Ug2der(1,2,i-2)=-dwacos2
4303           Ug2der(2,1,i-2)=-dwacos2
4304           Ug2der(2,2,i-2)=-dwasin2
4305         else
4306           obrot_der(1,i-2)=0.0d0
4307           obrot_der(2,i-2)=0.0d0
4308           Ugder(1,1,i-2)=0.0d0
4309           Ugder(1,2,i-2)=0.0d0
4310           Ugder(2,1,i-2)=0.0d0
4311           Ugder(2,2,i-2)=0.0d0
4312           obrot2_der(1,i-2)=0.0d0
4313           obrot2_der(2,i-2)=0.0d0
4314           Ug2der(1,1,i-2)=0.0d0
4315           Ug2der(1,2,i-2)=0.0d0
4316           Ug2der(2,1,i-2)=0.0d0
4317           Ug2der(2,2,i-2)=0.0d0
4318         endif
4319 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
4320         if (i.gt. nnt+2 .and. i.lt.nct+2) then
4321           iti = itortyp(itype(i-2))
4322         else
4323           iti=ntortyp+1
4324         endif
4325 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
4326         if (i.gt. nnt+1 .and. i.lt.nct+1) then
4327           iti1 = itortyp(itype(i-1))
4328         else
4329           iti1=ntortyp+1
4330         endif
4331 cd        write (iout,*) '*******i',i,' iti1',iti
4332 cd        write (iout,*) 'b1',b1(:,i-2)
4333 cd        write (iout,*) 'b2',b2(:,i-2)
4334 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
4335 c        if (i .gt. iatel_s+2) then
4336         if (i .gt. nnt+2) then
4337           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
4338           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
4339           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
4340      &    then
4341           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
4342           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
4343           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
4344           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
4345           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
4346           endif
4347         else
4348           do k=1,2
4349             Ub2(k,i-2)=0.0d0
4350             Ctobr(k,i-2)=0.0d0
4351             Dtobr2(k,i-2)=0.0d0
4352             do l=1,2
4353               EUg(l,k,i-2)=0.0d0
4354               CUg(l,k,i-2)=0.0d0
4355               DUg(l,k,i-2)=0.0d0
4356               DtUg2(l,k,i-2)=0.0d0
4357             enddo
4358           enddo
4359         endif
4360         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
4361         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
4362         do k=1,2
4363           muder(k,i-2)=Ub2der(k,i-2)
4364         enddo
4365 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
4366         if (i.gt. nnt+1 .and. i.lt.nct+1) then
4367           iti1 = itortyp(itype(i-1))
4368         else
4369           iti1=ntortyp+1
4370         endif
4371         do k=1,2
4372           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
4373         enddo
4374 cd        write (iout,*) 'mu ',mu(:,i-2)
4375 cd        write (iout,*) 'mu1',mu1(:,i-2)
4376 cd        write (iout,*) 'mu2',mu2(:,i-2)
4377         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
4378      &  then
4379         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
4380         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
4381         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
4382         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
4383         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
4384 C Vectors and matrices dependent on a single virtual-bond dihedral.
4385         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
4386         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
4387         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
4388         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
4389         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
4390         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
4391         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
4392         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
4393         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
4394         endif
4395       enddo
4396 C Matrices dependent on two consecutive virtual-bond dihedrals.
4397 C The order of matrices is from left to right.
4398       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
4399      &then
4400 c      do i=max0(ivec_start,2),ivec_end
4401       do i=2,nres-1
4402         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
4403         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
4404         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
4405         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
4406         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
4407         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
4408         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
4409         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
4410       enddo
4411       endif
4412 #if defined(MPI) && defined(PARMAT)
4413 #ifdef DEBUG
4414 c      if (fg_rank.eq.0) then
4415         write (iout,*) "Arrays UG and UGDER before GATHER"
4416         do i=1,nres-1
4417           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4418      &     ((ug(l,k,i),l=1,2),k=1,2),
4419      &     ((ugder(l,k,i),l=1,2),k=1,2)
4420         enddo
4421         write (iout,*) "Arrays UG2 and UG2DER"
4422         do i=1,nres-1
4423           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4424      &     ((ug2(l,k,i),l=1,2),k=1,2),
4425      &     ((ug2der(l,k,i),l=1,2),k=1,2)
4426         enddo
4427         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
4428         do i=1,nres-1
4429           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4430      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
4431      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
4432         enddo
4433         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
4434         do i=1,nres-1
4435           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4436      &     costab(i),sintab(i),costab2(i),sintab2(i)
4437         enddo
4438         write (iout,*) "Array MUDER"
4439         do i=1,nres-1
4440           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
4441         enddo
4442 c      endif
4443 #endif
4444       if (nfgtasks.gt.1) then
4445         time00=MPI_Wtime()
4446 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
4447 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
4448 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
4449 #ifdef MATGATHER
4450         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
4451      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4452      &   FG_COMM1,IERR)
4453         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
4454      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4455      &   FG_COMM1,IERR)
4456         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
4457      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4458      &   FG_COMM1,IERR)
4459         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
4460      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4461      &   FG_COMM1,IERR)
4462         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
4463      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4464      &   FG_COMM1,IERR)
4465         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
4466      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4467      &   FG_COMM1,IERR)
4468         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
4469      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
4470      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
4471         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
4472      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
4473      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
4474         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
4475      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
4476      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
4477         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
4478      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
4479      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
4480         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
4481      &  then
4482         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
4483      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4484      &   FG_COMM1,IERR)
4485         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
4486      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4487      &   FG_COMM1,IERR)
4488         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
4489      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4490      &   FG_COMM1,IERR)
4491        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
4492      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4493      &   FG_COMM1,IERR)
4494         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
4495      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4496      &   FG_COMM1,IERR)
4497         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
4498      &   ivec_count(fg_rank1),
4499      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4500      &   FG_COMM1,IERR)
4501         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
4502      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4503      &   FG_COMM1,IERR)
4504         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
4505      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
4506      &   FG_COMM1,IERR)
4507         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
4508      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4509      &   FG_COMM1,IERR)
4510         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
4511      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4512      &   FG_COMM1,IERR)
4513         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
4514      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4515      &   FG_COMM1,IERR)
4516         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
4517      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4518      &   FG_COMM1,IERR)
4519         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
4520      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4521      &   FG_COMM1,IERR)
4522         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
4523      &   ivec_count(fg_rank1),
4524      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4525      &   FG_COMM1,IERR)
4526         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
4527      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4528      &   FG_COMM1,IERR)
4529        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
4530      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4531      &   FG_COMM1,IERR)
4532         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
4533      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4534      &   FG_COMM1,IERR)
4535        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
4536      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4537      &   FG_COMM1,IERR)
4538         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
4539      &   ivec_count(fg_rank1),
4540      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4541      &   FG_COMM1,IERR)
4542         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
4543      &   ivec_count(fg_rank1),
4544      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
4545      &   FG_COMM1,IERR)
4546         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
4547      &   ivec_count(fg_rank1),
4548      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
4549      &   MPI_MAT2,FG_COMM1,IERR)
4550         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
4551      &   ivec_count(fg_rank1),
4552      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
4553      &   MPI_MAT2,FG_COMM1,IERR)
4554         endif
4555 #else
4556 c Passes matrix info through the ring
4557       isend=fg_rank1
4558       irecv=fg_rank1-1
4559       if (irecv.lt.0) irecv=nfgtasks1-1
4560       iprev=irecv
4561       inext=fg_rank1+1
4562       if (inext.ge.nfgtasks1) inext=0
4563       do i=1,nfgtasks1-1
4564 c        write (iout,*) "isend",isend," irecv",irecv
4565 c        call flush(iout)
4566         lensend=lentyp(isend)
4567         lenrecv=lentyp(irecv)
4568 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
4569 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
4570 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
4571 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
4572 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
4573 c        write (iout,*) "Gather ROTAT1"
4574 c        call flush(iout)
4575 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
4576 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
4577 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
4578 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
4579 c        write (iout,*) "Gather ROTAT2"
4580 c        call flush(iout)
4581         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
4582      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
4583      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
4584      &   iprev,4400+irecv,FG_COMM,status,IERR)
4585 c        write (iout,*) "Gather ROTAT_OLD"
4586 c        call flush(iout)
4587         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
4588      &   MPI_PRECOMP11(lensend),inext,5500+isend,
4589      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
4590      &   iprev,5500+irecv,FG_COMM,status,IERR)
4591 c        write (iout,*) "Gather PRECOMP11"
4592 c        call flush(iout)
4593         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
4594      &   MPI_PRECOMP12(lensend),inext,6600+isend,
4595      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
4596      &   iprev,6600+irecv,FG_COMM,status,IERR)
4597 c        write (iout,*) "Gather PRECOMP12"
4598 c        call flush(iout)
4599         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
4600      &  then
4601         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
4602      &   MPI_ROTAT2(lensend),inext,7700+isend,
4603      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
4604      &   iprev,7700+irecv,FG_COMM,status,IERR)
4605 c        write (iout,*) "Gather PRECOMP21"
4606 c        call flush(iout)
4607         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
4608      &   MPI_PRECOMP22(lensend),inext,8800+isend,
4609      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
4610      &   iprev,8800+irecv,FG_COMM,status,IERR)
4611 c        write (iout,*) "Gather PRECOMP22"
4612 c        call flush(iout)
4613         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
4614      &   MPI_PRECOMP23(lensend),inext,9900+isend,
4615      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
4616      &   MPI_PRECOMP23(lenrecv),
4617      &   iprev,9900+irecv,FG_COMM,status,IERR)
4618 c        write (iout,*) "Gather PRECOMP23"
4619 c        call flush(iout)
4620         endif
4621         isend=irecv
4622         irecv=irecv-1
4623         if (irecv.lt.0) irecv=nfgtasks1-1
4624       enddo
4625 #endif
4626         time_gather=time_gather+MPI_Wtime()-time00
4627       endif
4628 #ifdef DEBUG
4629 c      if (fg_rank.eq.0) then
4630         write (iout,*) "Arrays UG and UGDER"
4631         do i=1,nres-1
4632           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4633      &     ((ug(l,k,i),l=1,2),k=1,2),
4634      &     ((ugder(l,k,i),l=1,2),k=1,2)
4635         enddo
4636         write (iout,*) "Arrays UG2 and UG2DER"
4637         do i=1,nres-1
4638           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4639      &     ((ug2(l,k,i),l=1,2),k=1,2),
4640      &     ((ug2der(l,k,i),l=1,2),k=1,2)
4641         enddo
4642         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
4643         do i=1,nres-1
4644           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4645      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
4646      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
4647         enddo
4648         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
4649         do i=1,nres-1
4650           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
4651      &     costab(i),sintab(i),costab2(i),sintab2(i)
4652         enddo
4653         write (iout,*) "Array MUDER"
4654         do i=1,nres-1
4655           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
4656         enddo
4657 c      endif
4658 #endif
4659 #endif
4660 cd      do i=1,nres
4661 cd        iti = itortyp(itype(i))
4662 cd        write (iout,*) i
4663 cd        do j=1,2
4664 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
4665 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
4666 cd        enddo
4667 cd      enddo
4668       return
4669       end
4670 C--------------------------------------------------------------------------
4671       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
4672 C
4673 C This subroutine calculates the average interaction energy and its gradient
4674 C in the virtual-bond vectors between non-adjacent peptide groups, based on
4675 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
4676 C The potential depends both on the distance of peptide-group centers and on
4677 C the orientation of the CA-CA virtual bonds.
4678 C
4679       implicit real*8 (a-h,o-z)
4680 #ifdef MPI
4681       include 'mpif.h'
4682 #endif
4683       include 'DIMENSIONS'
4684       include 'COMMON.CONTROL'
4685       include 'COMMON.SETUP'
4686       include 'COMMON.IOUNITS'
4687       include 'COMMON.GEO'
4688       include 'COMMON.VAR'
4689       include 'COMMON.LOCAL'
4690       include 'COMMON.CHAIN'
4691       include 'COMMON.DERIV'
4692       include 'COMMON.INTERACT'
4693       include 'COMMON.CONTACTS'
4694       include 'COMMON.TORSION'
4695       include 'COMMON.VECTORS'
4696       include 'COMMON.FFIELD'
4697       include 'COMMON.TIME1'
4698       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
4699      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
4700       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
4701      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
4702       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4703      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4704      &    num_conti,j1,j2
4705 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
4706 #ifdef MOMENT
4707       double precision scal_el /1.0d0/
4708 #else
4709       double precision scal_el /0.5d0/
4710 #endif
4711 C 12/13/98
4712 C 13-go grudnia roku pamietnego...
4713       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4714      &                   0.0d0,1.0d0,0.0d0,
4715      &                   0.0d0,0.0d0,1.0d0/
4716 cd      write(iout,*) 'In EELEC'
4717 cd      do i=1,nloctyp
4718 cd        write(iout,*) 'Type',i
4719 cd        write(iout,*) 'B1',B1(:,i)
4720 cd        write(iout,*) 'B2',B2(:,i)
4721 cd        write(iout,*) 'CC',CC(:,:,i)
4722 cd        write(iout,*) 'DD',DD(:,:,i)
4723 cd        write(iout,*) 'EE',EE(:,:,i)
4724 cd      enddo
4725 cd      call check_vecgrad
4726 cd      stop
4727       if (icheckgrad.eq.1) then
4728         do i=1,nres-1
4729           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
4730           do k=1,3
4731             dc_norm(k,i)=dc(k,i)*fac
4732           enddo
4733 c          write (iout,*) 'i',i,' fac',fac
4734         enddo
4735       endif
4736       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4737      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
4738      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
4739 c        call vec_and_deriv
4740 #ifdef TIMING
4741         time01=MPI_Wtime()
4742 #endif
4743         call set_matrices
4744 #ifdef TIMING
4745         time_mat=time_mat+MPI_Wtime()-time01
4746 #endif
4747       endif
4748 cd      do i=1,nres-1
4749 cd        write (iout,*) 'i=',i
4750 cd        do k=1,3
4751 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
4752 cd        enddo
4753 cd        do k=1,3
4754 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
4755 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
4756 cd        enddo
4757 cd      enddo
4758       t_eelecij=0.0d0
4759       ees=0.0D0
4760       evdw1=0.0D0
4761       eel_loc=0.0d0
4762       eello_turn3=0.0d0
4763       eello_turn4=0.0d0
4764       ind=0
4765       do i=1,nres
4766         num_cont_hb(i)=0
4767       enddo
4768 cd      print '(a)','Enter EELEC'
4769 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
4770       do i=1,nres
4771         gel_loc_loc(i)=0.0d0
4772         gcorr_loc(i)=0.0d0
4773       enddo
4774 c
4775 c
4776 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
4777 C
4778 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
4779 C
4780       do i=iturn3_start,iturn3_end
4781         dxi=dc(1,i)
4782         dyi=dc(2,i)
4783         dzi=dc(3,i)
4784         dx_normi=dc_norm(1,i)
4785         dy_normi=dc_norm(2,i)
4786         dz_normi=dc_norm(3,i)
4787         xmedi=c(1,i)+0.5d0*dxi
4788         ymedi=c(2,i)+0.5d0*dyi
4789         zmedi=c(3,i)+0.5d0*dzi
4790         num_conti=0
4791         call eelecij(i,i+2,ees,evdw1,eel_loc)
4792         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
4793         num_cont_hb(i)=num_conti
4794       enddo
4795       do i=iturn4_start,iturn4_end
4796         dxi=dc(1,i)
4797         dyi=dc(2,i)
4798         dzi=dc(3,i)
4799         dx_normi=dc_norm(1,i)
4800         dy_normi=dc_norm(2,i)
4801         dz_normi=dc_norm(3,i)
4802         xmedi=c(1,i)+0.5d0*dxi
4803         ymedi=c(2,i)+0.5d0*dyi
4804         zmedi=c(3,i)+0.5d0*dzi
4805         num_conti=num_cont_hb(i)
4806         call eelecij(i,i+3,ees,evdw1,eel_loc)
4807         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
4808         num_cont_hb(i)=num_conti
4809       enddo   ! i
4810 c
4811 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
4812 c
4813       do i=iatel_s,iatel_e
4814         dxi=dc(1,i)
4815         dyi=dc(2,i)
4816         dzi=dc(3,i)
4817         dx_normi=dc_norm(1,i)
4818         dy_normi=dc_norm(2,i)
4819         dz_normi=dc_norm(3,i)
4820         xmedi=c(1,i)+0.5d0*dxi
4821         ymedi=c(2,i)+0.5d0*dyi
4822         zmedi=c(3,i)+0.5d0*dzi
4823 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
4824         num_conti=num_cont_hb(i)
4825         do j=ielstart(i),ielend(i)
4826           call eelecij(i,j,ees,evdw1,eel_loc)
4827         enddo ! j
4828         num_cont_hb(i)=num_conti
4829       enddo   ! i
4830 c      write (iout,*) "Number of loop steps in EELEC:",ind
4831 cd      do i=1,nres
4832 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
4833 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
4834 cd      enddo
4835 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
4836 ccc      eel_loc=eel_loc+eello_turn3
4837 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
4838       return
4839       end
4840 C-------------------------------------------------------------------------------
4841       subroutine eelecij(i,j,ees,evdw1,eel_loc)
4842       implicit real*8 (a-h,o-z)
4843       include 'DIMENSIONS'
4844 #ifdef MPI
4845       include "mpif.h"
4846 #endif
4847       include 'COMMON.CONTROL'
4848       include 'COMMON.IOUNITS'
4849       include 'COMMON.GEO'
4850       include 'COMMON.VAR'
4851       include 'COMMON.LOCAL'
4852       include 'COMMON.CHAIN'
4853       include 'COMMON.DERIV'
4854       include 'COMMON.INTERACT'
4855       include 'COMMON.CONTACTS'
4856       include 'COMMON.TORSION'
4857       include 'COMMON.VECTORS'
4858       include 'COMMON.FFIELD'
4859       include 'COMMON.TIME1'
4860       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
4861      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
4862       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
4863      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
4864       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4865      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4866      &    num_conti,j1,j2
4867 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
4868 #ifdef MOMENT
4869       double precision scal_el /1.0d0/
4870 #else
4871       double precision scal_el /0.5d0/
4872 #endif
4873 C 12/13/98
4874 C 13-go grudnia roku pamietnego...
4875       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
4876      &                   0.0d0,1.0d0,0.0d0,
4877      &                   0.0d0,0.0d0,1.0d0/
4878 c          time00=MPI_Wtime()
4879 cd      write (iout,*) "eelecij",i,j
4880 c          ind=ind+1
4881           iteli=itel(i)
4882           itelj=itel(j)
4883           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
4884           aaa=app(iteli,itelj)
4885           bbb=bpp(iteli,itelj)
4886           ael6i=ael6(iteli,itelj)
4887           ael3i=ael3(iteli,itelj)
4888           dxj=dc(1,j)
4889           dyj=dc(2,j)
4890           dzj=dc(3,j)
4891           dx_normj=dc_norm(1,j)
4892           dy_normj=dc_norm(2,j)
4893           dz_normj=dc_norm(3,j)
4894           xj=c(1,j)+0.5D0*dxj-xmedi
4895           yj=c(2,j)+0.5D0*dyj-ymedi
4896           zj=c(3,j)+0.5D0*dzj-zmedi
4897           rij=xj*xj+yj*yj+zj*zj
4898           rrmij=1.0D0/rij
4899           rij=dsqrt(rij)
4900           rmij=1.0D0/rij
4901           r3ij=rrmij*rmij
4902           r6ij=r3ij*r3ij
4903           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4904           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4905           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4906           fac=cosa-3.0D0*cosb*cosg
4907           ev1=aaa*r6ij*r6ij
4908 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4909           if (j.eq.i+2) ev1=scal_el*ev1
4910           ev2=bbb*r6ij
4911           fac3=ael6i*r6ij
4912           fac4=ael3i*r3ij
4913           evdwij=ev1+ev2
4914           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4915           el2=fac4*fac
4916           eesij=el1+el2
4917 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4918           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4919           ees=ees+eesij
4920           evdw1=evdw1+evdwij
4921 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4922 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4923 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4924 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4925
4926           if (energy_dec) then
4927               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
4928               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
4929           endif
4930
4931 C
4932 C Calculate contributions to the Cartesian gradient.
4933 C
4934 #ifdef SPLITELE
4935           facvdw=-6*rrmij*(ev1+evdwij)
4936           facel=-3*rrmij*(el1+eesij)
4937           fac1=fac
4938           erij(1)=xj*rmij
4939           erij(2)=yj*rmij
4940           erij(3)=zj*rmij
4941 *
4942 * Radial derivatives. First process both termini of the fragment (i,j)
4943 *
4944           ggg(1)=facel*xj
4945           ggg(2)=facel*yj
4946           ggg(3)=facel*zj
4947 c          do k=1,3
4948 c            ghalf=0.5D0*ggg(k)
4949 c            gelc(k,i)=gelc(k,i)+ghalf
4950 c            gelc(k,j)=gelc(k,j)+ghalf
4951 c          enddo
4952 c 9/28/08 AL Gradient compotents will be summed only at the end
4953           do k=1,3
4954             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4955             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4956           enddo
4957 *
4958 * Loop over residues i+1 thru j-1.
4959 *
4960 cgrad          do k=i+1,j-1
4961 cgrad            do l=1,3
4962 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4963 cgrad            enddo
4964 cgrad          enddo
4965           ggg(1)=facvdw*xj
4966           ggg(2)=facvdw*yj
4967           ggg(3)=facvdw*zj
4968 c          do k=1,3
4969 c            ghalf=0.5D0*ggg(k)
4970 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4971 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4972 c          enddo
4973 c 9/28/08 AL Gradient compotents will be summed only at the end
4974           do k=1,3
4975             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4976             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4977           enddo
4978 *
4979 * Loop over residues i+1 thru j-1.
4980 *
4981 cgrad          do k=i+1,j-1
4982 cgrad            do l=1,3
4983 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4984 cgrad            enddo
4985 cgrad          enddo
4986 #else
4987           facvdw=ev1+evdwij
4988           facel=el1+eesij
4989           fac1=fac
4990           fac=-3*rrmij*(facvdw+facvdw+facel)
4991           erij(1)=xj*rmij
4992           erij(2)=yj*rmij
4993           erij(3)=zj*rmij
4994 *
4995 * Radial derivatives. First process both termini of the fragment (i,j)
4996 *
4997           ggg(1)=fac*xj
4998           ggg(2)=fac*yj
4999           ggg(3)=fac*zj
5000 c          do k=1,3
5001 c            ghalf=0.5D0*ggg(k)
5002 c            gelc(k,i)=gelc(k,i)+ghalf
5003 c            gelc(k,j)=gelc(k,j)+ghalf
5004 c          enddo
5005 c 9/28/08 AL Gradient compotents will be summed only at the end
5006           do k=1,3
5007             gelc_long(k,j)=gelc(k,j)+ggg(k)
5008             gelc_long(k,i)=gelc(k,i)-ggg(k)
5009           enddo
5010 *
5011 * Loop over residues i+1 thru j-1.
5012 *
5013 cgrad          do k=i+1,j-1
5014 cgrad            do l=1,3
5015 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
5016 cgrad            enddo
5017 cgrad          enddo
5018 c 9/28/08 AL Gradient compotents will be summed only at the end
5019           ggg(1)=facvdw*xj
5020           ggg(2)=facvdw*yj
5021           ggg(3)=facvdw*zj
5022           do k=1,3
5023             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
5024             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
5025           enddo
5026 #endif
5027 *
5028 * Angular part
5029 *
5030           ecosa=2.0D0*fac3*fac1+fac4
5031           fac4=-3.0D0*fac4
5032           fac3=-6.0D0*fac3
5033           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
5034           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
5035           do k=1,3
5036             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
5037             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
5038           enddo
5039 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
5040 cd   &          (dcosg(k),k=1,3)
5041           do k=1,3
5042             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
5043           enddo
5044 c          do k=1,3
5045 c            ghalf=0.5D0*ggg(k)
5046 c            gelc(k,i)=gelc(k,i)+ghalf
5047 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
5048 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
5049 c            gelc(k,j)=gelc(k,j)+ghalf
5050 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
5051 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
5052 c          enddo
5053 cgrad          do k=i+1,j-1
5054 cgrad            do l=1,3
5055 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
5056 cgrad            enddo
5057 cgrad          enddo
5058           do k=1,3
5059             gelc(k,i)=gelc(k,i)
5060      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
5061      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
5062             gelc(k,j)=gelc(k,j)
5063      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
5064      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
5065             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
5066             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
5067           enddo
5068           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
5069      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
5070      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
5071 C
5072 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
5073 C   energy of a peptide unit is assumed in the form of a second-order
5074 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
5075 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
5076 C   are computed for EVERY pair of non-contiguous peptide groups.
5077 C
5078           if (j.lt.nres-1) then
5079             j1=j+1
5080             j2=j-1
5081           else
5082             j1=j-1
5083             j2=j-2
5084           endif
5085           kkk=0
5086           do k=1,2
5087             do l=1,2
5088               kkk=kkk+1
5089               muij(kkk)=mu(k,i)*mu(l,j)
5090             enddo
5091           enddo
5092 cd         write (iout,*) 'EELEC: i',i,' j',j
5093 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
5094 cd          write(iout,*) 'muij',muij
5095           ury=scalar(uy(1,i),erij)
5096           urz=scalar(uz(1,i),erij)
5097           vry=scalar(uy(1,j),erij)
5098           vrz=scalar(uz(1,j),erij)
5099           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
5100           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
5101           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
5102           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
5103           fac=dsqrt(-ael6i)*r3ij
5104           a22=a22*fac
5105           a23=a23*fac
5106           a32=a32*fac
5107           a33=a33*fac
5108 cd          write (iout,'(4i5,4f10.5)')
5109 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
5110 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
5111 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
5112 cd     &      uy(:,j),uz(:,j)
5113 cd          write (iout,'(4f10.5)')
5114 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
5115 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
5116 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
5117 cd           write (iout,'(9f10.5/)')
5118 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
5119 C Derivatives of the elements of A in virtual-bond vectors
5120           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
5121           do k=1,3
5122             uryg(k,1)=scalar(erder(1,k),uy(1,i))
5123             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
5124             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
5125             urzg(k,1)=scalar(erder(1,k),uz(1,i))
5126             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
5127             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
5128             vryg(k,1)=scalar(erder(1,k),uy(1,j))
5129             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
5130             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
5131             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
5132             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
5133             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
5134           enddo
5135 C Compute radial contributions to the gradient
5136           facr=-3.0d0*rrmij
5137           a22der=a22*facr
5138           a23der=a23*facr
5139           a32der=a32*facr
5140           a33der=a33*facr
5141           agg(1,1)=a22der*xj
5142           agg(2,1)=a22der*yj
5143           agg(3,1)=a22der*zj
5144           agg(1,2)=a23der*xj
5145           agg(2,2)=a23der*yj
5146           agg(3,2)=a23der*zj
5147           agg(1,3)=a32der*xj
5148           agg(2,3)=a32der*yj
5149           agg(3,3)=a32der*zj
5150           agg(1,4)=a33der*xj
5151           agg(2,4)=a33der*yj
5152           agg(3,4)=a33der*zj
5153 C Add the contributions coming from er
5154           fac3=-3.0d0*fac
5155           do k=1,3
5156             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
5157             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
5158             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
5159             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
5160           enddo
5161           do k=1,3
5162 C Derivatives in DC(i)
5163 cgrad            ghalf1=0.5d0*agg(k,1)
5164 cgrad            ghalf2=0.5d0*agg(k,2)
5165 cgrad            ghalf3=0.5d0*agg(k,3)
5166 cgrad            ghalf4=0.5d0*agg(k,4)
5167             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
5168      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
5169             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
5170      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
5171             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
5172      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
5173             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
5174      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
5175 C Derivatives in DC(i+1)
5176             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
5177      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
5178             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
5179      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
5180             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
5181      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
5182             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
5183      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
5184 C Derivatives in DC(j)
5185             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
5186      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
5187             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
5188      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
5189             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
5190      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
5191             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
5192      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
5193 C Derivatives in DC(j+1) or DC(nres-1)
5194             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
5195      &      -3.0d0*vryg(k,3)*ury)
5196             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
5197      &      -3.0d0*vrzg(k,3)*ury)
5198             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
5199      &      -3.0d0*vryg(k,3)*urz)
5200             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
5201      &      -3.0d0*vrzg(k,3)*urz)
5202 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
5203 cgrad              do l=1,4
5204 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
5205 cgrad              enddo
5206 cgrad            endif
5207           enddo
5208           acipa(1,1)=a22
5209           acipa(1,2)=a23
5210           acipa(2,1)=a32
5211           acipa(2,2)=a33
5212           a22=-a22
5213           a23=-a23
5214           do l=1,2
5215             do k=1,3
5216               agg(k,l)=-agg(k,l)
5217               aggi(k,l)=-aggi(k,l)
5218               aggi1(k,l)=-aggi1(k,l)
5219               aggj(k,l)=-aggj(k,l)
5220               aggj1(k,l)=-aggj1(k,l)
5221             enddo
5222           enddo
5223           if (j.lt.nres-1) then
5224             a22=-a22
5225             a32=-a32
5226             do l=1,3,2
5227               do k=1,3
5228                 agg(k,l)=-agg(k,l)
5229                 aggi(k,l)=-aggi(k,l)
5230                 aggi1(k,l)=-aggi1(k,l)
5231                 aggj(k,l)=-aggj(k,l)
5232                 aggj1(k,l)=-aggj1(k,l)
5233               enddo
5234             enddo
5235           else
5236             a22=-a22
5237             a23=-a23
5238             a32=-a32
5239             a33=-a33
5240             do l=1,4
5241               do k=1,3
5242                 agg(k,l)=-agg(k,l)
5243                 aggi(k,l)=-aggi(k,l)
5244                 aggi1(k,l)=-aggi1(k,l)
5245                 aggj(k,l)=-aggj(k,l)
5246                 aggj1(k,l)=-aggj1(k,l)
5247               enddo
5248             enddo
5249           endif
5250           ENDIF ! WCORR
5251           IF (wel_loc.gt.0.0d0) THEN
5252 C Contribution to the local-electrostatic energy coming from the i-j pair
5253           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
5254      &     +a33*muij(4)
5255 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
5256
5257           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5258      &            'eelloc',i,j,eel_loc_ij
5259
5260           eel_loc=eel_loc+eel_loc_ij
5261 C Partial derivatives in virtual-bond dihedral angles gamma
5262           if (i.gt.1)
5263      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
5264      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
5265      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
5266           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
5267      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
5268      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
5269 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
5270           do l=1,3
5271             ggg(l)=agg(l,1)*muij(1)+
5272      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
5273             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
5274             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
5275 cgrad            ghalf=0.5d0*ggg(l)
5276 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
5277 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
5278           enddo
5279 cgrad          do k=i+1,j2
5280 cgrad            do l=1,3
5281 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
5282 cgrad            enddo
5283 cgrad          enddo
5284 C Remaining derivatives of eello
5285           do l=1,3
5286             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
5287      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
5288             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
5289      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
5290             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
5291      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
5292             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
5293      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
5294           enddo
5295           ENDIF
5296 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
5297 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
5298           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
5299      &       .and. num_conti.le.maxconts) then
5300 c            write (iout,*) i,j," entered corr"
5301 C
5302 C Calculate the contact function. The ith column of the array JCONT will
5303 C contain the numbers of atoms that make contacts with the atom I (of numbers
5304 C greater than I). The arrays FACONT and GACONT will contain the values of
5305 C the contact function and its derivative.
5306 c           r0ij=1.02D0*rpp(iteli,itelj)
5307 c           r0ij=1.11D0*rpp(iteli,itelj)
5308             r0ij=2.20D0*rpp(iteli,itelj)
5309 c           r0ij=1.55D0*rpp(iteli,itelj)
5310             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
5311             if (fcont.gt.0.0D0) then
5312               num_conti=num_conti+1
5313               if (num_conti.gt.maxconts) then
5314                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
5315      &                         ' will skip next contacts for this conf.'
5316               else
5317                 jcont_hb(num_conti,i)=j
5318 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
5319 cd     &           " jcont_hb",jcont_hb(num_conti,i)
5320                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
5321      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
5322 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
5323 C  terms.
5324                 d_cont(num_conti,i)=rij
5325 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
5326 C     --- Electrostatic-interaction matrix ---
5327                 a_chuj(1,1,num_conti,i)=a22
5328                 a_chuj(1,2,num_conti,i)=a23
5329                 a_chuj(2,1,num_conti,i)=a32
5330                 a_chuj(2,2,num_conti,i)=a33
5331 C     --- Gradient of rij
5332                 do kkk=1,3
5333                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
5334                 enddo
5335                 kkll=0
5336                 do k=1,2
5337                   do l=1,2
5338                     kkll=kkll+1
5339                     do m=1,3
5340                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
5341                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
5342                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
5343                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
5344                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
5345                     enddo
5346                   enddo
5347                 enddo
5348                 ENDIF
5349                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
5350 C Calculate contact energies
5351                 cosa4=4.0D0*cosa
5352                 wij=cosa-3.0D0*cosb*cosg
5353                 cosbg1=cosb+cosg
5354                 cosbg2=cosb-cosg
5355 c               fac3=dsqrt(-ael6i)/r0ij**3
5356                 fac3=dsqrt(-ael6i)*r3ij
5357 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
5358                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
5359                 if (ees0tmp.gt.0) then
5360                   ees0pij=dsqrt(ees0tmp)
5361                 else
5362                   ees0pij=0
5363                 endif
5364 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
5365                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
5366                 if (ees0tmp.gt.0) then
5367                   ees0mij=dsqrt(ees0tmp)
5368                 else
5369                   ees0mij=0
5370                 endif
5371 c               ees0mij=0.0D0
5372                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
5373                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
5374 C Diagnostics. Comment out or remove after debugging!
5375 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
5376 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
5377 c               ees0m(num_conti,i)=0.0D0
5378 C End diagnostics.
5379 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
5380 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
5381 C Angular derivatives of the contact function
5382                 ees0pij1=fac3/ees0pij
5383                 ees0mij1=fac3/ees0mij
5384                 fac3p=-3.0D0*fac3*rrmij
5385                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
5386                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
5387 c               ees0mij1=0.0D0
5388                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
5389                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
5390                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
5391                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
5392                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
5393                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
5394                 ecosap=ecosa1+ecosa2
5395                 ecosbp=ecosb1+ecosb2
5396                 ecosgp=ecosg1+ecosg2
5397                 ecosam=ecosa1-ecosa2
5398                 ecosbm=ecosb1-ecosb2
5399                 ecosgm=ecosg1-ecosg2
5400 C Diagnostics
5401 c               ecosap=ecosa1
5402 c               ecosbp=ecosb1
5403 c               ecosgp=ecosg1
5404 c               ecosam=0.0D0
5405 c               ecosbm=0.0D0
5406 c               ecosgm=0.0D0
5407 C End diagnostics
5408                 facont_hb(num_conti,i)=fcont
5409                 fprimcont=fprimcont/rij
5410 cd              facont_hb(num_conti,i)=1.0D0
5411 C Following line is for diagnostics.
5412 cd              fprimcont=0.0D0
5413                 do k=1,3
5414                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
5415                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
5416                 enddo
5417                 do k=1,3
5418                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
5419                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
5420                 enddo
5421                 gggp(1)=gggp(1)+ees0pijp*xj
5422                 gggp(2)=gggp(2)+ees0pijp*yj
5423                 gggp(3)=gggp(3)+ees0pijp*zj
5424                 gggm(1)=gggm(1)+ees0mijp*xj
5425                 gggm(2)=gggm(2)+ees0mijp*yj
5426                 gggm(3)=gggm(3)+ees0mijp*zj
5427 C Derivatives due to the contact function
5428                 gacont_hbr(1,num_conti,i)=fprimcont*xj
5429                 gacont_hbr(2,num_conti,i)=fprimcont*yj
5430                 gacont_hbr(3,num_conti,i)=fprimcont*zj
5431                 do k=1,3
5432 c
5433 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
5434 c          following the change of gradient-summation algorithm.
5435 c
5436 cgrad                  ghalfp=0.5D0*gggp(k)
5437 cgrad                  ghalfm=0.5D0*gggm(k)
5438                   gacontp_hb1(k,num_conti,i)=!ghalfp
5439      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
5440      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
5441                   gacontp_hb2(k,num_conti,i)=!ghalfp
5442      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
5443      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
5444                   gacontp_hb3(k,num_conti,i)=gggp(k)
5445                   gacontm_hb1(k,num_conti,i)=!ghalfm
5446      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
5447      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
5448                   gacontm_hb2(k,num_conti,i)=!ghalfm
5449      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
5450      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
5451                   gacontm_hb3(k,num_conti,i)=gggm(k)
5452                 enddo
5453 C Diagnostics. Comment out or remove after debugging!
5454 cdiag           do k=1,3
5455 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
5456 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
5457 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
5458 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
5459 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
5460 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
5461 cdiag           enddo
5462               ENDIF ! wcorr
5463               endif  ! num_conti.le.maxconts
5464             endif  ! fcont.gt.0
5465           endif    ! j.gt.i+1
5466           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
5467             do k=1,4
5468               do l=1,3
5469                 ghalf=0.5d0*agg(l,k)
5470                 aggi(l,k)=aggi(l,k)+ghalf
5471                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
5472                 aggj(l,k)=aggj(l,k)+ghalf
5473               enddo
5474             enddo
5475             if (j.eq.nres-1 .and. i.lt.j-2) then
5476               do k=1,4
5477                 do l=1,3
5478                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
5479                 enddo
5480               enddo
5481             endif
5482           endif
5483 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
5484       return
5485       end
5486 C-----------------------------------------------------------------------------
5487       subroutine eturn3(i,eello_turn3)
5488 C Third- and fourth-order contributions from turns
5489       implicit real*8 (a-h,o-z)
5490       include 'DIMENSIONS'
5491       include 'COMMON.IOUNITS'
5492       include 'COMMON.GEO'
5493       include 'COMMON.VAR'
5494       include 'COMMON.LOCAL'
5495       include 'COMMON.CHAIN'
5496       include 'COMMON.DERIV'
5497       include 'COMMON.INTERACT'
5498       include 'COMMON.CONTACTS'
5499       include 'COMMON.TORSION'
5500       include 'COMMON.VECTORS'
5501       include 'COMMON.FFIELD'
5502       include 'COMMON.CONTROL'
5503       dimension ggg(3)
5504       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5505      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5506      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
5507       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5508      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5509       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5510      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5511      &    num_conti,j1,j2
5512       j=i+2
5513 c      write (iout,*) "eturn3",i,j,j1,j2
5514       a_temp(1,1)=a22
5515       a_temp(1,2)=a23
5516       a_temp(2,1)=a32
5517       a_temp(2,2)=a33
5518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5519 C
5520 C               Third-order contributions
5521 C
5522 C                 (i+2)o----(i+3)
5523 C                      | |
5524 C                      | |
5525 C                 (i+1)o----i
5526 C
5527 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5528 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5529         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5530         call transpose2(auxmat(1,1),auxmat1(1,1))
5531         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5532         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
5533         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5534      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
5535 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5536 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5537 cd     &    ' eello_turn3_num',4*eello_turn3_num
5538 C Derivatives in gamma(i)
5539         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5540         call transpose2(auxmat2(1,1),auxmat3(1,1))
5541         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5542         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5543 C Derivatives in gamma(i+1)
5544         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5545         call transpose2(auxmat2(1,1),auxmat3(1,1))
5546         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5547         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5548      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5549 C Cartesian derivatives
5550         do l=1,3
5551 c            ghalf1=0.5d0*agg(l,1)
5552 c            ghalf2=0.5d0*agg(l,2)
5553 c            ghalf3=0.5d0*agg(l,3)
5554 c            ghalf4=0.5d0*agg(l,4)
5555           a_temp(1,1)=aggi(l,1)!+ghalf1
5556           a_temp(1,2)=aggi(l,2)!+ghalf2
5557           a_temp(2,1)=aggi(l,3)!+ghalf3
5558           a_temp(2,2)=aggi(l,4)!+ghalf4
5559           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5560           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5561      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5562           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5563           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5564           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5565           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5566           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5567           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5568      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5569           a_temp(1,1)=aggj(l,1)!+ghalf1
5570           a_temp(1,2)=aggj(l,2)!+ghalf2
5571           a_temp(2,1)=aggj(l,3)!+ghalf3
5572           a_temp(2,2)=aggj(l,4)!+ghalf4
5573           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5574           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5575      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5576           a_temp(1,1)=aggj1(l,1)
5577           a_temp(1,2)=aggj1(l,2)
5578           a_temp(2,1)=aggj1(l,3)
5579           a_temp(2,2)=aggj1(l,4)
5580           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5581           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5582      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5583         enddo
5584       return
5585       end
5586 C-------------------------------------------------------------------------------
5587       subroutine eturn4(i,eello_turn4)
5588 C Third- and fourth-order contributions from turns
5589       implicit real*8 (a-h,o-z)
5590       include 'DIMENSIONS'
5591       include 'COMMON.IOUNITS'
5592       include 'COMMON.GEO'
5593       include 'COMMON.VAR'
5594       include 'COMMON.LOCAL'
5595       include 'COMMON.CHAIN'
5596       include 'COMMON.DERIV'
5597       include 'COMMON.INTERACT'
5598       include 'COMMON.CONTACTS'
5599       include 'COMMON.TORSION'
5600       include 'COMMON.VECTORS'
5601       include 'COMMON.FFIELD'
5602       include 'COMMON.CONTROL'
5603       dimension ggg(3)
5604       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5605      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5606      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
5607       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5608      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5609       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5610      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5611      &    num_conti,j1,j2
5612       j=i+3
5613 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5614 C
5615 C               Fourth-order contributions
5616 C
5617 C                 (i+3)o----(i+4)
5618 C                     /  |
5619 C               (i+2)o   |
5620 C                     \  |
5621 C                 (i+1)o----i
5622 C
5623 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5624 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5625 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5626         a_temp(1,1)=a22
5627         a_temp(1,2)=a23
5628         a_temp(2,1)=a32
5629         a_temp(2,2)=a33
5630         iti1=itortyp(itype(i+1))
5631         iti2=itortyp(itype(i+2))
5632         iti3=itortyp(itype(i+3))
5633 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5634         call transpose2(EUg(1,1,i+1),e1t(1,1))
5635         call transpose2(Eug(1,1,i+2),e2t(1,1))
5636         call transpose2(Eug(1,1,i+3),e3t(1,1))
5637         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5638         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5639         s1=scalar2(b1(1,i+2),auxvec(1))
5640         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5641         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5642         s2=scalar2(b1(1,i+1),auxvec(1))
5643         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5644         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5645         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5646         eello_turn4=eello_turn4-(s1+s2+s3)
5647         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5648      &      'eturn4',i,j,-(s1+s2+s3)
5649 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5650 cd     &    ' eello_turn4_num',8*eello_turn4_num
5651 C Derivatives in gamma(i)
5652         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5653         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5654         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5655         s1=scalar2(b1(1,i+2),auxvec(1))
5656         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5657         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5658         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5659 C Derivatives in gamma(i+1)
5660         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5661         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5662         s2=scalar2(b1(1,i+1),auxvec(1))
5663         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5664         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5665         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5666         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5667 C Derivatives in gamma(i+2)
5668         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5669         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5670         s1=scalar2(b1(1,i+2),auxvec(1))
5671         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5672         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5673         s2=scalar2(b1(1,i+1),auxvec(1))
5674         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5675         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5676         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5677         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5678 C Cartesian derivatives
5679 C Derivatives of this turn contributions in DC(i+2)
5680         if (j.lt.nres-1) then
5681           do l=1,3
5682             a_temp(1,1)=agg(l,1)
5683             a_temp(1,2)=agg(l,2)
5684             a_temp(2,1)=agg(l,3)
5685             a_temp(2,2)=agg(l,4)
5686             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5687             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5688             s1=scalar2(b1(1,i+2),auxvec(1))
5689             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5690             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5691             s2=scalar2(b1(1,i+1),auxvec(1))
5692             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5693             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5694             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5695             ggg(l)=-(s1+s2+s3)
5696             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5697           enddo
5698         endif
5699 C Remaining derivatives of this turn contribution
5700         do l=1,3
5701           a_temp(1,1)=aggi(l,1)
5702           a_temp(1,2)=aggi(l,2)
5703           a_temp(2,1)=aggi(l,3)
5704           a_temp(2,2)=aggi(l,4)
5705           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5706           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5707           s1=scalar2(b1(1,i+2),auxvec(1))
5708           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5709           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5710           s2=scalar2(b1(1,i+1),auxvec(1))
5711           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5712           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5713           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5714           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5715           a_temp(1,1)=aggi1(l,1)
5716           a_temp(1,2)=aggi1(l,2)
5717           a_temp(2,1)=aggi1(l,3)
5718           a_temp(2,2)=aggi1(l,4)
5719           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5720           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5721           s1=scalar2(b1(1,i+2),auxvec(1))
5722           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5723           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5724           s2=scalar2(b1(1,i+1),auxvec(1))
5725           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5726           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5727           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5728           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5729           a_temp(1,1)=aggj(l,1)
5730           a_temp(1,2)=aggj(l,2)
5731           a_temp(2,1)=aggj(l,3)
5732           a_temp(2,2)=aggj(l,4)
5733           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5734           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5735           s1=scalar2(b1(1,i+2),auxvec(1))
5736           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5737           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5738           s2=scalar2(b1(1,i+1),auxvec(1))
5739           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5740           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5741           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5742           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5743           a_temp(1,1)=aggj1(l,1)
5744           a_temp(1,2)=aggj1(l,2)
5745           a_temp(2,1)=aggj1(l,3)
5746           a_temp(2,2)=aggj1(l,4)
5747           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5748           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5749           s1=scalar2(b1(1,i+2),auxvec(1))
5750           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5751           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5752           s2=scalar2(b1(1,i+1),auxvec(1))
5753           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5754           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5755           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5756 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5757           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5758         enddo
5759       return
5760       end
5761 C-----------------------------------------------------------------------------
5762       subroutine vecpr(u,v,w)
5763       implicit real*8(a-h,o-z)
5764       dimension u(3),v(3),w(3)
5765       w(1)=u(2)*v(3)-u(3)*v(2)
5766       w(2)=-u(1)*v(3)+u(3)*v(1)
5767       w(3)=u(1)*v(2)-u(2)*v(1)
5768       return
5769       end
5770 C-----------------------------------------------------------------------------
5771       subroutine unormderiv(u,ugrad,unorm,ungrad)
5772 C This subroutine computes the derivatives of a normalized vector u, given
5773 C the derivatives computed without normalization conditions, ugrad. Returns
5774 C ungrad.
5775       implicit none
5776       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5777       double precision vec(3)
5778       double precision scalar
5779       integer i,j
5780 c      write (2,*) 'ugrad',ugrad
5781 c      write (2,*) 'u',u
5782       do i=1,3
5783         vec(i)=scalar(ugrad(1,i),u(1))
5784       enddo
5785 c      write (2,*) 'vec',vec
5786       do i=1,3
5787         do j=1,3
5788           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5789         enddo
5790       enddo
5791 c      write (2,*) 'ungrad',ungrad
5792       return
5793       end
5794 C-----------------------------------------------------------------------------
5795       subroutine escp_soft_sphere(evdw2,evdw2_14)
5796 C
5797 C This subroutine calculates the excluded-volume interaction energy between
5798 C peptide-group centers and side chains and its gradient in virtual-bond and
5799 C side-chain vectors.
5800 C
5801       implicit real*8 (a-h,o-z)
5802       include 'DIMENSIONS'
5803       include 'COMMON.GEO'
5804       include 'COMMON.VAR'
5805       include 'COMMON.LOCAL'
5806       include 'COMMON.CHAIN'
5807       include 'COMMON.DERIV'
5808       include 'COMMON.INTERACT'
5809       include 'COMMON.FFIELD'
5810       include 'COMMON.IOUNITS'
5811       include 'COMMON.CONTROL'
5812       dimension ggg(3)
5813       evdw2=0.0D0
5814       evdw2_14=0.0d0
5815       r0_scp=4.5d0
5816 cd    print '(a)','Enter ESCP'
5817 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5818       do i=iatscp_s,iatscp_e
5819         iteli=itel(i)
5820         xi=0.5D0*(c(1,i)+c(1,i+1))
5821         yi=0.5D0*(c(2,i)+c(2,i+1))
5822         zi=0.5D0*(c(3,i)+c(3,i+1))
5823
5824         do iint=1,nscp_gr(i)
5825
5826         do j=iscpstart(i,iint),iscpend(i,iint)
5827           itypj=itype(j)
5828 C Uncomment following three lines for SC-p interactions
5829 c         xj=c(1,nres+j)-xi
5830 c         yj=c(2,nres+j)-yi
5831 c         zj=c(3,nres+j)-zi
5832 C Uncomment following three lines for Ca-p interactions
5833           xj=c(1,j)-xi
5834           yj=c(2,j)-yi
5835           zj=c(3,j)-zi
5836           rij=xj*xj+yj*yj+zj*zj
5837           r0ij=r0_scp
5838           r0ijsq=r0ij*r0ij
5839           if (rij.lt.r0ijsq) then
5840             evdwij=0.25d0*(rij-r0ijsq)**2
5841             fac=rij-r0ijsq
5842           else
5843             evdwij=0.0d0
5844             fac=0.0d0
5845           endif
5846           evdw2=evdw2+evdwij
5847 C
5848 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5849 C
5850           ggg(1)=xj*fac
5851           ggg(2)=yj*fac
5852           ggg(3)=zj*fac
5853 cgrad          if (j.lt.i) then
5854 cd          write (iout,*) 'j<i'
5855 C Uncomment following three lines for SC-p interactions
5856 c           do k=1,3
5857 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5858 c           enddo
5859 cgrad          else
5860 cd          write (iout,*) 'j>i'
5861 cgrad            do k=1,3
5862 cgrad              ggg(k)=-ggg(k)
5863 C Uncomment following line for SC-p interactions
5864 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5865 cgrad            enddo
5866 cgrad          endif
5867 cgrad          do k=1,3
5868 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5869 cgrad          enddo
5870 cgrad          kstart=min0(i+1,j)
5871 cgrad          kend=max0(i-1,j-1)
5872 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5873 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5874 cgrad          do k=kstart,kend
5875 cgrad            do l=1,3
5876 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5877 cgrad            enddo
5878 cgrad          enddo
5879           do k=1,3
5880             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5881             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5882           enddo
5883         enddo
5884
5885         enddo ! iint
5886       enddo ! i
5887       return
5888       end
5889 C-----------------------------------------------------------------------------
5890       subroutine escp(evdw2,evdw2_14)
5891 C
5892 C This subroutine calculates the excluded-volume interaction energy between
5893 C peptide-group centers and side chains and its gradient in virtual-bond and
5894 C side-chain vectors.
5895 C
5896       implicit real*8 (a-h,o-z)
5897       include 'DIMENSIONS'
5898       include 'COMMON.GEO'
5899       include 'COMMON.VAR'
5900       include 'COMMON.LOCAL'
5901       include 'COMMON.CHAIN'
5902       include 'COMMON.DERIV'
5903       include 'COMMON.INTERACT'
5904       include 'COMMON.FFIELD'
5905       include 'COMMON.IOUNITS'
5906       include 'COMMON.CONTROL'
5907       dimension ggg(3)
5908       evdw2=0.0D0
5909       evdw2_14=0.0d0
5910 cd    print '(a)','Enter ESCP'
5911 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5912       do i=iatscp_s,iatscp_e
5913         iteli=itel(i)
5914         xi=0.5D0*(c(1,i)+c(1,i+1))
5915         yi=0.5D0*(c(2,i)+c(2,i+1))
5916         zi=0.5D0*(c(3,i)+c(3,i+1))
5917
5918         do iint=1,nscp_gr(i)
5919
5920         do j=iscpstart(i,iint),iscpend(i,iint)
5921           itypj=itype(j)
5922 C Uncomment following three lines for SC-p interactions
5923 c         xj=c(1,nres+j)-xi
5924 c         yj=c(2,nres+j)-yi
5925 c         zj=c(3,nres+j)-zi
5926 C Uncomment following three lines for Ca-p interactions
5927           xj=c(1,j)-xi
5928           yj=c(2,j)-yi
5929           zj=c(3,j)-zi
5930           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5931           fac=rrij**expon2
5932           e1=fac*fac*aad(itypj,iteli)
5933           e2=fac*bad(itypj,iteli)
5934           if (iabs(j-i) .le. 2) then
5935             e1=scal14*e1
5936             e2=scal14*e2
5937             evdw2_14=evdw2_14+e1+e2
5938           endif
5939           evdwij=e1+e2
5940           evdw2=evdw2+evdwij
5941           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5942      &        'evdw2',i,j,evdwij
5943 C
5944 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5945 C
5946           fac=-(evdwij+e1)*rrij
5947           ggg(1)=xj*fac
5948           ggg(2)=yj*fac
5949           ggg(3)=zj*fac
5950 cgrad          if (j.lt.i) then
5951 cd          write (iout,*) 'j<i'
5952 C Uncomment following three lines for SC-p interactions
5953 c           do k=1,3
5954 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5955 c           enddo
5956 cgrad          else
5957 cd          write (iout,*) 'j>i'
5958 cgrad            do k=1,3
5959 cgrad              ggg(k)=-ggg(k)
5960 C Uncomment following line for SC-p interactions
5961 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5962 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5963 cgrad            enddo
5964 cgrad          endif
5965 cgrad          do k=1,3
5966 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5967 cgrad          enddo
5968 cgrad          kstart=min0(i+1,j)
5969 cgrad          kend=max0(i-1,j-1)
5970 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5971 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5972 cgrad          do k=kstart,kend
5973 cgrad            do l=1,3
5974 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5975 cgrad            enddo
5976 cgrad          enddo
5977           do k=1,3
5978             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5979             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5980           enddo
5981         enddo
5982
5983         enddo ! iint
5984       enddo ! i
5985       do i=1,nct
5986         do j=1,3
5987           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5988           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5989           gradx_scp(j,i)=expon*gradx_scp(j,i)
5990         enddo
5991       enddo
5992 C******************************************************************************
5993 C
5994 C                              N O T E !!!
5995 C
5996 C To save time the factor EXPON has been extracted from ALL components
5997 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5998 C use!
5999 C
6000 C******************************************************************************
6001       return
6002       end
6003 C--------------------------------------------------------------------------
6004       subroutine edis(ehpb)
6005 C
6006 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
6007 C
6008       implicit real*8 (a-h,o-z)
6009       include 'DIMENSIONS'
6010       include 'COMMON.SBRIDGE'
6011       include 'COMMON.CHAIN'
6012       include 'COMMON.DERIV'
6013       include 'COMMON.VAR'
6014       include 'COMMON.INTERACT'
6015       include 'COMMON.IOUNITS'
6016       dimension ggg(3)
6017       ehpb=0.0D0
6018 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6019 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
6020       if (link_end.eq.0) return
6021       do i=link_start,link_end
6022 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6023 C CA-CA distance used in regularization of structure.
6024         ii=ihpb(i)
6025         jj=jhpb(i)
6026 C iii and jjj point to the residues for which the distance is assigned.
6027         if (ii.gt.nres) then
6028           iii=ii-nres
6029           jjj=jj-nres
6030         else
6031           iii=ii
6032           jjj=jj
6033         endif
6034 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6035 c     &    dhpb(i),dhpb1(i),forcon(i)
6036 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6037 C    distance and angle dependent SS bond potential.
6038 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6039 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6040         if (.not.dyn_ss .and. i.le.nss) then
6041 C 15/02/13 CC dynamic SSbond - additional check
6042          if (ii.gt.nres
6043      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6044           call ssbond_ene(iii,jjj,eij)
6045           ehpb=ehpb+2*eij
6046          endif
6047 cd          write (iout,*) "eij",eij
6048         else if (ii.gt.nres .and. jj.gt.nres) then
6049 c Restraints from contact prediction
6050           dd=dist(ii,jj)
6051           if (dhpb1(i).gt.0.0d0) then
6052             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6053             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6054 c            write (iout,*) "beta nmr",
6055 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6056           else
6057             dd=dist(ii,jj)
6058             rdis=dd-dhpb(i)
6059 C Get the force constant corresponding to this distance.
6060             waga=forcon(i)
6061 C Calculate the contribution to energy.
6062             ehpb=ehpb+waga*rdis*rdis
6063 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
6064 C
6065 C Evaluate gradient.
6066 C
6067             fac=waga*rdis/dd
6068           endif
6069           do j=1,3
6070             ggg(j)=fac*(c(j,jj)-c(j,ii))
6071           enddo
6072           do j=1,3
6073             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6074             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6075           enddo
6076           do k=1,3
6077             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6078             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6079           enddo
6080         else
6081 C Calculate the distance between the two points and its difference from the
6082 C target distance.
6083           dd=dist(ii,jj)
6084           if (dhpb1(i).gt.0.0d0) then
6085             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6086             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6087 c            write (iout,*) "alph nmr",
6088 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6089           else
6090             rdis=dd-dhpb(i)
6091 C Get the force constant corresponding to this distance.
6092             waga=forcon(i)
6093 C Calculate the contribution to energy.
6094             ehpb=ehpb+waga*rdis*rdis
6095 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
6096 C
6097 C Evaluate gradient.
6098 C
6099             fac=waga*rdis/dd
6100           endif
6101 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
6102 cd   &   ' waga=',waga,' fac=',fac
6103             do j=1,3
6104               ggg(j)=fac*(c(j,jj)-c(j,ii))
6105             enddo
6106 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6107 C If this is a SC-SC distance, we need to calculate the contributions to the
6108 C Cartesian gradient in the SC vectors (ghpbx).
6109           if (iii.lt.ii) then
6110           do j=1,3
6111             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6112             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6113           enddo
6114           endif
6115 cgrad        do j=iii,jjj-1
6116 cgrad          do k=1,3
6117 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6118 cgrad          enddo
6119 cgrad        enddo
6120           do k=1,3
6121             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6122             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6123           enddo
6124         endif
6125       enddo
6126       ehpb=0.5D0*ehpb
6127       return
6128       end
6129 C--------------------------------------------------------------------------
6130       subroutine ssbond_ene(i,j,eij)
6131 C
6132 C Calculate the distance and angle dependent SS-bond potential energy
6133 C using a free-energy function derived based on RHF/6-31G** ab initio
6134 C calculations of diethyl disulfide.
6135 C
6136 C A. Liwo and U. Kozlowska, 11/24/03
6137 C
6138       implicit real*8 (a-h,o-z)
6139       include 'DIMENSIONS'
6140       include 'COMMON.SBRIDGE'
6141       include 'COMMON.CHAIN'
6142       include 'COMMON.DERIV'
6143       include 'COMMON.LOCAL'
6144       include 'COMMON.INTERACT'
6145       include 'COMMON.VAR'
6146       include 'COMMON.IOUNITS'
6147       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6148       itypi=itype(i)
6149       xi=c(1,nres+i)
6150       yi=c(2,nres+i)
6151       zi=c(3,nres+i)
6152       dxi=dc_norm(1,nres+i)
6153       dyi=dc_norm(2,nres+i)
6154       dzi=dc_norm(3,nres+i)
6155 c      dsci_inv=dsc_inv(itypi)
6156       dsci_inv=vbld_inv(nres+i)
6157       itypj=itype(j)
6158 c      dscj_inv=dsc_inv(itypj)
6159       dscj_inv=vbld_inv(nres+j)
6160       xj=c(1,nres+j)-xi
6161       yj=c(2,nres+j)-yi
6162       zj=c(3,nres+j)-zi
6163       dxj=dc_norm(1,nres+j)
6164       dyj=dc_norm(2,nres+j)
6165       dzj=dc_norm(3,nres+j)
6166       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6167       rij=dsqrt(rrij)
6168       erij(1)=xj*rij
6169       erij(2)=yj*rij
6170       erij(3)=zj*rij
6171       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6172       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6173       om12=dxi*dxj+dyi*dyj+dzi*dzj
6174       do k=1,3
6175         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6176         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6177       enddo
6178       rij=1.0d0/rij
6179       deltad=rij-d0cm
6180       deltat1=1.0d0-om1
6181       deltat2=1.0d0+om2
6182       deltat12=om2-om1+2.0d0
6183       cosphi=om12-om1*om2
6184       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6185      &  +akct*deltad*deltat12+ebr
6186      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
6187 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6188 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6189 c     &  " deltat12",deltat12," eij",eij
6190       ed=2*akcm*deltad+akct*deltat12
6191       pom1=akct*deltad
6192       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6193       eom1=-2*akth*deltat1-pom1-om2*pom2
6194       eom2= 2*akth*deltat2+pom1-om1*pom2
6195       eom12=pom2
6196       do k=1,3
6197         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6198         ghpbx(k,i)=ghpbx(k,i)-ggk
6199      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6200      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6201         ghpbx(k,j)=ghpbx(k,j)+ggk
6202      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6203      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6204         ghpbc(k,i)=ghpbc(k,i)-ggk
6205         ghpbc(k,j)=ghpbc(k,j)+ggk
6206       enddo
6207 C
6208 C Calculate the components of the gradient in DC and X
6209 C
6210 cgrad      do k=i,j-1
6211 cgrad        do l=1,3
6212 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6213 cgrad        enddo
6214 cgrad      enddo
6215       return
6216       end
6217 C--------------------------------------------------------------------------
6218       subroutine ebond(estr)
6219 c
6220 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6221 c
6222       implicit real*8 (a-h,o-z)
6223       include 'DIMENSIONS'
6224       include 'COMMON.LOCAL'
6225       include 'COMMON.GEO'
6226       include 'COMMON.INTERACT'
6227       include 'COMMON.DERIV'
6228       include 'COMMON.VAR'
6229       include 'COMMON.CHAIN'
6230       include 'COMMON.IOUNITS'
6231       include 'COMMON.NAMES'
6232       include 'COMMON.FFIELD'
6233       include 'COMMON.CONTROL'
6234       include 'COMMON.SETUP'
6235       double precision u(3),ud(3)
6236       estr=0.0d0
6237       do i=ibondp_start,ibondp_end
6238         diff = vbld(i)-vbldp0
6239 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
6240         estr=estr+diff*diff
6241         do j=1,3
6242           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6243         enddo
6244 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6245       enddo
6246       estr=0.5d0*AKP*estr
6247 c
6248 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6249 c
6250       do i=ibond_start,ibond_end
6251         iti=itype(i)
6252         if (iti.ne.10) then
6253           nbi=nbondterm(iti)
6254           if (nbi.eq.1) then
6255             diff=vbld(i+nres)-vbldsc0(1,iti)
6256 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6257 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6258             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6259             do j=1,3
6260               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6261             enddo
6262           else
6263             do j=1,nbi
6264               diff=vbld(i+nres)-vbldsc0(j,iti)
6265               ud(j)=aksc(j,iti)*diff
6266               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6267             enddo
6268             uprod=u(1)
6269             do j=2,nbi
6270               uprod=uprod*u(j)
6271             enddo
6272             usum=0.0d0
6273             usumsqder=0.0d0
6274             do j=1,nbi
6275               uprod1=1.0d0
6276               uprod2=1.0d0
6277               do k=1,nbi
6278                 if (k.ne.j) then
6279                   uprod1=uprod1*u(k)
6280                   uprod2=uprod2*u(k)*u(k)
6281                 endif
6282               enddo
6283               usum=usum+uprod1
6284               usumsqder=usumsqder+ud(j)*uprod2
6285             enddo
6286             estr=estr+uprod/usum
6287             do j=1,3
6288              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6289             enddo
6290           endif
6291         endif
6292       enddo
6293       return
6294       end
6295 #ifdef CRYST_THETA
6296 C--------------------------------------------------------------------------
6297       subroutine ebend(etheta)
6298 C
6299 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6300 C angles gamma and its derivatives in consecutive thetas and gammas.
6301 C
6302       implicit real*8 (a-h,o-z)
6303       include 'DIMENSIONS'
6304       include 'COMMON.LOCAL'
6305       include 'COMMON.GEO'
6306       include 'COMMON.INTERACT'
6307       include 'COMMON.DERIV'
6308       include 'COMMON.VAR'
6309       include 'COMMON.CHAIN'
6310       include 'COMMON.IOUNITS'
6311       include 'COMMON.NAMES'
6312       include 'COMMON.FFIELD'
6313       include 'COMMON.CONTROL'
6314       common /calcthet/ term1,term2,termm,diffak,ratak,
6315      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6316      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6317       double precision y(2),z(2)
6318       delta=0.02d0*pi
6319 c      time11=dexp(-2*time)
6320 c      time12=1.0d0
6321       etheta=0.0D0
6322 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6323       do i=ithet_start,ithet_end
6324 C Zero the energy function and its derivative at 0 or pi.
6325         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6326         it=itype(i-1)
6327         if (i.gt.3) then
6328 #ifdef OSF
6329           phii=phi(i)
6330           if (phii.ne.phii) phii=150.0
6331 #else
6332           phii=phi(i)
6333 #endif
6334           y(1)=dcos(phii)
6335           y(2)=dsin(phii)
6336         else
6337           y(1)=0.0D0
6338           y(2)=0.0D0
6339         endif
6340         if (i.lt.nres) then
6341 #ifdef OSF
6342           phii1=phi(i+1)
6343           if (phii1.ne.phii1) phii1=150.0
6344           phii1=pinorm(phii1)
6345           z(1)=cos(phii1)
6346 #else
6347           phii1=phi(i+1)
6348           z(1)=dcos(phii1)
6349 #endif
6350           z(2)=dsin(phii1)
6351         else
6352           z(1)=0.0D0
6353           z(2)=0.0D0
6354         endif
6355 C Calculate the "mean" value of theta from the part of the distribution
6356 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6357 C In following comments this theta will be referred to as t_c.
6358         thet_pred_mean=0.0d0
6359         do k=1,2
6360           athetk=athet(k,it)
6361           bthetk=bthet(k,it)
6362           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6363         enddo
6364         dthett=thet_pred_mean*ssd
6365         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6366 C Derivatives of the "mean" values in gamma1 and gamma2.
6367         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
6368         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
6369         if (theta(i).gt.pi-delta) then
6370           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6371      &         E_tc0)
6372           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6373           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6374           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6375      &        E_theta)
6376           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6377      &        E_tc)
6378         else if (theta(i).lt.delta) then
6379           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6380           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6381           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6382      &        E_theta)
6383           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6384           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6385      &        E_tc)
6386         else
6387           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6388      &        E_theta,E_tc)
6389         endif
6390         etheta=etheta+ethetai
6391         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6392      &      'ebend',i,ethetai
6393         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6394         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6395         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6396       enddo
6397 C Ufff.... We've done all this!!!
6398       return
6399       end
6400 C---------------------------------------------------------------------------
6401       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6402      &     E_tc)
6403       implicit real*8 (a-h,o-z)
6404       include 'DIMENSIONS'
6405       include 'COMMON.LOCAL'
6406       include 'COMMON.IOUNITS'
6407       common /calcthet/ term1,term2,termm,diffak,ratak,
6408      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6409      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6410 C Calculate the contributions to both Gaussian lobes.
6411 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6412 C The "polynomial part" of the "standard deviation" of this part of
6413 C the distribution.
6414         sig=polthet(3,it)
6415         do j=2,0,-1
6416           sig=sig*thet_pred_mean+polthet(j,it)
6417         enddo
6418 C Derivative of the "interior part" of the "standard deviation of the"
6419 C gamma-dependent Gaussian lobe in t_c.
6420         sigtc=3*polthet(3,it)
6421         do j=2,1,-1
6422           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6423         enddo
6424         sigtc=sig*sigtc
6425 C Set the parameters of both Gaussian lobes of the distribution.
6426 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6427         fac=sig*sig+sigc0(it)
6428         sigcsq=fac+fac
6429         sigc=1.0D0/sigcsq
6430 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6431         sigsqtc=-4.0D0*sigcsq*sigtc
6432 c       print *,i,sig,sigtc,sigsqtc
6433 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6434         sigtc=-sigtc/(fac*fac)
6435 C Following variable is sigma(t_c)**(-2)
6436         sigcsq=sigcsq*sigcsq
6437         sig0i=sig0(it)
6438         sig0inv=1.0D0/sig0i**2
6439         delthec=thetai-thet_pred_mean
6440         delthe0=thetai-theta0i
6441         term1=-0.5D0*sigcsq*delthec*delthec
6442         term2=-0.5D0*sig0inv*delthe0*delthe0
6443 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6444 C NaNs in taking the logarithm. We extract the largest exponent which is added
6445 C to the energy (this being the log of the distribution) at the end of energy
6446 C term evaluation for this virtual-bond angle.
6447         if (term1.gt.term2) then
6448           termm=term1
6449           term2=dexp(term2-termm)
6450           term1=1.0d0
6451         else
6452           termm=term2
6453           term1=dexp(term1-termm)
6454           term2=1.0d0
6455         endif
6456 C The ratio between the gamma-independent and gamma-dependent lobes of
6457 C the distribution is a Gaussian function of thet_pred_mean too.
6458         diffak=gthet(2,it)-thet_pred_mean
6459         ratak=diffak/gthet(3,it)**2
6460         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6461 C Let's differentiate it in thet_pred_mean NOW.
6462         aktc=ak*ratak
6463 C Now put together the distribution terms to make complete distribution.
6464         termexp=term1+ak*term2
6465         termpre=sigc+ak*sig0i
6466 C Contribution of the bending energy from this theta is just the -log of
6467 C the sum of the contributions from the two lobes and the pre-exponential
6468 C factor. Simple enough, isn't it?
6469         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6470 C NOW the derivatives!!!
6471 C 6/6/97 Take into account the deformation.
6472         E_theta=(delthec*sigcsq*term1
6473      &       +ak*delthe0*sig0inv*term2)/termexp
6474         E_tc=((sigtc+aktc*sig0i)/termpre
6475      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6476      &       aktc*term2)/termexp)
6477       return
6478       end
6479 c-----------------------------------------------------------------------------
6480       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6481       implicit real*8 (a-h,o-z)
6482       include 'DIMENSIONS'
6483       include 'COMMON.LOCAL'
6484       include 'COMMON.IOUNITS'
6485       common /calcthet/ term1,term2,termm,diffak,ratak,
6486      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6487      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6488       delthec=thetai-thet_pred_mean
6489       delthe0=thetai-theta0i
6490 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6491       t3 = thetai-thet_pred_mean
6492       t6 = t3**2
6493       t9 = term1
6494       t12 = t3*sigcsq
6495       t14 = t12+t6*sigsqtc
6496       t16 = 1.0d0
6497       t21 = thetai-theta0i
6498       t23 = t21**2
6499       t26 = term2
6500       t27 = t21*t26
6501       t32 = termexp
6502       t40 = t32**2
6503       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6504      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6505      & *(-t12*t9-ak*sig0inv*t27)
6506       return
6507       end
6508 #else
6509 C--------------------------------------------------------------------------
6510       subroutine ebend(etheta)
6511 C
6512 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6513 C angles gamma and its derivatives in consecutive thetas and gammas.
6514 C ab initio-derived potentials from
6515 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6516 C
6517       implicit real*8 (a-h,o-z)
6518       include 'DIMENSIONS'
6519       include 'COMMON.LOCAL'
6520       include 'COMMON.GEO'
6521       include 'COMMON.INTERACT'
6522       include 'COMMON.DERIV'
6523       include 'COMMON.VAR'
6524       include 'COMMON.CHAIN'
6525       include 'COMMON.IOUNITS'
6526       include 'COMMON.NAMES'
6527       include 'COMMON.FFIELD'
6528       include 'COMMON.CONTROL'
6529       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6530      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6531      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6532      & sinph1ph2(maxdouble,maxdouble)
6533       logical lprn /.false./, lprn1 /.false./
6534       etheta=0.0D0
6535       do i=ithet_start,ithet_end
6536         dethetai=0.0d0
6537         dephii=0.0d0
6538         dephii1=0.0d0
6539         theti2=0.5d0*theta(i)
6540         ityp2=ithetyp(itype(i-1))
6541         do k=1,nntheterm
6542           coskt(k)=dcos(k*theti2)
6543           sinkt(k)=dsin(k*theti2)
6544         enddo
6545         if (i.gt.3) then
6546 #ifdef OSF
6547           phii=phi(i)
6548           if (phii.ne.phii) phii=150.0
6549 #else
6550           phii=phi(i)
6551 #endif
6552           ityp1=ithetyp(itype(i-2))
6553           do k=1,nsingle
6554             cosph1(k)=dcos(k*phii)
6555             sinph1(k)=dsin(k*phii)
6556           enddo
6557         else
6558           phii=0.0d0
6559           ityp1=nthetyp+1
6560           do k=1,nsingle
6561             cosph1(k)=0.0d0
6562             sinph1(k)=0.0d0
6563           enddo
6564         endif
6565         if (i.lt.nres) then
6566 #ifdef OSF
6567           phii1=phi(i+1)
6568           if (phii1.ne.phii1) phii1=150.0
6569           phii1=pinorm(phii1)
6570 #else
6571           phii1=phi(i+1)
6572 #endif
6573           ityp3=ithetyp(itype(i))
6574           do k=1,nsingle
6575             cosph2(k)=dcos(k*phii1)
6576             sinph2(k)=dsin(k*phii1)
6577           enddo
6578         else
6579           phii1=0.0d0
6580           ityp3=nthetyp+1
6581           do k=1,nsingle
6582             cosph2(k)=0.0d0
6583             sinph2(k)=0.0d0
6584           enddo
6585         endif
6586         ethetai=aa0thet(ityp1,ityp2,ityp3)
6587         do k=1,ndouble
6588           do l=1,k-1
6589             ccl=cosph1(l)*cosph2(k-l)
6590             ssl=sinph1(l)*sinph2(k-l)
6591             scl=sinph1(l)*cosph2(k-l)
6592             csl=cosph1(l)*sinph2(k-l)
6593             cosph1ph2(l,k)=ccl-ssl
6594             cosph1ph2(k,l)=ccl+ssl
6595             sinph1ph2(l,k)=scl+csl
6596             sinph1ph2(k,l)=scl-csl
6597           enddo
6598         enddo
6599         if (lprn) then
6600         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6601      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6602         write (iout,*) "coskt and sinkt"
6603         do k=1,nntheterm
6604           write (iout,*) k,coskt(k),sinkt(k)
6605         enddo
6606         endif
6607         do k=1,ntheterm
6608           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
6609           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
6610      &      *coskt(k)
6611           if (lprn)
6612      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
6613      &     " ethetai",ethetai
6614         enddo
6615         if (lprn) then
6616         write (iout,*) "cosph and sinph"
6617         do k=1,nsingle
6618           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6619         enddo
6620         write (iout,*) "cosph1ph2 and sinph2ph2"
6621         do k=2,ndouble
6622           do l=1,k-1
6623             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6624      &         sinph1ph2(l,k),sinph1ph2(k,l)
6625           enddo
6626         enddo
6627         write(iout,*) "ethetai",ethetai
6628         endif
6629         do m=1,ntheterm2
6630           do k=1,nsingle
6631             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
6632      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
6633      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
6634      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
6635             ethetai=ethetai+sinkt(m)*aux
6636             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6637             dephii=dephii+k*sinkt(m)*(
6638      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
6639      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
6640             dephii1=dephii1+k*sinkt(m)*(
6641      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
6642      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
6643             if (lprn)
6644      &      write (iout,*) "m",m," k",k," bbthet",
6645      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
6646      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
6647      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
6648      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
6649           enddo
6650         enddo
6651         if (lprn)
6652      &  write(iout,*) "ethetai",ethetai
6653         do m=1,ntheterm3
6654           do k=2,ndouble
6655             do l=1,k-1
6656               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
6657      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
6658      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
6659      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
6660               ethetai=ethetai+sinkt(m)*aux
6661               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6662               dephii=dephii+l*sinkt(m)*(
6663      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
6664      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
6665      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
6666      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
6667               dephii1=dephii1+(k-l)*sinkt(m)*(
6668      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
6669      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
6670      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
6671      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
6672               if (lprn) then
6673               write (iout,*) "m",m," k",k," l",l," ffthet",
6674      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
6675      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
6676      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
6677      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
6678               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6679      &            cosph1ph2(k,l)*sinkt(m),
6680      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6681               endif
6682             enddo
6683           enddo
6684         enddo
6685 10      continue
6686         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6687      &   i,theta(i)*rad2deg,phii*rad2deg,
6688      &   phii1*rad2deg,ethetai
6689         etheta=etheta+ethetai
6690         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6691         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6692         gloc(nphi+i-2,icg)=wang*dethetai
6693       enddo
6694       return
6695       end
6696 #endif
6697 #ifdef CRYST_SC
6698 c-----------------------------------------------------------------------------
6699       subroutine esc(escloc)
6700 C Calculate the local energy of a side chain and its derivatives in the
6701 C corresponding virtual-bond valence angles THETA and the spherical angles
6702 C ALPHA and OMEGA.
6703       implicit real*8 (a-h,o-z)
6704       include 'DIMENSIONS'
6705       include 'COMMON.GEO'
6706       include 'COMMON.LOCAL'
6707       include 'COMMON.VAR'
6708       include 'COMMON.INTERACT'
6709       include 'COMMON.DERIV'
6710       include 'COMMON.CHAIN'
6711       include 'COMMON.IOUNITS'
6712       include 'COMMON.NAMES'
6713       include 'COMMON.FFIELD'
6714       include 'COMMON.CONTROL'
6715       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6716      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6717       common /sccalc/ time11,time12,time112,theti,it,nlobit
6718       delta=0.02d0*pi
6719       escloc=0.0D0
6720 c     write (iout,'(a)') 'ESC'
6721       do i=loc_start,loc_end
6722         it=itype(i)
6723         if (it.eq.10) goto 1
6724         nlobit=nlob(it)
6725 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6726 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6727         theti=theta(i+1)-pipol
6728         x(1)=dtan(theti)
6729         x(2)=alph(i)
6730         x(3)=omeg(i)
6731
6732         if (x(2).gt.pi-delta) then
6733           xtemp(1)=x(1)
6734           xtemp(2)=pi-delta
6735           xtemp(3)=x(3)
6736           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6737           xtemp(2)=pi
6738           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6739           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6740      &        escloci,dersc(2))
6741           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6742      &        ddersc0(1),dersc(1))
6743           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6744      &        ddersc0(3),dersc(3))
6745           xtemp(2)=pi-delta
6746           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6747           xtemp(2)=pi
6748           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6749           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6750      &            dersc0(2),esclocbi,dersc02)
6751           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6752      &            dersc12,dersc01)
6753           call splinthet(x(2),0.5d0*delta,ss,ssd)
6754           dersc0(1)=dersc01
6755           dersc0(2)=dersc02
6756           dersc0(3)=0.0d0
6757           do k=1,3
6758             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6759           enddo
6760           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6761 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6762 c    &             esclocbi,ss,ssd
6763           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6764 c         escloci=esclocbi
6765 c         write (iout,*) escloci
6766         else if (x(2).lt.delta) then
6767           xtemp(1)=x(1)
6768           xtemp(2)=delta
6769           xtemp(3)=x(3)
6770           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6771           xtemp(2)=0.0d0
6772           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6773           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6774      &        escloci,dersc(2))
6775           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6776      &        ddersc0(1),dersc(1))
6777           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6778      &        ddersc0(3),dersc(3))
6779           xtemp(2)=delta
6780           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6781           xtemp(2)=0.0d0
6782           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6783           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6784      &            dersc0(2),esclocbi,dersc02)
6785           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6786      &            dersc12,dersc01)
6787           dersc0(1)=dersc01
6788           dersc0(2)=dersc02
6789           dersc0(3)=0.0d0
6790           call splinthet(x(2),0.5d0*delta,ss,ssd)
6791           do k=1,3
6792             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6793           enddo
6794           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6795 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6796 c    &             esclocbi,ss,ssd
6797           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6798 c         write (iout,*) escloci
6799         else
6800           call enesc(x,escloci,dersc,ddummy,.false.)
6801         endif
6802
6803         escloc=escloc+escloci
6804         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6805      &     'escloc',i,escloci
6806 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6807
6808         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6809      &   wscloc*dersc(1)
6810         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6811         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6812     1   continue
6813       enddo
6814       return
6815       end
6816 C---------------------------------------------------------------------------
6817       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6818       implicit real*8 (a-h,o-z)
6819       include 'DIMENSIONS'
6820       include 'COMMON.GEO'
6821       include 'COMMON.LOCAL'
6822       include 'COMMON.IOUNITS'
6823       common /sccalc/ time11,time12,time112,theti,it,nlobit
6824       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6825       double precision contr(maxlob,-1:1)
6826       logical mixed
6827 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6828         escloc_i=0.0D0
6829         do j=1,3
6830           dersc(j)=0.0D0
6831           if (mixed) ddersc(j)=0.0d0
6832         enddo
6833         x3=x(3)
6834
6835 C Because of periodicity of the dependence of the SC energy in omega we have
6836 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6837 C To avoid underflows, first compute & store the exponents.
6838
6839         do iii=-1,1
6840
6841           x(3)=x3+iii*dwapi
6842
6843           do j=1,nlobit
6844             do k=1,3
6845               z(k)=x(k)-censc(k,j,it)
6846             enddo
6847             do k=1,3
6848               Axk=0.0D0
6849               do l=1,3
6850                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6851               enddo
6852               Ax(k,j,iii)=Axk
6853             enddo
6854             expfac=0.0D0
6855             do k=1,3
6856               expfac=expfac+Ax(k,j,iii)*z(k)
6857             enddo
6858             contr(j,iii)=expfac
6859           enddo ! j
6860
6861         enddo ! iii
6862
6863         x(3)=x3
6864 C As in the case of ebend, we want to avoid underflows in exponentiation and
6865 C subsequent NaNs and INFs in energy calculation.
6866 C Find the largest exponent
6867         emin=contr(1,-1)
6868         do iii=-1,1
6869           do j=1,nlobit
6870             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6871           enddo
6872         enddo
6873         emin=0.5D0*emin
6874 cd      print *,'it=',it,' emin=',emin
6875
6876 C Compute the contribution to SC energy and derivatives
6877         do iii=-1,1
6878
6879           do j=1,nlobit
6880 #ifdef OSF
6881             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
6882             if(adexp.ne.adexp) adexp=1.0
6883             expfac=dexp(adexp)
6884 #else
6885             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
6886 #endif
6887 cd          print *,'j=',j,' expfac=',expfac
6888             escloc_i=escloc_i+expfac
6889             do k=1,3
6890               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6891             enddo
6892             if (mixed) then
6893               do k=1,3,2
6894                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6895      &            +gaussc(k,2,j,it))*expfac
6896               enddo
6897             endif
6898           enddo
6899
6900         enddo ! iii
6901
6902         dersc(1)=dersc(1)/cos(theti)**2
6903         ddersc(1)=ddersc(1)/cos(theti)**2
6904         ddersc(3)=ddersc(3)
6905
6906         escloci=-(dlog(escloc_i)-emin)
6907         do j=1,3
6908           dersc(j)=dersc(j)/escloc_i
6909         enddo
6910         if (mixed) then
6911           do j=1,3,2
6912             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6913           enddo
6914         endif
6915       return
6916       end
6917 C------------------------------------------------------------------------------
6918       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6919       implicit real*8 (a-h,o-z)
6920       include 'DIMENSIONS'
6921       include 'COMMON.GEO'
6922       include 'COMMON.LOCAL'
6923       include 'COMMON.IOUNITS'
6924       common /sccalc/ time11,time12,time112,theti,it,nlobit
6925       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6926       double precision contr(maxlob)
6927       logical mixed
6928
6929       escloc_i=0.0D0
6930
6931       do j=1,3
6932         dersc(j)=0.0D0
6933       enddo
6934
6935       do j=1,nlobit
6936         do k=1,2
6937           z(k)=x(k)-censc(k,j,it)
6938         enddo
6939         z(3)=dwapi
6940         do k=1,3
6941           Axk=0.0D0
6942           do l=1,3
6943             Axk=Axk+gaussc(l,k,j,it)*z(l)
6944           enddo
6945           Ax(k,j)=Axk
6946         enddo
6947         expfac=0.0D0
6948         do k=1,3
6949           expfac=expfac+Ax(k,j)*z(k)
6950         enddo
6951         contr(j)=expfac
6952       enddo ! j
6953
6954 C As in the case of ebend, we want to avoid underflows in exponentiation and
6955 C subsequent NaNs and INFs in energy calculation.
6956 C Find the largest exponent
6957       emin=contr(1)
6958       do j=1,nlobit
6959         if (emin.gt.contr(j)) emin=contr(j)
6960       enddo
6961       emin=0.5D0*emin
6962
6963 C Compute the contribution to SC energy and derivatives
6964
6965       dersc12=0.0d0
6966       do j=1,nlobit
6967         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
6968         escloc_i=escloc_i+expfac
6969         do k=1,2
6970           dersc(k)=dersc(k)+Ax(k,j)*expfac
6971         enddo
6972         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6973      &            +gaussc(1,2,j,it))*expfac
6974         dersc(3)=0.0d0
6975       enddo
6976
6977       dersc(1)=dersc(1)/cos(theti)**2
6978       dersc12=dersc12/cos(theti)**2
6979       escloci=-(dlog(escloc_i)-emin)
6980       do j=1,2
6981         dersc(j)=dersc(j)/escloc_i
6982       enddo
6983       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6984       return
6985       end
6986 #else
6987 c----------------------------------------------------------------------------------
6988       subroutine esc(escloc)
6989 C Calculate the local energy of a side chain and its derivatives in the
6990 C corresponding virtual-bond valence angles THETA and the spherical angles
6991 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6992 C added by Urszula Kozlowska. 07/11/2007
6993 C
6994       implicit real*8 (a-h,o-z)
6995       include 'DIMENSIONS'
6996       include 'COMMON.GEO'
6997       include 'COMMON.LOCAL'
6998       include 'COMMON.VAR'
6999       include 'COMMON.SCROT'
7000       include 'COMMON.INTERACT'
7001       include 'COMMON.DERIV'
7002       include 'COMMON.CHAIN'
7003       include 'COMMON.IOUNITS'
7004       include 'COMMON.NAMES'
7005       include 'COMMON.FFIELD'
7006       include 'COMMON.CONTROL'
7007       include 'COMMON.VECTORS'
7008       double precision x_prime(3),y_prime(3),z_prime(3)
7009      &    , sumene,dsc_i,dp2_i,x(65),
7010      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7011      &    de_dxx,de_dyy,de_dzz,de_dt
7012       double precision s1_t,s1_6_t,s2_t,s2_6_t
7013       double precision
7014      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7015      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7016      & dt_dCi(3),dt_dCi1(3)
7017       common /sccalc/ time11,time12,time112,theti,it,nlobit
7018       delta=0.02d0*pi
7019       escloc=0.0D0
7020       do i=loc_start,loc_end
7021         costtab(i+1) =dcos(theta(i+1))
7022         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7023         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7024         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7025         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7026         cosfac=dsqrt(cosfac2)
7027         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7028         sinfac=dsqrt(sinfac2)
7029         it=itype(i)
7030         if (it.eq.10) goto 1
7031 c
7032 C  Compute the axes of tghe local cartesian coordinates system; store in
7033 c   x_prime, y_prime and z_prime
7034 c
7035         do j=1,3
7036           x_prime(j) = 0.00
7037           y_prime(j) = 0.00
7038           z_prime(j) = 0.00
7039         enddo
7040 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7041 C     &   dc_norm(3,i+nres)
7042         do j = 1,3
7043           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7044           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7045         enddo
7046         do j = 1,3
7047           z_prime(j) = -uz(j,i-1)
7048         enddo
7049 c       write (2,*) "i",i
7050 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7051 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7052 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7053 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7054 c      & " xy",scalar(x_prime(1),y_prime(1)),
7055 c      & " xz",scalar(x_prime(1),z_prime(1)),
7056 c      & " yy",scalar(y_prime(1),y_prime(1)),
7057 c      & " yz",scalar(y_prime(1),z_prime(1)),
7058 c      & " zz",scalar(z_prime(1),z_prime(1))
7059 c
7060 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7061 C to local coordinate system. Store in xx, yy, zz.
7062 c
7063         xx=0.0d0
7064         yy=0.0d0
7065         zz=0.0d0
7066         do j = 1,3
7067           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7068           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7069           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7070         enddo
7071
7072         xxtab(i)=xx
7073         yytab(i)=yy
7074         zztab(i)=zz
7075 C
7076 C Compute the energy of the ith side cbain
7077 C
7078 c        write (2,*) "xx",xx," yy",yy," zz",zz
7079         it=itype(i)
7080         do j = 1,65
7081           x(j) = sc_parmin(j,it)
7082         enddo
7083 #ifdef CHECK_COORD
7084 Cc diagnostics - remove later
7085         xx1 = dcos(alph(2))
7086         yy1 = dsin(alph(2))*dcos(omeg(2))
7087         zz1 = -dsin(alph(2))*dsin(omeg(2))
7088         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7089      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7090      &    xx1,yy1,zz1
7091 C,"  --- ", xx_w,yy_w,zz_w
7092 c end diagnostics
7093 #endif
7094         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7095      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7096      &   + x(10)*yy*zz
7097         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7098      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7099      & + x(20)*yy*zz
7100         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7101      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7102      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7103      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7104      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7105      &  +x(40)*xx*yy*zz
7106         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7107      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7108      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7109      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7110      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7111      &  +x(60)*xx*yy*zz
7112         dsc_i   = 0.743d0+x(61)
7113         dp2_i   = 1.9d0+x(62)
7114         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7115      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7116         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7117      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7118         s1=(1+x(63))/(0.1d0 + dscp1)
7119         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7120         s2=(1+x(65))/(0.1d0 + dscp2)
7121         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7122         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7123      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7124 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7125 c     &   sumene4,
7126 c     &   dscp1,dscp2,sumene
7127 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7128         escloc = escloc + sumene
7129 c        write (2,*) "i",i," escloc",sumene,escloc
7130 #ifdef DEBUG
7131 C
7132 C This section to check the numerical derivatives of the energy of ith side
7133 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7134 C #define DEBUG in the code to turn it on.
7135 C
7136         write (2,*) "sumene               =",sumene
7137         aincr=1.0d-7
7138         xxsave=xx
7139         xx=xx+aincr
7140         write (2,*) xx,yy,zz
7141         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7142         de_dxx_num=(sumenep-sumene)/aincr
7143         xx=xxsave
7144         write (2,*) "xx+ sumene from enesc=",sumenep
7145         yysave=yy
7146         yy=yy+aincr
7147         write (2,*) xx,yy,zz
7148         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7149         de_dyy_num=(sumenep-sumene)/aincr
7150         yy=yysave
7151         write (2,*) "yy+ sumene from enesc=",sumenep
7152         zzsave=zz
7153         zz=zz+aincr
7154         write (2,*) xx,yy,zz
7155         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7156         de_dzz_num=(sumenep-sumene)/aincr
7157         zz=zzsave
7158         write (2,*) "zz+ sumene from enesc=",sumenep
7159         costsave=cost2tab(i+1)
7160         sintsave=sint2tab(i+1)
7161         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7162         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7163         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7164         de_dt_num=(sumenep-sumene)/aincr
7165         write (2,*) " t+ sumene from enesc=",sumenep
7166         cost2tab(i+1)=costsave
7167         sint2tab(i+1)=sintsave
7168 C End of diagnostics section.
7169 #endif
7170 C
7171 C Compute the gradient of esc
7172 C
7173         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7174         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7175         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7176         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7177         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7178         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7179         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7180         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7181         pom1=(sumene3*sint2tab(i+1)+sumene1)
7182      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7183         pom2=(sumene4*cost2tab(i+1)+sumene2)
7184      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7185         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7186         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7187      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7188      &  +x(40)*yy*zz
7189         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7190         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7191      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7192      &  +x(60)*yy*zz
7193         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7194      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7195      &        +(pom1+pom2)*pom_dx
7196 #ifdef DEBUG
7197         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
7198 #endif
7199 C
7200         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7201         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7202      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7203      &  +x(40)*xx*zz
7204         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7205         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7206      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7207      &  +x(59)*zz**2 +x(60)*xx*zz
7208         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7209      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7210      &        +(pom1-pom2)*pom_dy
7211 #ifdef DEBUG
7212         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
7213 #endif
7214 C
7215         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7216      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7217      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7218      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7219      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7220      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7221      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7222      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7223 #ifdef DEBUG
7224         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
7225 #endif
7226 C
7227         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7228      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7229      &  +pom1*pom_dt1+pom2*pom_dt2
7230 #ifdef DEBUG
7231         write(2,*), "de_dt = ", de_dt,de_dt_num
7232 #endif
7233 c
7234 C
7235        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7236        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7237        cosfac2xx=cosfac2*xx
7238        sinfac2yy=sinfac2*yy
7239        do k = 1,3
7240          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7241      &      vbld_inv(i+1)
7242          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7243      &      vbld_inv(i)
7244          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7245          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7246 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7247 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7248 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7249 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7250          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7251          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7252          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7253          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7254          dZZ_Ci1(k)=0.0d0
7255          dZZ_Ci(k)=0.0d0
7256          do j=1,3
7257            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
7258            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
7259          enddo
7260
7261          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7262          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7263          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
7264 c
7265          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7266          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7267        enddo
7268
7269        do k=1,3
7270          dXX_Ctab(k,i)=dXX_Ci(k)
7271          dXX_C1tab(k,i)=dXX_Ci1(k)
7272          dYY_Ctab(k,i)=dYY_Ci(k)
7273          dYY_C1tab(k,i)=dYY_Ci1(k)
7274          dZZ_Ctab(k,i)=dZZ_Ci(k)
7275          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7276          dXX_XYZtab(k,i)=dXX_XYZ(k)
7277          dYY_XYZtab(k,i)=dYY_XYZ(k)
7278          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7279        enddo
7280
7281        do k = 1,3
7282 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7283 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7284 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7285 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7286 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7287 c     &    dt_dci(k)
7288 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7289 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7290          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7291      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7292          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7293      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7294          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7295      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7296        enddo
7297 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7298 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7299
7300 C to check gradient call subroutine check_grad
7301
7302     1 continue
7303       enddo
7304       return
7305       end
7306 c------------------------------------------------------------------------------
7307       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7308       implicit none
7309       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7310      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7311       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7312      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7313      &   + x(10)*yy*zz
7314       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7315      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7316      & + x(20)*yy*zz
7317       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7318      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7319      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7320      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7321      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7322      &  +x(40)*xx*yy*zz
7323       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7324      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7325      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7326      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7327      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7328      &  +x(60)*xx*yy*zz
7329       dsc_i   = 0.743d0+x(61)
7330       dp2_i   = 1.9d0+x(62)
7331       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7332      &          *(xx*cost2+yy*sint2))
7333       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7334      &          *(xx*cost2-yy*sint2))
7335       s1=(1+x(63))/(0.1d0 + dscp1)
7336       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7337       s2=(1+x(65))/(0.1d0 + dscp2)
7338       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7339       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7340      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7341       enesc=sumene
7342       return
7343       end
7344 #endif
7345 c------------------------------------------------------------------------------
7346       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7347 C
7348 C This procedure calculates two-body contact function g(rij) and its derivative:
7349 C
7350 C           eps0ij                                     !       x < -1
7351 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7352 C            0                                         !       x > 1
7353 C
7354 C where x=(rij-r0ij)/delta
7355 C
7356 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7357 C
7358       implicit none
7359       double precision rij,r0ij,eps0ij,fcont,fprimcont
7360       double precision x,x2,x4,delta
7361 c     delta=0.02D0*r0ij
7362 c      delta=0.2D0*r0ij
7363       x=(rij-r0ij)/delta
7364       if (x.lt.-1.0D0) then
7365         fcont=eps0ij
7366         fprimcont=0.0D0
7367       else if (x.le.1.0D0) then
7368         x2=x*x
7369         x4=x2*x2
7370         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7371         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7372       else
7373         fcont=0.0D0
7374         fprimcont=0.0D0
7375       endif
7376       return
7377       end
7378 c------------------------------------------------------------------------------
7379       subroutine splinthet(theti,delta,ss,ssder)
7380       implicit real*8 (a-h,o-z)
7381       include 'DIMENSIONS'
7382       include 'COMMON.VAR'
7383       include 'COMMON.GEO'
7384       thetup=pi-delta
7385       thetlow=delta
7386       if (theti.gt.pipol) then
7387         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7388       else
7389         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7390         ssder=-ssder
7391       endif
7392       return
7393       end
7394 c------------------------------------------------------------------------------
7395       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7396       implicit none
7397       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7398       double precision ksi,ksi2,ksi3,a1,a2,a3
7399       a1=fprim0*delta/(f1-f0)
7400       a2=3.0d0-2.0d0*a1
7401       a3=a1-2.0d0
7402       ksi=(x-x0)/delta
7403       ksi2=ksi*ksi
7404       ksi3=ksi2*ksi
7405       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7406       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7407       return
7408       end
7409 c------------------------------------------------------------------------------
7410       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7411       implicit none
7412       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7413       double precision ksi,ksi2,ksi3,a1,a2,a3
7414       ksi=(x-x0)/delta
7415       ksi2=ksi*ksi
7416       ksi3=ksi2*ksi
7417       a1=fprim0x*delta
7418       a2=3*(f1x-f0x)-2*fprim0x*delta
7419       a3=fprim0x*delta-2*(f1x-f0x)
7420       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7421       return
7422       end
7423 C-----------------------------------------------------------------------------
7424 #ifdef CRYST_TOR
7425 C-----------------------------------------------------------------------------
7426       subroutine etor(etors,edihcnstr)
7427       implicit real*8 (a-h,o-z)
7428       include 'DIMENSIONS'
7429       include 'COMMON.VAR'
7430       include 'COMMON.GEO'
7431       include 'COMMON.LOCAL'
7432       include 'COMMON.TORSION'
7433       include 'COMMON.INTERACT'
7434       include 'COMMON.DERIV'
7435       include 'COMMON.CHAIN'
7436       include 'COMMON.NAMES'
7437       include 'COMMON.IOUNITS'
7438       include 'COMMON.FFIELD'
7439       include 'COMMON.TORCNSTR'
7440       include 'COMMON.CONTROL'
7441       logical lprn
7442 C Set lprn=.true. for debugging
7443       lprn=.false.
7444 c      lprn=.true.
7445       etors=0.0D0
7446       do i=iphi_start,iphi_end
7447       etors_ii=0.0D0
7448         itori=itortyp(itype(i-2))
7449         itori1=itortyp(itype(i-1))
7450         phii=phi(i)
7451         gloci=0.0D0
7452 C Proline-Proline pair is a special case...
7453         if (itori.eq.3 .and. itori1.eq.3) then
7454           if (phii.gt.-dwapi3) then
7455             cosphi=dcos(3*phii)
7456             fac=1.0D0/(1.0D0-cosphi)
7457             etorsi=v1(1,3,3)*fac
7458             etorsi=etorsi+etorsi
7459             etors=etors+etorsi-v1(1,3,3)
7460             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7461             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7462           endif
7463           do j=1,3
7464             v1ij=v1(j+1,itori,itori1)
7465             v2ij=v2(j+1,itori,itori1)
7466             cosphi=dcos(j*phii)
7467             sinphi=dsin(j*phii)
7468             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7469             if (energy_dec) etors_ii=etors_ii+
7470      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7471             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7472           enddo
7473         else
7474           do j=1,nterm_old
7475             v1ij=v1(j,itori,itori1)
7476             v2ij=v2(j,itori,itori1)
7477             cosphi=dcos(j*phii)
7478             sinphi=dsin(j*phii)
7479             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7480             if (energy_dec) etors_ii=etors_ii+
7481      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7482             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7483           enddo
7484         endif
7485         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7486      &        'etor',i,etors_ii
7487         if (lprn)
7488      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7489      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7490      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7491         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7492         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7493       enddo
7494 ! 6/20/98 - dihedral angle constraints
7495       edihcnstr=0.0d0
7496       do i=1,ndih_constr
7497         itori=idih_constr(i)
7498         phii=phi(itori)
7499         difi=phii-phi0(i)
7500         if (difi.gt.drange(i)) then
7501           difi=difi-drange(i)
7502           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
7503           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
7504         else if (difi.lt.-drange(i)) then
7505           difi=difi+drange(i)
7506           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
7507           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
7508         endif
7509 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7510 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7511       enddo
7512 !      write (iout,*) 'edihcnstr',edihcnstr
7513       return
7514       end
7515 c------------------------------------------------------------------------------
7516       subroutine etor_d(etors_d)
7517       etors_d=0.0d0
7518       return
7519       end
7520 c----------------------------------------------------------------------------
7521 #else
7522       subroutine etor(etors,edihcnstr)
7523       implicit real*8 (a-h,o-z)
7524       include 'DIMENSIONS'
7525       include 'COMMON.VAR'
7526       include 'COMMON.GEO'
7527       include 'COMMON.LOCAL'
7528       include 'COMMON.TORSION'
7529       include 'COMMON.INTERACT'
7530       include 'COMMON.DERIV'
7531       include 'COMMON.CHAIN'
7532       include 'COMMON.NAMES'
7533       include 'COMMON.IOUNITS'
7534       include 'COMMON.FFIELD'
7535       include 'COMMON.TORCNSTR'
7536       include 'COMMON.CONTROL'
7537       logical lprn
7538 C Set lprn=.true. for debugging
7539       lprn=.false.
7540 c     lprn=.true.
7541       etors=0.0D0
7542       do i=iphi_start,iphi_end
7543       etors_ii=0.0D0
7544         itori=itortyp(itype(i-2))
7545         itori1=itortyp(itype(i-1))
7546         phii=phi(i)
7547         gloci=0.0D0
7548 C Regular cosine and sine terms
7549         do j=1,nterm(itori,itori1)
7550           v1ij=v1(j,itori,itori1)
7551           v2ij=v2(j,itori,itori1)
7552           cosphi=dcos(j*phii)
7553           sinphi=dsin(j*phii)
7554           etors=etors+v1ij*cosphi+v2ij*sinphi
7555           if (energy_dec) etors_ii=etors_ii+
7556      &                v1ij*cosphi+v2ij*sinphi
7557           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7558         enddo
7559 C Lorentz terms
7560 C                         v1
7561 C  E = SUM ----------------------------------- - v1
7562 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7563 C
7564         cosphi=dcos(0.5d0*phii)
7565         sinphi=dsin(0.5d0*phii)
7566         do j=1,nlor(itori,itori1)
7567           vl1ij=vlor1(j,itori,itori1)
7568           vl2ij=vlor2(j,itori,itori1)
7569           vl3ij=vlor3(j,itori,itori1)
7570           pom=vl2ij*cosphi+vl3ij*sinphi
7571           pom1=1.0d0/(pom*pom+1.0d0)
7572           etors=etors+vl1ij*pom1
7573           if (energy_dec) etors_ii=etors_ii+
7574      &                vl1ij*pom1
7575           pom=-pom*pom1*pom1
7576           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7577         enddo
7578 C Subtract the constant term
7579         etors=etors-v0(itori,itori1)
7580           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7581      &         'etor',i,etors_ii-v0(itori,itori1)
7582         if (lprn)
7583      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7584      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7585      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7586         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7587 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7588       enddo
7589 ! 6/20/98 - dihedral angle constraints
7590       edihcnstr=0.0d0
7591 c      do i=1,ndih_constr
7592       do i=idihconstr_start,idihconstr_end
7593         itori=idih_constr(i)
7594         phii=phi(itori)
7595         difi=pinorm(phii-phi0(i))
7596         if (difi.gt.drange(i)) then
7597           difi=difi-drange(i)
7598           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
7599           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
7600         else if (difi.lt.-drange(i)) then
7601           difi=difi+drange(i)
7602           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
7603           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
7604         else
7605           difi=0.0
7606         endif
7607 c        write (iout,*) "gloci", gloc(i-3,icg)
7608 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
7609 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
7610 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7611       enddo
7612 cd       write (iout,*) 'edihcnstr',edihcnstr
7613       return
7614       end
7615 c----------------------------------------------------------------------------
7616       subroutine etor_d(etors_d)
7617 C 6/23/01 Compute double torsional energy
7618       implicit real*8 (a-h,o-z)
7619       include 'DIMENSIONS'
7620       include 'COMMON.VAR'
7621       include 'COMMON.GEO'
7622       include 'COMMON.LOCAL'
7623       include 'COMMON.TORSION'
7624       include 'COMMON.INTERACT'
7625       include 'COMMON.DERIV'
7626       include 'COMMON.CHAIN'
7627       include 'COMMON.NAMES'
7628       include 'COMMON.IOUNITS'
7629       include 'COMMON.FFIELD'
7630       include 'COMMON.TORCNSTR'
7631       logical lprn
7632 C Set lprn=.true. for debugging
7633       lprn=.false.
7634 c     lprn=.true.
7635       etors_d=0.0D0
7636       do i=iphid_start,iphid_end
7637         itori=itortyp(itype(i-2))
7638         itori1=itortyp(itype(i-1))
7639         itori2=itortyp(itype(i))
7640         phii=phi(i)
7641         phii1=phi(i+1)
7642         gloci1=0.0D0
7643         gloci2=0.0D0
7644         do j=1,ntermd_1(itori,itori1,itori2)
7645           v1cij=v1c(1,j,itori,itori1,itori2)
7646           v1sij=v1s(1,j,itori,itori1,itori2)
7647           v2cij=v1c(2,j,itori,itori1,itori2)
7648           v2sij=v1s(2,j,itori,itori1,itori2)
7649           cosphi1=dcos(j*phii)
7650           sinphi1=dsin(j*phii)
7651           cosphi2=dcos(j*phii1)
7652           sinphi2=dsin(j*phii1)
7653           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7654      &     v2cij*cosphi2+v2sij*sinphi2
7655           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7656           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7657         enddo
7658         do k=2,ntermd_2(itori,itori1,itori2)
7659           do l=1,k-1
7660             v1cdij = v2c(k,l,itori,itori1,itori2)
7661             v2cdij = v2c(l,k,itori,itori1,itori2)
7662             v1sdij = v2s(k,l,itori,itori1,itori2)
7663             v2sdij = v2s(l,k,itori,itori1,itori2)
7664             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7665             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7666             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7667             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7668             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7669      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7670             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7671      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7672             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7673      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7674           enddo
7675         enddo
7676         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7677         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7678 c        write (iout,*) "gloci", gloc(i-3,icg)
7679       enddo
7680       return
7681       end
7682 #endif
7683 c------------------------------------------------------------------------------
7684       subroutine eback_sc_corr(esccor)
7685 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7686 c        conformational states; temporarily implemented as differences
7687 c        between UNRES torsional potentials (dependent on three types of
7688 c        residues) and the torsional potentials dependent on all 20 types
7689 c        of residues computed from AM1  energy surfaces of terminally-blocked
7690 c        amino-acid residues.
7691       implicit real*8 (a-h,o-z)
7692       include 'DIMENSIONS'
7693       include 'COMMON.VAR'
7694       include 'COMMON.GEO'
7695       include 'COMMON.LOCAL'
7696       include 'COMMON.TORSION'
7697       include 'COMMON.SCCOR'
7698       include 'COMMON.INTERACT'
7699       include 'COMMON.DERIV'
7700       include 'COMMON.CHAIN'
7701       include 'COMMON.NAMES'
7702       include 'COMMON.IOUNITS'
7703       include 'COMMON.FFIELD'
7704       include 'COMMON.CONTROL'
7705       logical lprn
7706 C Set lprn=.true. for debugging
7707       lprn=.false.
7708 c      lprn=.true.
7709 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7710       esccor=0.0D0
7711       do i=itau_start,itau_end
7712         esccor_ii=0.0D0
7713         isccori=isccortyp(itype(i-2))
7714         isccori1=isccortyp(itype(i-1))
7715         phii=phi(i)
7716 cccc  Added 9 May 2012
7717 cc Tauangle is torsional engle depending on the value of first digit
7718 c(see comment below)
7719 cc Omicron is flat angle depending on the value of first digit
7720 c(see comment below)
7721
7722
7723         do intertyp=1,3 !intertyp
7724 cc Added 09 May 2012 (Adasko)
7725 cc  Intertyp means interaction type of backbone mainchain correlation:
7726 c   1 = SC...Ca...Ca...Ca
7727 c   2 = Ca...Ca...Ca...SC
7728 c   3 = SC...Ca...Ca...SCi
7729         gloci=0.0D0
7730         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7731      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
7732      &      (itype(i-1).eq.21)))
7733      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7734      &     .or.(itype(i-2).eq.21)))
7735      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7736      &      (itype(i-1).eq.21)))) cycle
7737         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
7738         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
7739      & cycle
7740         do j=1,nterm_sccor(isccori,isccori1)
7741           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7742           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7743           cosphi=dcos(j*tauangle(intertyp,i))
7744           sinphi=dsin(j*tauangle(intertyp,i))
7745           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7746           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7747         enddo
7748         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7749 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
7750 c     &gloc_sc(intertyp,i-3,icg)
7751         if (lprn)
7752      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7753      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7754      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
7755      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
7756         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7757        enddo !intertyp
7758       enddo
7759 c        do i=1,nres
7760 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
7761 c        enddo
7762       return
7763       end
7764 c----------------------------------------------------------------------------
7765       subroutine multibody(ecorr)
7766 C This subroutine calculates multi-body contributions to energy following
7767 C the idea of Skolnick et al. If side chains I and J make a contact and
7768 C at the same time side chains I+1 and J+1 make a contact, an extra
7769 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7770       implicit real*8 (a-h,o-z)
7771       include 'DIMENSIONS'
7772       include 'COMMON.IOUNITS'
7773       include 'COMMON.DERIV'
7774       include 'COMMON.INTERACT'
7775       include 'COMMON.CONTACTS'
7776       double precision gx(3),gx1(3)
7777       logical lprn
7778
7779 C Set lprn=.true. for debugging
7780       lprn=.false.
7781
7782       if (lprn) then
7783         write (iout,'(a)') 'Contact function values:'
7784         do i=nnt,nct-2
7785           write (iout,'(i2,20(1x,i2,f10.5))')
7786      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7787         enddo
7788       endif
7789       ecorr=0.0D0
7790       do i=nnt,nct
7791         do j=1,3
7792           gradcorr(j,i)=0.0D0
7793           gradxorr(j,i)=0.0D0
7794         enddo
7795       enddo
7796       do i=nnt,nct-2
7797
7798         DO ISHIFT = 3,4
7799
7800         i1=i+ishift
7801         num_conti=num_cont(i)
7802         num_conti1=num_cont(i1)
7803         do jj=1,num_conti
7804           j=jcont(jj,i)
7805           do kk=1,num_conti1
7806             j1=jcont(kk,i1)
7807             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7808 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7809 cd   &                   ' ishift=',ishift
7810 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7811 C The system gains extra energy.
7812               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7813             endif   ! j1==j+-ishift
7814           enddo     ! kk
7815         enddo       ! jj
7816
7817         ENDDO ! ISHIFT
7818
7819       enddo         ! i
7820       return
7821       end
7822 c------------------------------------------------------------------------------
7823       double precision function esccorr(i,j,k,l,jj,kk)
7824       implicit real*8 (a-h,o-z)
7825       include 'DIMENSIONS'
7826       include 'COMMON.IOUNITS'
7827       include 'COMMON.DERIV'
7828       include 'COMMON.INTERACT'
7829       include 'COMMON.CONTACTS'
7830       double precision gx(3),gx1(3)
7831       logical lprn
7832       lprn=.false.
7833       eij=facont(jj,i)
7834       ekl=facont(kk,k)
7835 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7836 C Calculate the multi-body contribution to energy.
7837 C Calculate multi-body contributions to the gradient.
7838 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7839 cd   & k,l,(gacont(m,kk,k),m=1,3)
7840       do m=1,3
7841         gx(m) =ekl*gacont(m,jj,i)
7842         gx1(m)=eij*gacont(m,kk,k)
7843         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7844         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7845         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7846         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7847       enddo
7848       do m=i,j-1
7849         do ll=1,3
7850           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7851         enddo
7852       enddo
7853       do m=k,l-1
7854         do ll=1,3
7855           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7856         enddo
7857       enddo
7858       esccorr=-eij*ekl
7859       return
7860       end
7861 c------------------------------------------------------------------------------
7862       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7863 C This subroutine calculates multi-body contributions to hydrogen-bonding
7864       implicit real*8 (a-h,o-z)
7865       include 'DIMENSIONS'
7866       include 'COMMON.IOUNITS'
7867 #ifdef MPI
7868       include "mpif.h"
7869       parameter (max_cont=maxconts)
7870       parameter (max_dim=26)
7871       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7872       double precision zapas(max_dim,maxconts,max_fg_procs),
7873      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7874       common /przechowalnia/ zapas
7875       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7876      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7877 #endif
7878       include 'COMMON.SETUP'
7879       include 'COMMON.FFIELD'
7880       include 'COMMON.DERIV'
7881       include 'COMMON.INTERACT'
7882       include 'COMMON.CONTACTS'
7883       include 'COMMON.CONTROL'
7884       include 'COMMON.LOCAL'
7885       double precision gx(3),gx1(3),time00
7886       logical lprn,ldone
7887
7888 C Set lprn=.true. for debugging
7889       lprn=.false.
7890 #ifdef MPI
7891       n_corr=0
7892       n_corr1=0
7893       if (nfgtasks.le.1) goto 30
7894       if (lprn) then
7895         write (iout,'(a)') 'Contact function values before RECEIVE:'
7896         do i=nnt,nct-2
7897           write (iout,'(2i3,50(1x,i2,f5.2))')
7898      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7899      &    j=1,num_cont_hb(i))
7900         enddo
7901       endif
7902       call flush(iout)
7903       do i=1,ntask_cont_from
7904         ncont_recv(i)=0
7905       enddo
7906       do i=1,ntask_cont_to
7907         ncont_sent(i)=0
7908       enddo
7909 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7910 c     & ntask_cont_to
7911 C Make the list of contacts to send to send to other procesors
7912 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7913 c      call flush(iout)
7914       do i=iturn3_start,iturn3_end
7915 c        write (iout,*) "make contact list turn3",i," num_cont",
7916 c     &    num_cont_hb(i)
7917         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7918       enddo
7919       do i=iturn4_start,iturn4_end
7920 c        write (iout,*) "make contact list turn4",i," num_cont",
7921 c     &   num_cont_hb(i)
7922         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7923       enddo
7924       do ii=1,nat_sent
7925         i=iat_sent(ii)
7926 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7927 c     &    num_cont_hb(i)
7928         do j=1,num_cont_hb(i)
7929         do k=1,4
7930           jjc=jcont_hb(j,i)
7931           iproc=iint_sent_local(k,jjc,ii)
7932 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7933           if (iproc.gt.0) then
7934             ncont_sent(iproc)=ncont_sent(iproc)+1
7935             nn=ncont_sent(iproc)
7936             zapas(1,nn,iproc)=i
7937             zapas(2,nn,iproc)=jjc
7938             zapas(3,nn,iproc)=facont_hb(j,i)
7939             zapas(4,nn,iproc)=ees0p(j,i)
7940             zapas(5,nn,iproc)=ees0m(j,i)
7941             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7942             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7943             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7944             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7945             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7946             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7947             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7948             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7949             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7950             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7951             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7952             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7953             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7954             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7955             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7956             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7957             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7958             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7959             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7960             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7961             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7962           endif
7963         enddo
7964         enddo
7965       enddo
7966       if (lprn) then
7967       write (iout,*)
7968      &  "Numbers of contacts to be sent to other processors",
7969      &  (ncont_sent(i),i=1,ntask_cont_to)
7970       write (iout,*) "Contacts sent"
7971       do ii=1,ntask_cont_to
7972         nn=ncont_sent(ii)
7973         iproc=itask_cont_to(ii)
7974         write (iout,*) nn," contacts to processor",iproc,
7975      &   " of CONT_TO_COMM group"
7976         do i=1,nn
7977           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7978         enddo
7979       enddo
7980       call flush(iout)
7981       endif
7982       CorrelType=477
7983       CorrelID=fg_rank+1
7984       CorrelType1=478
7985       CorrelID1=nfgtasks+fg_rank+1
7986       ireq=0
7987 C Receive the numbers of needed contacts from other processors
7988       do ii=1,ntask_cont_from
7989         iproc=itask_cont_from(ii)
7990         ireq=ireq+1
7991         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7992      &    FG_COMM,req(ireq),IERR)
7993       enddo
7994 c      write (iout,*) "IRECV ended"
7995 c      call flush(iout)
7996 C Send the number of contacts needed by other processors
7997       do ii=1,ntask_cont_to
7998         iproc=itask_cont_to(ii)
7999         ireq=ireq+1
8000         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8001      &    FG_COMM,req(ireq),IERR)
8002       enddo
8003 c      write (iout,*) "ISEND ended"
8004 c      write (iout,*) "number of requests (nn)",ireq
8005       call flush(iout)
8006       if (ireq.gt.0)
8007      &  call MPI_Waitall(ireq,req,status_array,ierr)
8008 c      write (iout,*)
8009 c     &  "Numbers of contacts to be received from other processors",
8010 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8011 c      call flush(iout)
8012 C Receive contacts
8013       ireq=0
8014       do ii=1,ntask_cont_from
8015         iproc=itask_cont_from(ii)
8016         nn=ncont_recv(ii)
8017 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8018 c     &   " of CONT_TO_COMM group"
8019         call flush(iout)
8020         if (nn.gt.0) then
8021           ireq=ireq+1
8022           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8023      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8024 c          write (iout,*) "ireq,req",ireq,req(ireq)
8025         endif
8026       enddo
8027 C Send the contacts to processors that need them
8028       do ii=1,ntask_cont_to
8029         iproc=itask_cont_to(ii)
8030         nn=ncont_sent(ii)
8031 c        write (iout,*) nn," contacts to processor",iproc,
8032 c     &   " of CONT_TO_COMM group"
8033         if (nn.gt.0) then
8034           ireq=ireq+1
8035           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8036      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8037 c          write (iout,*) "ireq,req",ireq,req(ireq)
8038 c          do i=1,nn
8039 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8040 c          enddo
8041         endif
8042       enddo
8043 c      write (iout,*) "number of requests (contacts)",ireq
8044 c      write (iout,*) "req",(req(i),i=1,4)
8045 c      call flush(iout)
8046       if (ireq.gt.0)
8047      & call MPI_Waitall(ireq,req,status_array,ierr)
8048       do iii=1,ntask_cont_from
8049         iproc=itask_cont_from(iii)
8050         nn=ncont_recv(iii)
8051         if (lprn) then
8052         write (iout,*) "Received",nn," contacts from processor",iproc,
8053      &   " of CONT_FROM_COMM group"
8054         call flush(iout)
8055         do i=1,nn
8056           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8057         enddo
8058         call flush(iout)
8059         endif
8060         do i=1,nn
8061           ii=zapas_recv(1,i,iii)
8062 c Flag the received contacts to prevent double-counting
8063           jj=-zapas_recv(2,i,iii)
8064 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8065 c          call flush(iout)
8066           nnn=num_cont_hb(ii)+1
8067           num_cont_hb(ii)=nnn
8068           jcont_hb(nnn,ii)=jj
8069           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8070           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8071           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8072           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8073           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8074           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8075           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8076           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8077           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8078           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8079           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8080           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8081           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8082           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8083           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8084           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8085           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8086           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8087           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8088           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8089           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8090           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8091           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8092           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8093         enddo
8094       enddo
8095       call flush(iout)
8096       if (lprn) then
8097         write (iout,'(a)') 'Contact function values after receive:'
8098         do i=nnt,nct-2
8099           write (iout,'(2i3,50(1x,i3,f5.2))')
8100      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8101      &    j=1,num_cont_hb(i))
8102         enddo
8103         call flush(iout)
8104       endif
8105    30 continue
8106 #endif
8107       if (lprn) then
8108         write (iout,'(a)') 'Contact function values:'
8109         do i=nnt,nct-2
8110           write (iout,'(2i3,50(1x,i3,f5.2))')
8111      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8112      &    j=1,num_cont_hb(i))
8113         enddo
8114       endif
8115       ecorr=0.0D0
8116 C Remove the loop below after debugging !!!
8117       do i=nnt,nct
8118         do j=1,3
8119           gradcorr(j,i)=0.0D0
8120           gradxorr(j,i)=0.0D0
8121         enddo
8122       enddo
8123 C Calculate the local-electrostatic correlation terms
8124       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8125         i1=i+1
8126         num_conti=num_cont_hb(i)
8127         num_conti1=num_cont_hb(i+1)
8128         do jj=1,num_conti
8129           j=jcont_hb(jj,i)
8130           jp=iabs(j)
8131           do kk=1,num_conti1
8132             j1=jcont_hb(kk,i1)
8133             jp1=iabs(j1)
8134 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8135 c     &         ' jj=',jj,' kk=',kk
8136             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8137      &          .or. j.lt.0 .and. j1.gt.0) .and.
8138      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8139 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8140 C The system gains extra energy.
8141               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8142               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8143      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8144               n_corr=n_corr+1
8145             else if (j1.eq.j) then
8146 C Contacts I-J and I-(J+1) occur simultaneously.
8147 C The system loses extra energy.
8148 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8149             endif
8150           enddo ! kk
8151           do kk=1,num_conti
8152             j1=jcont_hb(kk,i)
8153 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8154 c    &         ' jj=',jj,' kk=',kk
8155             if (j1.eq.j+1) then
8156 C Contacts I-J and (I+1)-J occur simultaneously.
8157 C The system loses extra energy.
8158 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8159             endif ! j1==j+1
8160           enddo ! kk
8161         enddo ! jj
8162       enddo ! i
8163       return
8164       end
8165 c------------------------------------------------------------------------------
8166       subroutine add_hb_contact(ii,jj,itask)
8167       implicit real*8 (a-h,o-z)
8168       include "DIMENSIONS"
8169       include "COMMON.IOUNITS"
8170       integer max_cont
8171       integer max_dim
8172       parameter (max_cont=maxconts)
8173       parameter (max_dim=26)
8174       include "COMMON.CONTACTS"
8175       double precision zapas(max_dim,maxconts,max_fg_procs),
8176      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8177       common /przechowalnia/ zapas
8178       integer i,j,ii,jj,iproc,itask(4),nn
8179 c      write (iout,*) "itask",itask
8180       do i=1,2
8181         iproc=itask(i)
8182         if (iproc.gt.0) then
8183           do j=1,num_cont_hb(ii)
8184             jjc=jcont_hb(j,ii)
8185 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8186             if (jjc.eq.jj) then
8187               ncont_sent(iproc)=ncont_sent(iproc)+1
8188               nn=ncont_sent(iproc)
8189               zapas(1,nn,iproc)=ii
8190               zapas(2,nn,iproc)=jjc
8191               zapas(3,nn,iproc)=facont_hb(j,ii)
8192               zapas(4,nn,iproc)=ees0p(j,ii)
8193               zapas(5,nn,iproc)=ees0m(j,ii)
8194               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8195               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8196               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8197               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8198               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8199               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8200               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8201               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8202               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8203               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8204               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8205               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8206               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8207               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8208               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8209               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8210               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8211               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8212               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8213               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8214               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8215               exit
8216             endif
8217           enddo
8218         endif
8219       enddo
8220       return
8221       end
8222 c------------------------------------------------------------------------------
8223       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8224      &  n_corr1)
8225 C This subroutine calculates multi-body contributions to hydrogen-bonding
8226       implicit real*8 (a-h,o-z)
8227       include 'DIMENSIONS'
8228       include 'COMMON.IOUNITS'
8229 #ifdef MPI
8230       include "mpif.h"
8231       parameter (max_cont=maxconts)
8232       parameter (max_dim=70)
8233       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8234       double precision zapas(max_dim,maxconts,max_fg_procs),
8235      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8236       common /przechowalnia/ zapas
8237       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8238      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8239 #endif
8240       include 'COMMON.SETUP'
8241       include 'COMMON.FFIELD'
8242       include 'COMMON.DERIV'
8243       include 'COMMON.LOCAL'
8244       include 'COMMON.INTERACT'
8245       include 'COMMON.CONTACTS'
8246       include 'COMMON.CHAIN'
8247       include 'COMMON.CONTROL'
8248       double precision gx(3),gx1(3)
8249       integer num_cont_hb_old(maxres)
8250       logical lprn,ldone
8251       double precision eello4,eello5,eelo6,eello_turn6
8252       external eello4,eello5,eello6,eello_turn6
8253 C Set lprn=.true. for debugging
8254       lprn=.false.
8255       eturn6=0.0d0
8256 #ifdef MPI
8257       do i=1,nres
8258         num_cont_hb_old(i)=num_cont_hb(i)
8259       enddo
8260       n_corr=0
8261       n_corr1=0
8262       if (nfgtasks.le.1) goto 30
8263       if (lprn) then
8264         write (iout,'(a)') 'Contact function values before RECEIVE:'
8265         do i=nnt,nct-2
8266           write (iout,'(2i3,50(1x,i2,f5.2))')
8267      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8268      &    j=1,num_cont_hb(i))
8269         enddo
8270       endif
8271       call flush(iout)
8272       do i=1,ntask_cont_from
8273         ncont_recv(i)=0
8274       enddo
8275       do i=1,ntask_cont_to
8276         ncont_sent(i)=0
8277       enddo
8278 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8279 c     & ntask_cont_to
8280 C Make the list of contacts to send to send to other procesors
8281       do i=iturn3_start,iturn3_end
8282 c        write (iout,*) "make contact list turn3",i," num_cont",
8283 c     &    num_cont_hb(i)
8284         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8285       enddo
8286       do i=iturn4_start,iturn4_end
8287 c        write (iout,*) "make contact list turn4",i," num_cont",
8288 c     &   num_cont_hb(i)
8289         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8290       enddo
8291       do ii=1,nat_sent
8292         i=iat_sent(ii)
8293 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8294 c     &    num_cont_hb(i)
8295         do j=1,num_cont_hb(i)
8296         do k=1,4
8297           jjc=jcont_hb(j,i)
8298           iproc=iint_sent_local(k,jjc,ii)
8299 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8300           if (iproc.ne.0) then
8301             ncont_sent(iproc)=ncont_sent(iproc)+1
8302             nn=ncont_sent(iproc)
8303             zapas(1,nn,iproc)=i
8304             zapas(2,nn,iproc)=jjc
8305             zapas(3,nn,iproc)=d_cont(j,i)
8306             ind=3
8307             do kk=1,3
8308               ind=ind+1
8309               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8310             enddo
8311             do kk=1,2
8312               do ll=1,2
8313                 ind=ind+1
8314                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8315               enddo
8316             enddo
8317             do jj=1,5
8318               do kk=1,3
8319                 do ll=1,2
8320                   do mm=1,2
8321                     ind=ind+1
8322                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8323                   enddo
8324                 enddo
8325               enddo
8326             enddo
8327           endif
8328         enddo
8329         enddo
8330       enddo
8331       if (lprn) then
8332       write (iout,*)
8333      &  "Numbers of contacts to be sent to other processors",
8334      &  (ncont_sent(i),i=1,ntask_cont_to)
8335       write (iout,*) "Contacts sent"
8336       do ii=1,ntask_cont_to
8337         nn=ncont_sent(ii)
8338         iproc=itask_cont_to(ii)
8339         write (iout,*) nn," contacts to processor",iproc,
8340      &   " of CONT_TO_COMM group"
8341         do i=1,nn
8342           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8343         enddo
8344       enddo
8345       call flush(iout)
8346       endif
8347       CorrelType=477
8348       CorrelID=fg_rank+1
8349       CorrelType1=478
8350       CorrelID1=nfgtasks+fg_rank+1
8351       ireq=0
8352 C Receive the numbers of needed contacts from other processors
8353       do ii=1,ntask_cont_from
8354         iproc=itask_cont_from(ii)
8355         ireq=ireq+1
8356         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8357      &    FG_COMM,req(ireq),IERR)
8358       enddo
8359 c      write (iout,*) "IRECV ended"
8360 c      call flush(iout)
8361 C Send the number of contacts needed by other processors
8362       do ii=1,ntask_cont_to
8363         iproc=itask_cont_to(ii)
8364         ireq=ireq+1
8365         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8366      &    FG_COMM,req(ireq),IERR)
8367       enddo
8368 c      write (iout,*) "ISEND ended"
8369 c      write (iout,*) "number of requests (nn)",ireq
8370       call flush(iout)
8371       if (ireq.gt.0)
8372      &  call MPI_Waitall(ireq,req,status_array,ierr)
8373 c      write (iout,*)
8374 c     &  "Numbers of contacts to be received from other processors",
8375 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8376 c      call flush(iout)
8377 C Receive contacts
8378       ireq=0
8379       do ii=1,ntask_cont_from
8380         iproc=itask_cont_from(ii)
8381         nn=ncont_recv(ii)
8382 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8383 c     &   " of CONT_TO_COMM group"
8384         call flush(iout)
8385         if (nn.gt.0) then
8386           ireq=ireq+1
8387           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8388      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8389 c          write (iout,*) "ireq,req",ireq,req(ireq)
8390         endif
8391       enddo
8392 C Send the contacts to processors that need them
8393       do ii=1,ntask_cont_to
8394         iproc=itask_cont_to(ii)
8395         nn=ncont_sent(ii)
8396 c        write (iout,*) nn," contacts to processor",iproc,
8397 c     &   " of CONT_TO_COMM group"
8398         if (nn.gt.0) then
8399           ireq=ireq+1
8400           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8401      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8402 c          write (iout,*) "ireq,req",ireq,req(ireq)
8403 c          do i=1,nn
8404 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8405 c          enddo
8406         endif
8407       enddo
8408 c      write (iout,*) "number of requests (contacts)",ireq
8409 c      write (iout,*) "req",(req(i),i=1,4)
8410 c      call flush(iout)
8411       if (ireq.gt.0)
8412      & call MPI_Waitall(ireq,req,status_array,ierr)
8413       do iii=1,ntask_cont_from
8414         iproc=itask_cont_from(iii)
8415         nn=ncont_recv(iii)
8416         if (lprn) then
8417         write (iout,*) "Received",nn," contacts from processor",iproc,
8418      &   " of CONT_FROM_COMM group"
8419         call flush(iout)
8420         do i=1,nn
8421           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8422         enddo
8423         call flush(iout)
8424         endif
8425         do i=1,nn
8426           ii=zapas_recv(1,i,iii)
8427 c Flag the received contacts to prevent double-counting
8428           jj=-zapas_recv(2,i,iii)
8429 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8430 c          call flush(iout)
8431           nnn=num_cont_hb(ii)+1
8432           num_cont_hb(ii)=nnn
8433           jcont_hb(nnn,ii)=jj
8434           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8435           ind=3
8436           do kk=1,3
8437             ind=ind+1
8438             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8439           enddo
8440           do kk=1,2
8441             do ll=1,2
8442               ind=ind+1
8443               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8444             enddo
8445           enddo
8446           do jj=1,5
8447             do kk=1,3
8448               do ll=1,2
8449                 do mm=1,2
8450                   ind=ind+1
8451                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8452                 enddo
8453               enddo
8454             enddo
8455           enddo
8456         enddo
8457       enddo
8458       call flush(iout)
8459       if (lprn) then
8460         write (iout,'(a)') 'Contact function values after receive:'
8461         do i=nnt,nct-2
8462           write (iout,'(2i3,50(1x,i3,5f6.3))')
8463      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8464      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8465         enddo
8466         call flush(iout)
8467       endif
8468    30 continue
8469 #endif
8470       if (lprn) then
8471         write (iout,'(a)') 'Contact function values:'
8472         do i=nnt,nct-2
8473           write (iout,'(2i3,50(1x,i2,5f6.3))')
8474      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8475      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8476         enddo
8477       endif
8478       ecorr=0.0D0
8479       ecorr5=0.0d0
8480       ecorr6=0.0d0
8481 C Remove the loop below after debugging !!!
8482       do i=nnt,nct
8483         do j=1,3
8484           gradcorr(j,i)=0.0D0
8485           gradxorr(j,i)=0.0D0
8486         enddo
8487       enddo
8488 C Calculate the dipole-dipole interaction energies
8489       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8490       do i=iatel_s,iatel_e+1
8491         num_conti=num_cont_hb(i)
8492         do jj=1,num_conti
8493           j=jcont_hb(jj,i)
8494 #ifdef MOMENT
8495           call dipole(i,j,jj)
8496 #endif
8497         enddo
8498       enddo
8499       endif
8500 C Calculate the local-electrostatic correlation terms
8501 c                write (iout,*) "gradcorr5 in eello5 before loop"
8502 c                do iii=1,nres
8503 c                  write (iout,'(i5,3f10.5)')
8504 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8505 c                enddo
8506       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8507 c        write (iout,*) "corr loop i",i
8508         i1=i+1
8509         num_conti=num_cont_hb(i)
8510         num_conti1=num_cont_hb(i+1)
8511         do jj=1,num_conti
8512           j=jcont_hb(jj,i)
8513           jp=iabs(j)
8514           do kk=1,num_conti1
8515             j1=jcont_hb(kk,i1)
8516             jp1=iabs(j1)
8517 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8518 c     &         ' jj=',jj,' kk=',kk
8519 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8520             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8521      &          .or. j.lt.0 .and. j1.gt.0) .and.
8522      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8523 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8524 C The system gains extra energy.
8525               n_corr=n_corr+1
8526               sqd1=dsqrt(d_cont(jj,i))
8527               sqd2=dsqrt(d_cont(kk,i1))
8528               sred_geom = sqd1*sqd2
8529               IF (sred_geom.lt.cutoff_corr) THEN
8530                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8531      &            ekont,fprimcont)
8532 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8533 cd     &         ' jj=',jj,' kk=',kk
8534                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8535                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8536                 do l=1,3
8537                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8538                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8539                 enddo
8540                 n_corr1=n_corr1+1
8541 cd               write (iout,*) 'sred_geom=',sred_geom,
8542 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8543 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8544 cd               write (iout,*) "g_contij",g_contij
8545 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8546 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8547                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8548                 if (wcorr4.gt.0.0d0)
8549      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8550                   if (energy_dec.and.wcorr4.gt.0.0d0)
8551      1                 write (iout,'(a6,4i5,0pf7.3)')
8552      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8553 c                write (iout,*) "gradcorr5 before eello5"
8554 c                do iii=1,nres
8555 c                  write (iout,'(i5,3f10.5)')
8556 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8557 c                enddo
8558                 if (wcorr5.gt.0.0d0)
8559      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8560 c                write (iout,*) "gradcorr5 after eello5"
8561 c                do iii=1,nres
8562 c                  write (iout,'(i5,3f10.5)')
8563 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8564 c                enddo
8565                   if (energy_dec.and.wcorr5.gt.0.0d0)
8566      1                 write (iout,'(a6,4i5,0pf7.3)')
8567      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8568 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8569 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8570                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8571      &               .or. wturn6.eq.0.0d0))then
8572 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8573                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8574                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8575      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8576 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8577 cd     &            'ecorr6=',ecorr6
8578 cd                write (iout,'(4e15.5)') sred_geom,
8579 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8580 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8581 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8582                 else if (wturn6.gt.0.0d0
8583      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8584 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8585                   eturn6=eturn6+eello_turn6(i,jj,kk)
8586                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8587      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8588 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8589                 endif
8590               ENDIF
8591 1111          continue
8592             endif
8593           enddo ! kk
8594         enddo ! jj
8595       enddo ! i
8596       do i=1,nres
8597         num_cont_hb(i)=num_cont_hb_old(i)
8598       enddo
8599 c                write (iout,*) "gradcorr5 in eello5"
8600 c                do iii=1,nres
8601 c                  write (iout,'(i5,3f10.5)')
8602 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8603 c                enddo
8604       return
8605       end
8606 c------------------------------------------------------------------------------
8607       subroutine add_hb_contact_eello(ii,jj,itask)
8608       implicit real*8 (a-h,o-z)
8609       include "DIMENSIONS"
8610       include "COMMON.IOUNITS"
8611       integer max_cont
8612       integer max_dim
8613       parameter (max_cont=maxconts)
8614       parameter (max_dim=70)
8615       include "COMMON.CONTACTS"
8616       double precision zapas(max_dim,maxconts,max_fg_procs),
8617      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8618       common /przechowalnia/ zapas
8619       integer i,j,ii,jj,iproc,itask(4),nn
8620 c      write (iout,*) "itask",itask
8621       do i=1,2
8622         iproc=itask(i)
8623         if (iproc.gt.0) then
8624           do j=1,num_cont_hb(ii)
8625             jjc=jcont_hb(j,ii)
8626 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8627             if (jjc.eq.jj) then
8628               ncont_sent(iproc)=ncont_sent(iproc)+1
8629               nn=ncont_sent(iproc)
8630               zapas(1,nn,iproc)=ii
8631               zapas(2,nn,iproc)=jjc
8632               zapas(3,nn,iproc)=d_cont(j,ii)
8633               ind=3
8634               do kk=1,3
8635                 ind=ind+1
8636                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8637               enddo
8638               do kk=1,2
8639                 do ll=1,2
8640                   ind=ind+1
8641                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8642                 enddo
8643               enddo
8644               do jj=1,5
8645                 do kk=1,3
8646                   do ll=1,2
8647                     do mm=1,2
8648                       ind=ind+1
8649                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8650                     enddo
8651                   enddo
8652                 enddo
8653               enddo
8654               exit
8655             endif
8656           enddo
8657         endif
8658       enddo
8659       return
8660       end
8661 c------------------------------------------------------------------------------
8662       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8663       implicit real*8 (a-h,o-z)
8664       include 'DIMENSIONS'
8665       include 'COMMON.IOUNITS'
8666       include 'COMMON.DERIV'
8667       include 'COMMON.INTERACT'
8668       include 'COMMON.CONTACTS'
8669       double precision gx(3),gx1(3)
8670       logical lprn
8671       lprn=.false.
8672       eij=facont_hb(jj,i)
8673       ekl=facont_hb(kk,k)
8674       ees0pij=ees0p(jj,i)
8675       ees0pkl=ees0p(kk,k)
8676       ees0mij=ees0m(jj,i)
8677       ees0mkl=ees0m(kk,k)
8678       ekont=eij*ekl
8679       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8680 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8681 C Following 4 lines for diagnostics.
8682 cd    ees0pkl=0.0D0
8683 cd    ees0pij=1.0D0
8684 cd    ees0mkl=0.0D0
8685 cd    ees0mij=1.0D0
8686 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8687 c     & 'Contacts ',i,j,
8688 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8689 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8690 c     & 'gradcorr_long'
8691 C Calculate the multi-body contribution to energy.
8692 c      ecorr=ecorr+ekont*ees
8693 C Calculate multi-body contributions to the gradient.
8694       coeffpees0pij=coeffp*ees0pij
8695       coeffmees0mij=coeffm*ees0mij
8696       coeffpees0pkl=coeffp*ees0pkl
8697       coeffmees0mkl=coeffm*ees0mkl
8698       do ll=1,3
8699 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8700         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8701      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8702      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8703         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8704      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8705      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8706 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8707         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8708      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8709      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8710         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8711      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8712      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8713         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8714      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8715      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8716         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8717         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8718         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8719      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8720      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8721         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8722         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8723 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8724       enddo
8725 c      write (iout,*)
8726 cgrad      do m=i+1,j-1
8727 cgrad        do ll=1,3
8728 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8729 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8730 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8731 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8732 cgrad        enddo
8733 cgrad      enddo
8734 cgrad      do m=k+1,l-1
8735 cgrad        do ll=1,3
8736 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8737 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8738 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8739 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8740 cgrad        enddo
8741 cgrad      enddo
8742 c      write (iout,*) "ehbcorr",ekont*ees
8743       ehbcorr=ekont*ees
8744       return
8745       end
8746 #ifdef MOMENT
8747 C---------------------------------------------------------------------------
8748       subroutine dipole(i,j,jj)
8749       implicit real*8 (a-h,o-z)
8750       include 'DIMENSIONS'
8751       include 'COMMON.IOUNITS'
8752       include 'COMMON.CHAIN'
8753       include 'COMMON.FFIELD'
8754       include 'COMMON.DERIV'
8755       include 'COMMON.INTERACT'
8756       include 'COMMON.CONTACTS'
8757       include 'COMMON.TORSION'
8758       include 'COMMON.VAR'
8759       include 'COMMON.GEO'
8760       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8761      &  auxmat(2,2)
8762       iti1 = itortyp(itype(i+1))
8763       if (j.lt.nres-1) then
8764         itj1 = itortyp(itype(j+1))
8765       else
8766         itj1=ntortyp+1
8767       endif
8768       do iii=1,2
8769         dipi(iii,1)=Ub2(iii,i)
8770         dipderi(iii)=Ub2der(iii,i)
8771         dipi(iii,2)=b1(iii,i+1)
8772         dipj(iii,1)=Ub2(iii,j)
8773         dipderj(iii)=Ub2der(iii,j)
8774         dipj(iii,2)=b1(iii,i+1)
8775       enddo
8776       kkk=0
8777       do iii=1,2
8778         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8779         do jjj=1,2
8780           kkk=kkk+1
8781           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8782         enddo
8783       enddo
8784       do kkk=1,5
8785         do lll=1,3
8786           mmm=0
8787           do iii=1,2
8788             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8789      &        auxvec(1))
8790             do jjj=1,2
8791               mmm=mmm+1
8792               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8793             enddo
8794           enddo
8795         enddo
8796       enddo
8797       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8798       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8799       do iii=1,2
8800         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8801       enddo
8802       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8803       do iii=1,2
8804         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8805       enddo
8806       return
8807       end
8808 #endif
8809 C---------------------------------------------------------------------------
8810       subroutine calc_eello(i,j,k,l,jj,kk)
8811 C
8812 C This subroutine computes matrices and vectors needed to calculate
8813 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8814 C
8815       implicit real*8 (a-h,o-z)
8816       include 'DIMENSIONS'
8817       include 'COMMON.IOUNITS'
8818       include 'COMMON.CHAIN'
8819       include 'COMMON.DERIV'
8820       include 'COMMON.INTERACT'
8821       include 'COMMON.CONTACTS'
8822       include 'COMMON.TORSION'
8823       include 'COMMON.VAR'
8824       include 'COMMON.GEO'
8825       include 'COMMON.FFIELD'
8826       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8827      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8828       logical lprn
8829       common /kutas/ lprn
8830 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8831 cd     & ' jj=',jj,' kk=',kk
8832 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8833 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8834 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8835       do iii=1,2
8836         do jjj=1,2
8837           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8838           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8839         enddo
8840       enddo
8841       call transpose2(aa1(1,1),aa1t(1,1))
8842       call transpose2(aa2(1,1),aa2t(1,1))
8843       do kkk=1,5
8844         do lll=1,3
8845           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8846      &      aa1tder(1,1,lll,kkk))
8847           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8848      &      aa2tder(1,1,lll,kkk))
8849         enddo
8850       enddo
8851       if (l.eq.j+1) then
8852 C parallel orientation of the two CA-CA-CA frames.
8853         if (i.gt.1) then
8854           iti=itortyp(itype(i))
8855         else
8856           iti=ntortyp+1
8857         endif
8858         itk1=itortyp(itype(k+1))
8859         itj=itortyp(itype(j))
8860         if (l.lt.nres-1) then
8861           itl1=itortyp(itype(l+1))
8862         else
8863           itl1=ntortyp+1
8864         endif
8865 C A1 kernel(j+1) A2T
8866 cd        do iii=1,2
8867 cd          write (iout,'(3f10.5,5x,3f10.5)')
8868 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8869 cd        enddo
8870         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8871      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8872      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8873 C Following matrices are needed only for 6-th order cumulants
8874         IF (wcorr6.gt.0.0d0) THEN
8875         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8876      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8877      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8878         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8879      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8880      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8881      &   ADtEAderx(1,1,1,1,1,1))
8882         lprn=.false.
8883         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8884      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8885      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8886      &   ADtEA1derx(1,1,1,1,1,1))
8887         ENDIF
8888 C End 6-th order cumulants
8889 cd        lprn=.false.
8890 cd        if (lprn) then
8891 cd        write (2,*) 'In calc_eello6'
8892 cd        do iii=1,2
8893 cd          write (2,*) 'iii=',iii
8894 cd          do kkk=1,5
8895 cd            write (2,*) 'kkk=',kkk
8896 cd            do jjj=1,2
8897 cd              write (2,'(3(2f10.5),5x)')
8898 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8899 cd            enddo
8900 cd          enddo
8901 cd        enddo
8902 cd        endif
8903         call transpose2(EUgder(1,1,k),auxmat(1,1))
8904         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8905         call transpose2(EUg(1,1,k),auxmat(1,1))
8906         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8907         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8908         do iii=1,2
8909           do kkk=1,5
8910             do lll=1,3
8911               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8912      &          EAEAderx(1,1,lll,kkk,iii,1))
8913             enddo
8914           enddo
8915         enddo
8916 C A1T kernel(i+1) A2
8917         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8918      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8919      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8920 C Following matrices are needed only for 6-th order cumulants
8921         IF (wcorr6.gt.0.0d0) THEN
8922         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8923      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8924      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8925         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8926      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8927      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8928      &   ADtEAderx(1,1,1,1,1,2))
8929         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8930      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8931      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8932      &   ADtEA1derx(1,1,1,1,1,2))
8933         ENDIF
8934 C End 6-th order cumulants
8935         call transpose2(EUgder(1,1,l),auxmat(1,1))
8936         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8937         call transpose2(EUg(1,1,l),auxmat(1,1))
8938         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8939         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8940         do iii=1,2
8941           do kkk=1,5
8942             do lll=1,3
8943               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8944      &          EAEAderx(1,1,lll,kkk,iii,2))
8945             enddo
8946           enddo
8947         enddo
8948 C AEAb1 and AEAb2
8949 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8950 C They are needed only when the fifth- or the sixth-order cumulants are
8951 C indluded.
8952         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8953         call transpose2(AEA(1,1,1),auxmat(1,1))
8954         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8955         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8956         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8957         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8958         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8959         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8960         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8961         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8962         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8963         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8964         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8965         call transpose2(AEA(1,1,2),auxmat(1,1))
8966         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8967         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8968         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8969         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8970         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8971         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8972         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8973         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8974         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8975         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8976         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8977 C Calculate the Cartesian derivatives of the vectors.
8978         do iii=1,2
8979           do kkk=1,5
8980             do lll=1,3
8981               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8982               call matvec2(auxmat(1,1),b1(1,i),
8983      &          AEAb1derx(1,lll,kkk,iii,1,1))
8984               call matvec2(auxmat(1,1),Ub2(1,i),
8985      &          AEAb2derx(1,lll,kkk,iii,1,1))
8986               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8987      &          AEAb1derx(1,lll,kkk,iii,2,1))
8988               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8989      &          AEAb2derx(1,lll,kkk,iii,2,1))
8990               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8991               call matvec2(auxmat(1,1),b1(1,j),
8992      &          AEAb1derx(1,lll,kkk,iii,1,2))
8993               call matvec2(auxmat(1,1),Ub2(1,j),
8994      &          AEAb2derx(1,lll,kkk,iii,1,2))
8995               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8996      &          AEAb1derx(1,lll,kkk,iii,2,2))
8997               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8998      &          AEAb2derx(1,lll,kkk,iii,2,2))
8999             enddo
9000           enddo
9001         enddo
9002         ENDIF
9003 C End vectors
9004       else
9005 C Antiparallel orientation of the two CA-CA-CA frames.
9006         if (i.gt.1) then
9007           iti=itortyp(itype(i))
9008         else
9009           iti=ntortyp+1
9010         endif
9011         itk1=itortyp(itype(k+1))
9012         itl=itortyp(itype(l))
9013         itj=itortyp(itype(j))
9014         if (j.lt.nres-1) then
9015           itj1=itortyp(itype(j+1))
9016         else
9017           itj1=ntortyp+1
9018         endif
9019 C A2 kernel(j-1)T A1T
9020         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9021      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9022      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9023 C Following matrices are needed only for 6-th order cumulants
9024         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9025      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9026         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9027      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9028      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9029         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9030      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9031      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9032      &   ADtEAderx(1,1,1,1,1,1))
9033         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9034      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9035      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9036      &   ADtEA1derx(1,1,1,1,1,1))
9037         ENDIF
9038 C End 6-th order cumulants
9039         call transpose2(EUgder(1,1,k),auxmat(1,1))
9040         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9041         call transpose2(EUg(1,1,k),auxmat(1,1))
9042         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9043         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9044         do iii=1,2
9045           do kkk=1,5
9046             do lll=1,3
9047               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9048      &          EAEAderx(1,1,lll,kkk,iii,1))
9049             enddo
9050           enddo
9051         enddo
9052 C A2T kernel(i+1)T A1
9053         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9054      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9055      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9056 C Following matrices are needed only for 6-th order cumulants
9057         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9058      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9059         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9060      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9061      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9062         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9063      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9064      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9065      &   ADtEAderx(1,1,1,1,1,2))
9066         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9067      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9068      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9069      &   ADtEA1derx(1,1,1,1,1,2))
9070         ENDIF
9071 C End 6-th order cumulants
9072         call transpose2(EUgder(1,1,j),auxmat(1,1))
9073         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9074         call transpose2(EUg(1,1,j),auxmat(1,1))
9075         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9076         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9077         do iii=1,2
9078           do kkk=1,5
9079             do lll=1,3
9080               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9081      &          EAEAderx(1,1,lll,kkk,iii,2))
9082             enddo
9083           enddo
9084         enddo
9085 C AEAb1 and AEAb2
9086 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9087 C They are needed only when the fifth- or the sixth-order cumulants are
9088 C indluded.
9089         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9090      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9091         call transpose2(AEA(1,1,1),auxmat(1,1))
9092         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9093         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9094         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9095         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9096         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9097         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9098         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9099         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9100         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9101         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9102         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9103         call transpose2(AEA(1,1,2),auxmat(1,1))
9104         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9105         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9106         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9107         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9108         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9109         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9110         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9111         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9112         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9113         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9114         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9115 C Calculate the Cartesian derivatives of the vectors.
9116         do iii=1,2
9117           do kkk=1,5
9118             do lll=1,3
9119               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9120               call matvec2(auxmat(1,1),b1(1,i),
9121      &          AEAb1derx(1,lll,kkk,iii,1,1))
9122               call matvec2(auxmat(1,1),Ub2(1,i),
9123      &          AEAb2derx(1,lll,kkk,iii,1,1))
9124               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9125      &          AEAb1derx(1,lll,kkk,iii,2,1))
9126               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9127      &          AEAb2derx(1,lll,kkk,iii,2,1))
9128               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9129               call matvec2(auxmat(1,1),b1(1,l),
9130      &          AEAb1derx(1,lll,kkk,iii,1,2))
9131               call matvec2(auxmat(1,1),Ub2(1,l),
9132      &          AEAb2derx(1,lll,kkk,iii,1,2))
9133               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9134      &          AEAb1derx(1,lll,kkk,iii,2,2))
9135               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9136      &          AEAb2derx(1,lll,kkk,iii,2,2))
9137             enddo
9138           enddo
9139         enddo
9140         ENDIF
9141 C End vectors
9142       endif
9143       return
9144       end
9145 C---------------------------------------------------------------------------
9146       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9147      &  KK,KKderg,AKA,AKAderg,AKAderx)
9148       implicit none
9149       integer nderg
9150       logical transp
9151       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9152      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9153      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9154       integer iii,kkk,lll
9155       integer jjj,mmm
9156       logical lprn
9157       common /kutas/ lprn
9158       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9159       do iii=1,nderg
9160         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9161      &    AKAderg(1,1,iii))
9162       enddo
9163 cd      if (lprn) write (2,*) 'In kernel'
9164       do kkk=1,5
9165 cd        if (lprn) write (2,*) 'kkk=',kkk
9166         do lll=1,3
9167           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9168      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9169 cd          if (lprn) then
9170 cd            write (2,*) 'lll=',lll
9171 cd            write (2,*) 'iii=1'
9172 cd            do jjj=1,2
9173 cd              write (2,'(3(2f10.5),5x)')
9174 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9175 cd            enddo
9176 cd          endif
9177           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9178      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9179 cd          if (lprn) then
9180 cd            write (2,*) 'lll=',lll
9181 cd            write (2,*) 'iii=2'
9182 cd            do jjj=1,2
9183 cd              write (2,'(3(2f10.5),5x)')
9184 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9185 cd            enddo
9186 cd          endif
9187         enddo
9188       enddo
9189       return
9190       end
9191 C---------------------------------------------------------------------------
9192       double precision function eello4(i,j,k,l,jj,kk)
9193       implicit real*8 (a-h,o-z)
9194       include 'DIMENSIONS'
9195       include 'COMMON.IOUNITS'
9196       include 'COMMON.CHAIN'
9197       include 'COMMON.DERIV'
9198       include 'COMMON.INTERACT'
9199       include 'COMMON.CONTACTS'
9200       include 'COMMON.TORSION'
9201       include 'COMMON.VAR'
9202       include 'COMMON.GEO'
9203       double precision pizda(2,2),ggg1(3),ggg2(3)
9204 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9205 cd        eello4=0.0d0
9206 cd        return
9207 cd      endif
9208 cd      print *,'eello4:',i,j,k,l,jj,kk
9209 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9210 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9211 cold      eij=facont_hb(jj,i)
9212 cold      ekl=facont_hb(kk,k)
9213 cold      ekont=eij*ekl
9214       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9215 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9216       gcorr_loc(k-1)=gcorr_loc(k-1)
9217      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9218       if (l.eq.j+1) then
9219         gcorr_loc(l-1)=gcorr_loc(l-1)
9220      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9221       else
9222         gcorr_loc(j-1)=gcorr_loc(j-1)
9223      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9224       endif
9225       do iii=1,2
9226         do kkk=1,5
9227           do lll=1,3
9228             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9229      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9230 cd            derx(lll,kkk,iii)=0.0d0
9231           enddo
9232         enddo
9233       enddo
9234 cd      gcorr_loc(l-1)=0.0d0
9235 cd      gcorr_loc(j-1)=0.0d0
9236 cd      gcorr_loc(k-1)=0.0d0
9237 cd      eel4=1.0d0
9238 cd      write (iout,*)'Contacts have occurred for peptide groups',
9239 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9240 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9241       if (j.lt.nres-1) then
9242         j1=j+1
9243         j2=j-1
9244       else
9245         j1=j-1
9246         j2=j-2
9247       endif
9248       if (l.lt.nres-1) then
9249         l1=l+1
9250         l2=l-1
9251       else
9252         l1=l-1
9253         l2=l-2
9254       endif
9255       do ll=1,3
9256 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9257 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9258         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9259         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9260 cgrad        ghalf=0.5d0*ggg1(ll)
9261         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9262         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9263         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9264         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9265         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9266         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9267 cgrad        ghalf=0.5d0*ggg2(ll)
9268         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9269         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9270         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9271         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9272         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9273         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9274       enddo
9275 cgrad      do m=i+1,j-1
9276 cgrad        do ll=1,3
9277 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9278 cgrad        enddo
9279 cgrad      enddo
9280 cgrad      do m=k+1,l-1
9281 cgrad        do ll=1,3
9282 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9283 cgrad        enddo
9284 cgrad      enddo
9285 cgrad      do m=i+2,j2
9286 cgrad        do ll=1,3
9287 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9288 cgrad        enddo
9289 cgrad      enddo
9290 cgrad      do m=k+2,l2
9291 cgrad        do ll=1,3
9292 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9293 cgrad        enddo
9294 cgrad      enddo
9295 cd      do iii=1,nres-3
9296 cd        write (2,*) iii,gcorr_loc(iii)
9297 cd      enddo
9298       eello4=ekont*eel4
9299 cd      write (2,*) 'ekont',ekont
9300 cd      write (iout,*) 'eello4',ekont*eel4
9301       return
9302       end
9303 C---------------------------------------------------------------------------
9304       double precision function eello5(i,j,k,l,jj,kk)
9305       implicit real*8 (a-h,o-z)
9306       include 'DIMENSIONS'
9307       include 'COMMON.IOUNITS'
9308       include 'COMMON.CHAIN'
9309       include 'COMMON.DERIV'
9310       include 'COMMON.INTERACT'
9311       include 'COMMON.CONTACTS'
9312       include 'COMMON.TORSION'
9313       include 'COMMON.VAR'
9314       include 'COMMON.GEO'
9315       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9316       double precision ggg1(3),ggg2(3)
9317 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9318 C                                                                              C
9319 C                            Parallel chains                                   C
9320 C                                                                              C
9321 C          o             o                   o             o                   C
9322 C         /l\           / \             \   / \           / \   /              C
9323 C        /   \         /   \             \ /   \         /   \ /               C
9324 C       j| o |l1       | o |              o| o |         | o |o                C
9325 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9326 C      \i/   \         /   \ /             /   \         /   \                 C
9327 C       o    k1             o                                                  C
9328 C         (I)          (II)                (III)          (IV)                 C
9329 C                                                                              C
9330 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9331 C                                                                              C
9332 C                            Antiparallel chains                               C
9333 C                                                                              C
9334 C          o             o                   o             o                   C
9335 C         /j\           / \             \   / \           / \   /              C
9336 C        /   \         /   \             \ /   \         /   \ /               C
9337 C      j1| o |l        | o |              o| o |         | o |o                C
9338 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9339 C      \i/   \         /   \ /             /   \         /   \                 C
9340 C       o     k1            o                                                  C
9341 C         (I)          (II)                (III)          (IV)                 C
9342 C                                                                              C
9343 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9344 C                                                                              C
9345 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9346 C                                                                              C
9347 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9348 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9349 cd        eello5=0.0d0
9350 cd        return
9351 cd      endif
9352 cd      write (iout,*)
9353 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9354 cd     &   ' and',k,l
9355       itk=itortyp(itype(k))
9356       itl=itortyp(itype(l))
9357       itj=itortyp(itype(j))
9358       eello5_1=0.0d0
9359       eello5_2=0.0d0
9360       eello5_3=0.0d0
9361       eello5_4=0.0d0
9362 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9363 cd     &   eel5_3_num,eel5_4_num)
9364       do iii=1,2
9365         do kkk=1,5
9366           do lll=1,3
9367             derx(lll,kkk,iii)=0.0d0
9368           enddo
9369         enddo
9370       enddo
9371 cd      eij=facont_hb(jj,i)
9372 cd      ekl=facont_hb(kk,k)
9373 cd      ekont=eij*ekl
9374 cd      write (iout,*)'Contacts have occurred for peptide groups',
9375 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9376 cd      goto 1111
9377 C Contribution from the graph I.
9378 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9379 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9380       call transpose2(EUg(1,1,k),auxmat(1,1))
9381       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9382       vv(1)=pizda(1,1)-pizda(2,2)
9383       vv(2)=pizda(1,2)+pizda(2,1)
9384       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9385      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9386 C Explicit gradient in virtual-dihedral angles.
9387       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9388      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9389      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9390       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9391       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9392       vv(1)=pizda(1,1)-pizda(2,2)
9393       vv(2)=pizda(1,2)+pizda(2,1)
9394       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9395      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9396      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9397       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9398       vv(1)=pizda(1,1)-pizda(2,2)
9399       vv(2)=pizda(1,2)+pizda(2,1)
9400       if (l.eq.j+1) then
9401         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9402      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9403      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9404       else
9405         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9406      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9407      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9408       endif
9409 C Cartesian gradient
9410       do iii=1,2
9411         do kkk=1,5
9412           do lll=1,3
9413             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9414      &        pizda(1,1))
9415             vv(1)=pizda(1,1)-pizda(2,2)
9416             vv(2)=pizda(1,2)+pizda(2,1)
9417             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9418      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9419      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9420           enddo
9421         enddo
9422       enddo
9423 c      goto 1112
9424 c1111  continue
9425 C Contribution from graph II
9426       call transpose2(EE(1,1,itk),auxmat(1,1))
9427       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9428       vv(1)=pizda(1,1)+pizda(2,2)
9429       vv(2)=pizda(2,1)-pizda(1,2)
9430       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9431      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9432 C Explicit gradient in virtual-dihedral angles.
9433       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9434      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9435       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9436       vv(1)=pizda(1,1)+pizda(2,2)
9437       vv(2)=pizda(2,1)-pizda(1,2)
9438       if (l.eq.j+1) then
9439         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9440      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9441      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9442       else
9443         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9444      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9445      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9446       endif
9447 C Cartesian gradient
9448       do iii=1,2
9449         do kkk=1,5
9450           do lll=1,3
9451             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9452      &        pizda(1,1))
9453             vv(1)=pizda(1,1)+pizda(2,2)
9454             vv(2)=pizda(2,1)-pizda(1,2)
9455             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9456      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9457      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9458           enddo
9459         enddo
9460       enddo
9461 cd      goto 1112
9462 cd1111  continue
9463       if (l.eq.j+1) then
9464 cd        goto 1110
9465 C Parallel orientation
9466 C Contribution from graph III
9467         call transpose2(EUg(1,1,l),auxmat(1,1))
9468         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9469         vv(1)=pizda(1,1)-pizda(2,2)
9470         vv(2)=pizda(1,2)+pizda(2,1)
9471         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9472      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9473 C Explicit gradient in virtual-dihedral angles.
9474         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9475      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9476      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9477         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9478         vv(1)=pizda(1,1)-pizda(2,2)
9479         vv(2)=pizda(1,2)+pizda(2,1)
9480         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9481      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9482      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9483         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9484         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9485         vv(1)=pizda(1,1)-pizda(2,2)
9486         vv(2)=pizda(1,2)+pizda(2,1)
9487         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9488      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9489      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9490 C Cartesian gradient
9491         do iii=1,2
9492           do kkk=1,5
9493             do lll=1,3
9494               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9495      &          pizda(1,1))
9496               vv(1)=pizda(1,1)-pizda(2,2)
9497               vv(2)=pizda(1,2)+pizda(2,1)
9498               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9499      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9500      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9501             enddo
9502           enddo
9503         enddo
9504 cd        goto 1112
9505 C Contribution from graph IV
9506 cd1110    continue
9507         call transpose2(EE(1,1,itl),auxmat(1,1))
9508         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9509         vv(1)=pizda(1,1)+pizda(2,2)
9510         vv(2)=pizda(2,1)-pizda(1,2)
9511         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9512      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9513 C Explicit gradient in virtual-dihedral angles.
9514         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9515      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9516         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9517         vv(1)=pizda(1,1)+pizda(2,2)
9518         vv(2)=pizda(2,1)-pizda(1,2)
9519         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9520      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9521      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9522 C Cartesian gradient
9523         do iii=1,2
9524           do kkk=1,5
9525             do lll=1,3
9526               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9527      &          pizda(1,1))
9528               vv(1)=pizda(1,1)+pizda(2,2)
9529               vv(2)=pizda(2,1)-pizda(1,2)
9530               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9531      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9532      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9533             enddo
9534           enddo
9535         enddo
9536       else
9537 C Antiparallel orientation
9538 C Contribution from graph III
9539 c        goto 1110
9540         call transpose2(EUg(1,1,j),auxmat(1,1))
9541         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9542         vv(1)=pizda(1,1)-pizda(2,2)
9543         vv(2)=pizda(1,2)+pizda(2,1)
9544         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9545      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9546 C Explicit gradient in virtual-dihedral angles.
9547         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9548      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9549      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9550         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9551         vv(1)=pizda(1,1)-pizda(2,2)
9552         vv(2)=pizda(1,2)+pizda(2,1)
9553         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9554      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9555      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9556         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9557         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9558         vv(1)=pizda(1,1)-pizda(2,2)
9559         vv(2)=pizda(1,2)+pizda(2,1)
9560         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9561      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9562      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9563 C Cartesian gradient
9564         do iii=1,2
9565           do kkk=1,5
9566             do lll=1,3
9567               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9568      &          pizda(1,1))
9569               vv(1)=pizda(1,1)-pizda(2,2)
9570               vv(2)=pizda(1,2)+pizda(2,1)
9571               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9572      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9573      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9574             enddo
9575           enddo
9576         enddo
9577 cd        goto 1112
9578 C Contribution from graph IV
9579 1110    continue
9580         call transpose2(EE(1,1,itj),auxmat(1,1))
9581         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9582         vv(1)=pizda(1,1)+pizda(2,2)
9583         vv(2)=pizda(2,1)-pizda(1,2)
9584         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9585      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9586 C Explicit gradient in virtual-dihedral angles.
9587         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9588      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9589         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9590         vv(1)=pizda(1,1)+pizda(2,2)
9591         vv(2)=pizda(2,1)-pizda(1,2)
9592         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9593      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9594      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9595 C Cartesian gradient
9596         do iii=1,2
9597           do kkk=1,5
9598             do lll=1,3
9599               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9600      &          pizda(1,1))
9601               vv(1)=pizda(1,1)+pizda(2,2)
9602               vv(2)=pizda(2,1)-pizda(1,2)
9603               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9604      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9605      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9606             enddo
9607           enddo
9608         enddo
9609       endif
9610 1112  continue
9611       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9612 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9613 cd        write (2,*) 'ijkl',i,j,k,l
9614 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9615 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9616 cd      endif
9617 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9618 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9619 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9620 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9621       if (j.lt.nres-1) then
9622         j1=j+1
9623         j2=j-1
9624       else
9625         j1=j-1
9626         j2=j-2
9627       endif
9628       if (l.lt.nres-1) then
9629         l1=l+1
9630         l2=l-1
9631       else
9632         l1=l-1
9633         l2=l-2
9634       endif
9635 cd      eij=1.0d0
9636 cd      ekl=1.0d0
9637 cd      ekont=1.0d0
9638 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9639 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9640 C        summed up outside the subrouine as for the other subroutines
9641 C        handling long-range interactions. The old code is commented out
9642 C        with "cgrad" to keep track of changes.
9643       do ll=1,3
9644 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9645 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9646         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9647         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9648 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9649 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9650 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9651 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9652 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9653 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9654 c     &   gradcorr5ij,
9655 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9656 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9657 cgrad        ghalf=0.5d0*ggg1(ll)
9658 cd        ghalf=0.0d0
9659         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9660         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9661         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9662         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9663         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9664         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9665 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9666 cgrad        ghalf=0.5d0*ggg2(ll)
9667 cd        ghalf=0.0d0
9668         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9669         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9670         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9671         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9672         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9673         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9674       enddo
9675 cd      goto 1112
9676 cgrad      do m=i+1,j-1
9677 cgrad        do ll=1,3
9678 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9679 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9680 cgrad        enddo
9681 cgrad      enddo
9682 cgrad      do m=k+1,l-1
9683 cgrad        do ll=1,3
9684 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9685 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9686 cgrad        enddo
9687 cgrad      enddo
9688 c1112  continue
9689 cgrad      do m=i+2,j2
9690 cgrad        do ll=1,3
9691 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9692 cgrad        enddo
9693 cgrad      enddo
9694 cgrad      do m=k+2,l2
9695 cgrad        do ll=1,3
9696 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9697 cgrad        enddo
9698 cgrad      enddo
9699 cd      do iii=1,nres-3
9700 cd        write (2,*) iii,g_corr5_loc(iii)
9701 cd      enddo
9702       eello5=ekont*eel5
9703 cd      write (2,*) 'ekont',ekont
9704 cd      write (iout,*) 'eello5',ekont*eel5
9705       return
9706       end
9707 c--------------------------------------------------------------------------
9708       double precision function eello6(i,j,k,l,jj,kk)
9709       implicit real*8 (a-h,o-z)
9710       include 'DIMENSIONS'
9711       include 'COMMON.IOUNITS'
9712       include 'COMMON.CHAIN'
9713       include 'COMMON.DERIV'
9714       include 'COMMON.INTERACT'
9715       include 'COMMON.CONTACTS'
9716       include 'COMMON.TORSION'
9717       include 'COMMON.VAR'
9718       include 'COMMON.GEO'
9719       include 'COMMON.FFIELD'
9720       double precision ggg1(3),ggg2(3)
9721 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9722 cd        eello6=0.0d0
9723 cd        return
9724 cd      endif
9725 cd      write (iout,*)
9726 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9727 cd     &   ' and',k,l
9728       eello6_1=0.0d0
9729       eello6_2=0.0d0
9730       eello6_3=0.0d0
9731       eello6_4=0.0d0
9732       eello6_5=0.0d0
9733       eello6_6=0.0d0
9734 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9735 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9736       do iii=1,2
9737         do kkk=1,5
9738           do lll=1,3
9739             derx(lll,kkk,iii)=0.0d0
9740           enddo
9741         enddo
9742       enddo
9743 cd      eij=facont_hb(jj,i)
9744 cd      ekl=facont_hb(kk,k)
9745 cd      ekont=eij*ekl
9746 cd      eij=1.0d0
9747 cd      ekl=1.0d0
9748 cd      ekont=1.0d0
9749       if (l.eq.j+1) then
9750         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9751         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9752         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9753         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9754         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9755         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9756       else
9757         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9758         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9759         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9760         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9761         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9762           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9763         else
9764           eello6_5=0.0d0
9765         endif
9766         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9767       endif
9768 C If turn contributions are considered, they will be handled separately.
9769       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9770 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9771 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9772 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9773 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9774 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9775 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9776 cd      goto 1112
9777       if (j.lt.nres-1) then
9778         j1=j+1
9779         j2=j-1
9780       else
9781         j1=j-1
9782         j2=j-2
9783       endif
9784       if (l.lt.nres-1) then
9785         l1=l+1
9786         l2=l-1
9787       else
9788         l1=l-1
9789         l2=l-2
9790       endif
9791       do ll=1,3
9792 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9793 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9794 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9795 cgrad        ghalf=0.5d0*ggg1(ll)
9796 cd        ghalf=0.0d0
9797         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9798         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9799         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9800         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9801         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9802         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9803         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9804         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9805 cgrad        ghalf=0.5d0*ggg2(ll)
9806 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9807 cd        ghalf=0.0d0
9808         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9809         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9810         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9811         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9812         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9813         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9814       enddo
9815 cd      goto 1112
9816 cgrad      do m=i+1,j-1
9817 cgrad        do ll=1,3
9818 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9819 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9820 cgrad        enddo
9821 cgrad      enddo
9822 cgrad      do m=k+1,l-1
9823 cgrad        do ll=1,3
9824 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9825 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9826 cgrad        enddo
9827 cgrad      enddo
9828 cgrad1112  continue
9829 cgrad      do m=i+2,j2
9830 cgrad        do ll=1,3
9831 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9832 cgrad        enddo
9833 cgrad      enddo
9834 cgrad      do m=k+2,l2
9835 cgrad        do ll=1,3
9836 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9837 cgrad        enddo
9838 cgrad      enddo
9839 cd      do iii=1,nres-3
9840 cd        write (2,*) iii,g_corr6_loc(iii)
9841 cd      enddo
9842       eello6=ekont*eel6
9843 cd      write (2,*) 'ekont',ekont
9844 cd      write (iout,*) 'eello6',ekont*eel6
9845       return
9846       end
9847 c--------------------------------------------------------------------------
9848       double precision function eello6_graph1(i,j,k,l,imat,swap)
9849       implicit real*8 (a-h,o-z)
9850       include 'DIMENSIONS'
9851       include 'COMMON.IOUNITS'
9852       include 'COMMON.CHAIN'
9853       include 'COMMON.DERIV'
9854       include 'COMMON.INTERACT'
9855       include 'COMMON.CONTACTS'
9856       include 'COMMON.TORSION'
9857       include 'COMMON.VAR'
9858       include 'COMMON.GEO'
9859       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9860       logical swap
9861       logical lprn
9862       common /kutas/ lprn
9863 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9864 C
9865 C      Parallel       Antiparallel
9866 C
9867 C          o             o
9868 C         /l\           /j\
9869 C        /   \         /   \
9870 C       /| o |         | o |\
9871 C     \ j|/k\|  /   \  |/k\|l /
9872 C      \ /   \ /     \ /   \ /
9873 C       o     o       o     o
9874 C       i             i
9875 C
9876 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9877       itk=itortyp(itype(k))
9878       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9879       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9880       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9881       call transpose2(EUgC(1,1,k),auxmat(1,1))
9882       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9883       vv1(1)=pizda1(1,1)-pizda1(2,2)
9884       vv1(2)=pizda1(1,2)+pizda1(2,1)
9885       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9886       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9887       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9888       s5=scalar2(vv(1),Dtobr2(1,i))
9889 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9890       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9891       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9892      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9893      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9894      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9895      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9896      & +scalar2(vv(1),Dtobr2der(1,i)))
9897       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9898       vv1(1)=pizda1(1,1)-pizda1(2,2)
9899       vv1(2)=pizda1(1,2)+pizda1(2,1)
9900       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9901       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9902       if (l.eq.j+1) then
9903         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9904      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9905      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9906      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9907      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9908       else
9909         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9910      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9911      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9912      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9913      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9914       endif
9915       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9916       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9917       vv1(1)=pizda1(1,1)-pizda1(2,2)
9918       vv1(2)=pizda1(1,2)+pizda1(2,1)
9919       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9920      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9921      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9922      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9923       do iii=1,2
9924         if (swap) then
9925           ind=3-iii
9926         else
9927           ind=iii
9928         endif
9929         do kkk=1,5
9930           do lll=1,3
9931             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9932             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9933             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9934             call transpose2(EUgC(1,1,k),auxmat(1,1))
9935             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9936      &        pizda1(1,1))
9937             vv1(1)=pizda1(1,1)-pizda1(2,2)
9938             vv1(2)=pizda1(1,2)+pizda1(2,1)
9939             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9940             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9941      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9942             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9943      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9944             s5=scalar2(vv(1),Dtobr2(1,i))
9945             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9946           enddo
9947         enddo
9948       enddo
9949       return
9950       end
9951 c----------------------------------------------------------------------------
9952       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9953       implicit real*8 (a-h,o-z)
9954       include 'DIMENSIONS'
9955       include 'COMMON.IOUNITS'
9956       include 'COMMON.CHAIN'
9957       include 'COMMON.DERIV'
9958       include 'COMMON.INTERACT'
9959       include 'COMMON.CONTACTS'
9960       include 'COMMON.TORSION'
9961       include 'COMMON.VAR'
9962       include 'COMMON.GEO'
9963       logical swap
9964       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9965      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9966       logical lprn
9967       common /kutas/ lprn
9968 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9969 C                                                                              C
9970 C      Parallel       Antiparallel                                             C
9971 C                                                                              C
9972 C          o             o                                                     C
9973 C     \   /l\           /j\   /                                                C
9974 C      \ /   \         /   \ /                                                 C
9975 C       o| o |         | o |o                                                  C
9976 C     \ j|/k\|      \  |/k\|l                                                  C
9977 C      \ /   \       \ /   \                                                   C
9978 C       o             o                                                        C
9979 C       i             i                                                        C
9980 C                                                                              C
9981 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9982 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9983 C AL 7/4/01 s1 would occur in the sixth-order moment,
9984 C           but not in a cluster cumulant
9985 #ifdef MOMENT
9986       s1=dip(1,jj,i)*dip(1,kk,k)
9987 #endif
9988       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9989       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9990       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9991       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9992       call transpose2(EUg(1,1,k),auxmat(1,1))
9993       call matmat2(ADtEA1(1,1,1),auxmat(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 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9998 #ifdef MOMENT
9999       eello6_graph2=-(s1+s2+s3+s4)
10000 #else
10001       eello6_graph2=-(s2+s3+s4)
10002 #endif
10003 c      eello6_graph2=-s3
10004 C Derivatives in gamma(i-1)
10005       if (i.gt.1) then
10006 #ifdef MOMENT
10007         s1=dipderg(1,jj,i)*dip(1,kk,k)
10008 #endif
10009         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10010         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10011         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10012         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10013 #ifdef MOMENT
10014         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10015 #else
10016         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10017 #endif
10018 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10019       endif
10020 C Derivatives in gamma(k-1)
10021 #ifdef MOMENT
10022       s1=dip(1,jj,i)*dipderg(1,kk,k)
10023 #endif
10024       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10025       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10026       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10027       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10028       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10029       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10030       vv(1)=pizda(1,1)-pizda(2,2)
10031       vv(2)=pizda(1,2)+pizda(2,1)
10032       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10033 #ifdef MOMENT
10034       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10035 #else
10036       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10037 #endif
10038 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10039 C Derivatives in gamma(j-1) or gamma(l-1)
10040       if (j.gt.1) then
10041 #ifdef MOMENT
10042         s1=dipderg(3,jj,i)*dip(1,kk,k)
10043 #endif
10044         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10045         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10046         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10047         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10048         vv(1)=pizda(1,1)-pizda(2,2)
10049         vv(2)=pizda(1,2)+pizda(2,1)
10050         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10051 #ifdef MOMENT
10052         if (swap) then
10053           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10054         else
10055           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10056         endif
10057 #endif
10058         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10059 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10060       endif
10061 C Derivatives in gamma(l-1) or gamma(j-1)
10062       if (l.gt.1) then
10063 #ifdef MOMENT
10064         s1=dip(1,jj,i)*dipderg(3,kk,k)
10065 #endif
10066         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10067         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10068         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10069         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10070         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10071         vv(1)=pizda(1,1)-pizda(2,2)
10072         vv(2)=pizda(1,2)+pizda(2,1)
10073         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10074 #ifdef MOMENT
10075         if (swap) then
10076           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10077         else
10078           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10079         endif
10080 #endif
10081         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10082 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10083       endif
10084 C Cartesian derivatives.
10085       if (lprn) then
10086         write (2,*) 'In eello6_graph2'
10087         do iii=1,2
10088           write (2,*) 'iii=',iii
10089           do kkk=1,5
10090             write (2,*) 'kkk=',kkk
10091             do jjj=1,2
10092               write (2,'(3(2f10.5),5x)')
10093      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10094             enddo
10095           enddo
10096         enddo
10097       endif
10098       do iii=1,2
10099         do kkk=1,5
10100           do lll=1,3
10101 #ifdef MOMENT
10102             if (iii.eq.1) then
10103               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10104             else
10105               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10106             endif
10107 #endif
10108             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10109      &        auxvec(1))
10110             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10111             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10112      &        auxvec(1))
10113             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10114             call transpose2(EUg(1,1,k),auxmat(1,1))
10115             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10116      &        pizda(1,1))
10117             vv(1)=pizda(1,1)-pizda(2,2)
10118             vv(2)=pizda(1,2)+pizda(2,1)
10119             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10120 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10121 #ifdef MOMENT
10122             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10123 #else
10124             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10125 #endif
10126             if (swap) then
10127               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10128             else
10129               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10130             endif
10131           enddo
10132         enddo
10133       enddo
10134       return
10135       end
10136 c----------------------------------------------------------------------------
10137       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10138       implicit real*8 (a-h,o-z)
10139       include 'DIMENSIONS'
10140       include 'COMMON.IOUNITS'
10141       include 'COMMON.CHAIN'
10142       include 'COMMON.DERIV'
10143       include 'COMMON.INTERACT'
10144       include 'COMMON.CONTACTS'
10145       include 'COMMON.TORSION'
10146       include 'COMMON.VAR'
10147       include 'COMMON.GEO'
10148       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10149       logical swap
10150 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10151 C                                                                              C
10152 C      Parallel       Antiparallel                                             C
10153 C                                                                              C
10154 C          o             o                                                     C
10155 C         /l\   /   \   /j\                                                    C
10156 C        /   \ /     \ /   \                                                   C
10157 C       /| o |o       o| o |\                                                  C
10158 C       j|/k\|  /      |/k\|l /                                                C
10159 C        /   \ /       /   \ /                                                 C
10160 C       /     o       /     o                                                  C
10161 C       i             i                                                        C
10162 C                                                                              C
10163 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10164 C
10165 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10166 C           energy moment and not to the cluster cumulant.
10167       iti=itortyp(itype(i))
10168       if (j.lt.nres-1) then
10169         itj1=itortyp(itype(j+1))
10170       else
10171         itj1=ntortyp+1
10172       endif
10173       itk=itortyp(itype(k))
10174       itk1=itortyp(itype(k+1))
10175       if (l.lt.nres-1) then
10176         itl1=itortyp(itype(l+1))
10177       else
10178         itl1=ntortyp+1
10179       endif
10180 #ifdef MOMENT
10181       s1=dip(4,jj,i)*dip(4,kk,k)
10182 #endif
10183       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10184       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10185       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10186       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10187       call transpose2(EE(1,1,itk),auxmat(1,1))
10188       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10189       vv(1)=pizda(1,1)+pizda(2,2)
10190       vv(2)=pizda(2,1)-pizda(1,2)
10191       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10192 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10193 cd     & "sum",-(s2+s3+s4)
10194 #ifdef MOMENT
10195       eello6_graph3=-(s1+s2+s3+s4)
10196 #else
10197       eello6_graph3=-(s2+s3+s4)
10198 #endif
10199 c      eello6_graph3=-s4
10200 C Derivatives in gamma(k-1)
10201       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10202       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10203       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10204       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10205 C Derivatives in gamma(l-1)
10206       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10207       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10208       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10209       vv(1)=pizda(1,1)+pizda(2,2)
10210       vv(2)=pizda(2,1)-pizda(1,2)
10211       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10212       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10213 C Cartesian derivatives.
10214       do iii=1,2
10215         do kkk=1,5
10216           do lll=1,3
10217 #ifdef MOMENT
10218             if (iii.eq.1) then
10219               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10220             else
10221               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10222             endif
10223 #endif
10224             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10225      &        auxvec(1))
10226             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10227             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10228      &        auxvec(1))
10229             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10230             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10231      &        pizda(1,1))
10232             vv(1)=pizda(1,1)+pizda(2,2)
10233             vv(2)=pizda(2,1)-pizda(1,2)
10234             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10235 #ifdef MOMENT
10236             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10237 #else
10238             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10239 #endif
10240             if (swap) then
10241               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10242             else
10243               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10244             endif
10245 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10246           enddo
10247         enddo
10248       enddo
10249       return
10250       end
10251 c----------------------------------------------------------------------------
10252       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10253       implicit real*8 (a-h,o-z)
10254       include 'DIMENSIONS'
10255       include 'COMMON.IOUNITS'
10256       include 'COMMON.CHAIN'
10257       include 'COMMON.DERIV'
10258       include 'COMMON.INTERACT'
10259       include 'COMMON.CONTACTS'
10260       include 'COMMON.TORSION'
10261       include 'COMMON.VAR'
10262       include 'COMMON.GEO'
10263       include 'COMMON.FFIELD'
10264       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10265      & auxvec1(2),auxmat1(2,2)
10266       logical swap
10267 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10268 C                                                                              C
10269 C      Parallel       Antiparallel                                             C
10270 C                                                                              C
10271 C          o             o                                                     C
10272 C         /l\   /   \   /j\                                                    C
10273 C        /   \ /     \ /   \                                                   C
10274 C       /| o |o       o| o |\                                                  C
10275 C     \ j|/k\|      \  |/k\|l                                                  C
10276 C      \ /   \       \ /   \                                                   C
10277 C       o     \       o     \                                                  C
10278 C       i             i                                                        C
10279 C                                                                              C
10280 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10281 C
10282 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10283 C           energy moment and not to the cluster cumulant.
10284 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10285       iti=itortyp(itype(i))
10286       itj=itortyp(itype(j))
10287       if (j.lt.nres-1) then
10288         itj1=itortyp(itype(j+1))
10289       else
10290         itj1=ntortyp+1
10291       endif
10292       itk=itortyp(itype(k))
10293       if (k.lt.nres-1) then
10294         itk1=itortyp(itype(k+1))
10295       else
10296         itk1=ntortyp+1
10297       endif
10298       itl=itortyp(itype(l))
10299       if (l.lt.nres-1) then
10300         itl1=itortyp(itype(l+1))
10301       else
10302         itl1=ntortyp+1
10303       endif
10304 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10305 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10306 cd     & ' itl',itl,' itl1',itl1
10307 #ifdef MOMENT
10308       if (imat.eq.1) then
10309         s1=dip(3,jj,i)*dip(3,kk,k)
10310       else
10311         s1=dip(2,jj,j)*dip(2,kk,l)
10312       endif
10313 #endif
10314       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10315       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10316       if (j.eq.l+1) then
10317         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10318         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10319       else
10320         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10321         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10322       endif
10323       call transpose2(EUg(1,1,k),auxmat(1,1))
10324       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10325       vv(1)=pizda(1,1)-pizda(2,2)
10326       vv(2)=pizda(2,1)+pizda(1,2)
10327       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10328 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10329 #ifdef MOMENT
10330       eello6_graph4=-(s1+s2+s3+s4)
10331 #else
10332       eello6_graph4=-(s2+s3+s4)
10333 #endif
10334 C Derivatives in gamma(i-1)
10335       if (i.gt.1) then
10336 #ifdef MOMENT
10337         if (imat.eq.1) then
10338           s1=dipderg(2,jj,i)*dip(3,kk,k)
10339         else
10340           s1=dipderg(4,jj,j)*dip(2,kk,l)
10341         endif
10342 #endif
10343         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10344         if (j.eq.l+1) then
10345           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10346           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10347         else
10348           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10349           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10350         endif
10351         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10352         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10353 cd          write (2,*) 'turn6 derivatives'
10354 #ifdef MOMENT
10355           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10356 #else
10357           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10358 #endif
10359         else
10360 #ifdef MOMENT
10361           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10362 #else
10363           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10364 #endif
10365         endif
10366       endif
10367 C Derivatives in gamma(k-1)
10368 #ifdef MOMENT
10369       if (imat.eq.1) then
10370         s1=dip(3,jj,i)*dipderg(2,kk,k)
10371       else
10372         s1=dip(2,jj,j)*dipderg(4,kk,l)
10373       endif
10374 #endif
10375       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10376       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10377       if (j.eq.l+1) then
10378         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10379         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10380       else
10381         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10382         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10383       endif
10384       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10385       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10386       vv(1)=pizda(1,1)-pizda(2,2)
10387       vv(2)=pizda(2,1)+pizda(1,2)
10388       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10389       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10390 #ifdef MOMENT
10391         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10392 #else
10393         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10394 #endif
10395       else
10396 #ifdef MOMENT
10397         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10398 #else
10399         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10400 #endif
10401       endif
10402 C Derivatives in gamma(j-1) or gamma(l-1)
10403       if (l.eq.j+1 .and. l.gt.1) then
10404         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10405         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10406         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10407         vv(1)=pizda(1,1)-pizda(2,2)
10408         vv(2)=pizda(2,1)+pizda(1,2)
10409         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10410         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10411       else if (j.gt.1) then
10412         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10413         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10414         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10415         vv(1)=pizda(1,1)-pizda(2,2)
10416         vv(2)=pizda(2,1)+pizda(1,2)
10417         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10418         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10419           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10420         else
10421           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10422         endif
10423       endif
10424 C Cartesian derivatives.
10425       do iii=1,2
10426         do kkk=1,5
10427           do lll=1,3
10428 #ifdef MOMENT
10429             if (iii.eq.1) then
10430               if (imat.eq.1) then
10431                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10432               else
10433                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10434               endif
10435             else
10436               if (imat.eq.1) then
10437                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10438               else
10439                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10440               endif
10441             endif
10442 #endif
10443             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10444      &        auxvec(1))
10445             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10446             if (j.eq.l+1) then
10447               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10448      &          b1(1,j+1),auxvec(1))
10449               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10450             else
10451               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10452      &          b1(1,l+1),auxvec(1))
10453               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10454             endif
10455             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10456      &        pizda(1,1))
10457             vv(1)=pizda(1,1)-pizda(2,2)
10458             vv(2)=pizda(2,1)+pizda(1,2)
10459             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10460             if (swap) then
10461               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10462 #ifdef MOMENT
10463                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10464      &             -(s1+s2+s4)
10465 #else
10466                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10467      &             -(s2+s4)
10468 #endif
10469                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10470               else
10471 #ifdef MOMENT
10472                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10473 #else
10474                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10475 #endif
10476                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10477               endif
10478             else
10479 #ifdef MOMENT
10480               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10481 #else
10482               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10483 #endif
10484               if (l.eq.j+1) then
10485                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10486               else
10487                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10488               endif
10489             endif
10490           enddo
10491         enddo
10492       enddo
10493       return
10494       end
10495 c----------------------------------------------------------------------------
10496       double precision function eello_turn6(i,jj,kk)
10497       implicit real*8 (a-h,o-z)
10498       include 'DIMENSIONS'
10499       include 'COMMON.IOUNITS'
10500       include 'COMMON.CHAIN'
10501       include 'COMMON.DERIV'
10502       include 'COMMON.INTERACT'
10503       include 'COMMON.CONTACTS'
10504       include 'COMMON.TORSION'
10505       include 'COMMON.VAR'
10506       include 'COMMON.GEO'
10507       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10508      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10509      &  ggg1(3),ggg2(3)
10510       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10511      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10512 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10513 C           the respective energy moment and not to the cluster cumulant.
10514       s1=0.0d0
10515       s8=0.0d0
10516       s13=0.0d0
10517 c
10518       eello_turn6=0.0d0
10519       j=i+4
10520       k=i+1
10521       l=i+3
10522       iti=itortyp(itype(i))
10523       itk=itortyp(itype(k))
10524       itk1=itortyp(itype(k+1))
10525       itl=itortyp(itype(l))
10526       itj=itortyp(itype(j))
10527 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10528 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10529 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10530 cd        eello6=0.0d0
10531 cd        return
10532 cd      endif
10533 cd      write (iout,*)
10534 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10535 cd     &   ' and',k,l
10536 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10537       do iii=1,2
10538         do kkk=1,5
10539           do lll=1,3
10540             derx_turn(lll,kkk,iii)=0.0d0
10541           enddo
10542         enddo
10543       enddo
10544 cd      eij=1.0d0
10545 cd      ekl=1.0d0
10546 cd      ekont=1.0d0
10547       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10548 cd      eello6_5=0.0d0
10549 cd      write (2,*) 'eello6_5',eello6_5
10550 #ifdef MOMENT
10551       call transpose2(AEA(1,1,1),auxmat(1,1))
10552       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10553       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10554       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10555 #endif
10556       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10557       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10558       s2 = scalar2(b1(1,k),vtemp1(1))
10559 #ifdef MOMENT
10560       call transpose2(AEA(1,1,2),atemp(1,1))
10561       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10562       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10563       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10564 #endif
10565       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10566       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10567       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10568 #ifdef MOMENT
10569       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10570       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10571       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10572       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10573       ss13 = scalar2(b1(1,k),vtemp4(1))
10574       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10575 #endif
10576 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10577 c      s1=0.0d0
10578 c      s2=0.0d0
10579 c      s8=0.0d0
10580 c      s12=0.0d0
10581 c      s13=0.0d0
10582       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10583 C Derivatives in gamma(i+2)
10584       s1d =0.0d0
10585       s8d =0.0d0
10586 #ifdef MOMENT
10587       call transpose2(AEA(1,1,1),auxmatd(1,1))
10588       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10589       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10590       call transpose2(AEAderg(1,1,2),atempd(1,1))
10591       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10592       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10593 #endif
10594       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10595       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10596       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10597 c      s1d=0.0d0
10598 c      s2d=0.0d0
10599 c      s8d=0.0d0
10600 c      s12d=0.0d0
10601 c      s13d=0.0d0
10602       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10603 C Derivatives in gamma(i+3)
10604 #ifdef MOMENT
10605       call transpose2(AEA(1,1,1),auxmatd(1,1))
10606       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10607       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10608       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10609 #endif
10610       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10611       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10612       s2d = scalar2(b1(1,k),vtemp1d(1))
10613 #ifdef MOMENT
10614       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10615       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10616 #endif
10617       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10618 #ifdef MOMENT
10619       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10620       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10621       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10622 #endif
10623 c      s1d=0.0d0
10624 c      s2d=0.0d0
10625 c      s8d=0.0d0
10626 c      s12d=0.0d0
10627 c      s13d=0.0d0
10628 #ifdef MOMENT
10629       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10630      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10631 #else
10632       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10633      &               -0.5d0*ekont*(s2d+s12d)
10634 #endif
10635 C Derivatives in gamma(i+4)
10636       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10637       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10638       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10639 #ifdef MOMENT
10640       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10641       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10642       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10643 #endif
10644 c      s1d=0.0d0
10645 c      s2d=0.0d0
10646 c      s8d=0.0d0
10647 C      s12d=0.0d0
10648 c      s13d=0.0d0
10649 #ifdef MOMENT
10650       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10651 #else
10652       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10653 #endif
10654 C Derivatives in gamma(i+5)
10655 #ifdef MOMENT
10656       call transpose2(AEAderg(1,1,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,l),vtemp1d(1))
10661       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10662       s2d = scalar2(b1(1,k),vtemp1d(1))
10663 #ifdef MOMENT
10664       call transpose2(AEA(1,1,2),atempd(1,1))
10665       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10666       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10667 #endif
10668       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10669       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10670 #ifdef MOMENT
10671       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10672       ss13d = scalar2(b1(1,k),vtemp4d(1))
10673       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10674 #endif
10675 c      s1d=0.0d0
10676 c      s2d=0.0d0
10677 c      s8d=0.0d0
10678 c      s12d=0.0d0
10679 c      s13d=0.0d0
10680 #ifdef MOMENT
10681       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10682      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10683 #else
10684       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10685      &               -0.5d0*ekont*(s2d+s12d)
10686 #endif
10687 C Cartesian derivatives
10688       do iii=1,2
10689         do kkk=1,5
10690           do lll=1,3
10691 #ifdef MOMENT
10692             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10693             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10694             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10695 #endif
10696             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10697             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10698      &          vtemp1d(1))
10699             s2d = scalar2(b1(1,k),vtemp1d(1))
10700 #ifdef MOMENT
10701             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10702             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10703             s8d = -(atempd(1,1)+atempd(2,2))*
10704      &           scalar2(cc(1,1,itl),vtemp2(1))
10705 #endif
10706             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10707      &           auxmatd(1,1))
10708             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10709             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10710 c      s1d=0.0d0
10711 c      s2d=0.0d0
10712 c      s8d=0.0d0
10713 c      s12d=0.0d0
10714 c      s13d=0.0d0
10715 #ifdef MOMENT
10716             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10717      &        - 0.5d0*(s1d+s2d)
10718 #else
10719             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10720      &        - 0.5d0*s2d
10721 #endif
10722 #ifdef MOMENT
10723             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10724      &        - 0.5d0*(s8d+s12d)
10725 #else
10726             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10727      &        - 0.5d0*s12d
10728 #endif
10729           enddo
10730         enddo
10731       enddo
10732 #ifdef MOMENT
10733       do kkk=1,5
10734         do lll=1,3
10735           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10736      &      achuj_tempd(1,1))
10737           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10738           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10739           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10740           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10741           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10742      &      vtemp4d(1))
10743           ss13d = scalar2(b1(1,k),vtemp4d(1))
10744           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10745           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10746         enddo
10747       enddo
10748 #endif
10749 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10750 cd     &  16*eel_turn6_num
10751 cd      goto 1112
10752       if (j.lt.nres-1) then
10753         j1=j+1
10754         j2=j-1
10755       else
10756         j1=j-1
10757         j2=j-2
10758       endif
10759       if (l.lt.nres-1) then
10760         l1=l+1
10761         l2=l-1
10762       else
10763         l1=l-1
10764         l2=l-2
10765       endif
10766       do ll=1,3
10767 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10768 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10769 cgrad        ghalf=0.5d0*ggg1(ll)
10770 cd        ghalf=0.0d0
10771         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10772         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10773         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10774      &    +ekont*derx_turn(ll,2,1)
10775         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10776         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10777      &    +ekont*derx_turn(ll,4,1)
10778         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10779         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10780         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10781 cgrad        ghalf=0.5d0*ggg2(ll)
10782 cd        ghalf=0.0d0
10783         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10784      &    +ekont*derx_turn(ll,2,2)
10785         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10786         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10787      &    +ekont*derx_turn(ll,4,2)
10788         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10789         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10790         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10791       enddo
10792 cd      goto 1112
10793 cgrad      do m=i+1,j-1
10794 cgrad        do ll=1,3
10795 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10796 cgrad        enddo
10797 cgrad      enddo
10798 cgrad      do m=k+1,l-1
10799 cgrad        do ll=1,3
10800 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10801 cgrad        enddo
10802 cgrad      enddo
10803 cgrad1112  continue
10804 cgrad      do m=i+2,j2
10805 cgrad        do ll=1,3
10806 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10807 cgrad        enddo
10808 cgrad      enddo
10809 cgrad      do m=k+2,l2
10810 cgrad        do ll=1,3
10811 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10812 cgrad        enddo
10813 cgrad      enddo
10814 cd      do iii=1,nres-3
10815 cd        write (2,*) iii,g_corr6_loc(iii)
10816 cd      enddo
10817       eello_turn6=ekont*eel_turn6
10818 cd      write (2,*) 'ekont',ekont
10819 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10820       return
10821       end
10822
10823 C-----------------------------------------------------------------------------
10824       double precision function scalar(u,v)
10825 !DIR$ INLINEALWAYS scalar
10826 #ifndef OSF
10827 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10828 #endif
10829       implicit none
10830       double precision u(3),v(3)
10831 cd      double precision sc
10832 cd      integer i
10833 cd      sc=0.0d0
10834 cd      do i=1,3
10835 cd        sc=sc+u(i)*v(i)
10836 cd      enddo
10837 cd      scalar=sc
10838
10839       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10840       return
10841       end
10842 crc-------------------------------------------------
10843       SUBROUTINE MATVEC2(A1,V1,V2)
10844 !DIR$ INLINEALWAYS MATVEC2
10845 #ifndef OSF
10846 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10847 #endif
10848       implicit real*8 (a-h,o-z)
10849       include 'DIMENSIONS'
10850       DIMENSION A1(2,2),V1(2),V2(2)
10851 c      DO 1 I=1,2
10852 c        VI=0.0
10853 c        DO 3 K=1,2
10854 c    3     VI=VI+A1(I,K)*V1(K)
10855 c        Vaux(I)=VI
10856 c    1 CONTINUE
10857
10858       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10859       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10860
10861       v2(1)=vaux1
10862       v2(2)=vaux2
10863       END
10864 C---------------------------------------
10865       SUBROUTINE MATMAT2(A1,A2,A3)
10866 #ifndef OSF
10867 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10868 #endif
10869       implicit real*8 (a-h,o-z)
10870       include 'DIMENSIONS'
10871       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10872 c      DIMENSION AI3(2,2)
10873 c        DO  J=1,2
10874 c          A3IJ=0.0
10875 c          DO K=1,2
10876 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10877 c          enddo
10878 c          A3(I,J)=A3IJ
10879 c       enddo
10880 c      enddo
10881
10882       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10883       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10884       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10885       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10886
10887       A3(1,1)=AI3_11
10888       A3(2,1)=AI3_21
10889       A3(1,2)=AI3_12
10890       A3(2,2)=AI3_22
10891       END
10892
10893 c-------------------------------------------------------------------------
10894       double precision function scalar2(u,v)
10895 !DIR$ INLINEALWAYS scalar2
10896       implicit none
10897       double precision u(2),v(2)
10898       double precision sc
10899       integer i
10900       scalar2=u(1)*v(1)+u(2)*v(2)
10901       return
10902       end
10903
10904 C-----------------------------------------------------------------------------
10905
10906       subroutine transpose2(a,at)
10907 !DIR$ INLINEALWAYS transpose2
10908 #ifndef OSF
10909 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10910 #endif
10911       implicit none
10912       double precision a(2,2),at(2,2)
10913       at(1,1)=a(1,1)
10914       at(1,2)=a(2,1)
10915       at(2,1)=a(1,2)
10916       at(2,2)=a(2,2)
10917       return
10918       end
10919 c--------------------------------------------------------------------------
10920       subroutine transpose(n,a,at)
10921       implicit none
10922       integer n,i,j
10923       double precision a(n,n),at(n,n)
10924       do i=1,n
10925         do j=1,n
10926           at(j,i)=a(i,j)
10927         enddo
10928       enddo
10929       return
10930       end
10931 C---------------------------------------------------------------------------
10932       subroutine prodmat3(a1,a2,kk,transp,prod)
10933 !DIR$ INLINEALWAYS prodmat3
10934 #ifndef OSF
10935 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10936 #endif
10937       implicit none
10938       integer i,j
10939       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10940       logical transp
10941 crc      double precision auxmat(2,2),prod_(2,2)
10942
10943       if (transp) then
10944 crc        call transpose2(kk(1,1),auxmat(1,1))
10945 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10946 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10947
10948            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10949      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10950            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10951      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10952            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10953      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10954            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10955      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10956
10957       else
10958 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10959 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10960
10961            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10962      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10963            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10964      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10965            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10966      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10967            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10968      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10969
10970       endif
10971 c      call transpose2(a2(1,1),a2t(1,1))
10972
10973 crc      print *,transp
10974 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10975 crc      print *,((prod(i,j),i=1,2),j=1,2)
10976
10977       return
10978       end
10979