source/unres/src_MD-M/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         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 C      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101 C      write(iout,*) "zaczynam liczyc energie"
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C      write(iout,*) "skonczylem ipoty"
 122
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 C           write(iout,*) "skonczylem ipoty"
 128 cmc
 129 cmc Sep-06: egb takes care of dynamic ss bonds too
 130 cmc
 131 c      if (dyn_ss) call dyn_set_nss
 132
 133 c      print *,"Processor",myrank," computed USCSC"
 134 #ifdef TIMING
 135       time01=MPI_Wtime()
 136 #endif
 137       call vec_and_deriv
 138 #ifdef TIMING
 139       time_vec=time_vec+MPI_Wtime()-time01
 140 #endif
 141 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 142       if (ipot.lt.6) then
 143 #ifdef SPLITELE
 144          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 145      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 146      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 147      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 148 #else
 149          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 150      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 151      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 152      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 153 #endif
 154             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 155          else
 156             ees=0.0d0
 157             evdw1=0.0d0
 158             eel_loc=0.0d0
 159             eello_turn3=0.0d0
 160             eello_turn4=0.0d0
 161          endif
 162       else
 163 c        write (iout,*) "Soft-spheer ELEC potential"
 164         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 165      &   eello_turn4)
 166       endif
 167 c      print *,"Processor",myrank," computed UELEC"
 168 C
 169 C Calculate excluded-volume interaction energy between peptide groups
 170 C and side chains.
 171 C
 172       if (ipot.lt.6) then
 173        if(wscp.gt.0d0) then
 174         call escp(evdw2,evdw2_14)
 175        else
 176         evdw2=0
 177         evdw2_14=0
 178        endif
 179       else
 180 c        write (iout,*) "Soft-sphere SCP potential"
 181         call escp_soft_sphere(evdw2,evdw2_14)
 182       endif
 183 c
 184 c Calculate the bond-stretching energy
 185 c
 186       call ebond(estr)
 187 C
 188 C Calculate the disulfide-bridge and other energy and the contributions
 189 C from other distance constraints.
 190 cd    print *,'Calling EHPB'
 191       call edis(ehpb)
 192 cd    print *,'EHPB exitted succesfully.'
 193 C
 194 C Calculate the virtual-bond-angle energy.
 195 C
 196       if (wang.gt.0d0) then
 197         call ebend(ebe)
 198       else
 199         ebe=0
 200       endif
 201 c      print *,"Processor",myrank," computed UB"
 202 C
 203 C Calculate the SC local energy.
 204 C
 205       call esc(escloc)
 206 c      print *,"Processor",myrank," computed USC"
 207 C
 208 C Calculate the virtual-bond torsional energy.
 209 C
 210 cd    print *,'nterm=',nterm
 211       if (wtor.gt.0) then
 212        call etor(etors,edihcnstr)
 213       else
 214        etors=0
 215        edihcnstr=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utor"
 218 C
 219 C 6/23/01 Calculate double-torsional energy
 220 C
 221       if (wtor_d.gt.0) then
 222        call etor_d(etors_d)
 223       else
 224        etors_d=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utord"
 227 C
 228 C 21/5/07 Calculate local sicdechain correlation energy
 229 C
 230       if (wsccor.gt.0.0d0) then
 231         call eback_sc_corr(esccor)
 232       else
 233         esccor=0.0d0
 234       endif
 235 c      print *,"Processor",myrank," computed Usccorr"
 236 C
 237 C 12/1/95 Multi-body terms
 238 C
 239       n_corr=0
 240       n_corr1=0
 241       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 242      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 243          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 244 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 245 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 246       else
 247          ecorr=0.0d0
 248          ecorr5=0.0d0
 249          ecorr6=0.0d0
 250          eturn6=0.0d0
 251       endif
 252       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 253          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 254 cd         write (iout,*) "multibody_hb ecorr",ecorr
 255       endif
 256 c      print *,"Processor",myrank," computed Ucorr"
 257 C
 258 C If performing constraint dynamics, call the constraint energy
 259 C  after the equilibration time
 260       if(usampl.and.totT.gt.eq_time) then
 261          call EconstrQ
 262          call Econstr_back
 263       else
 264          Uconst=0.0d0
 265          Uconst_back=0.0d0
 266       endif
 267 #ifdef TIMING
 268       time_enecalc=time_enecalc+MPI_Wtime()-time00
 269 #endif
 270 c      print *,"Processor",myrank," computed Uconstr"
 271 #ifdef TIMING
 272       time00=MPI_Wtime()
 273 #endif
 274 c
 275 C Sum the energies
 276 C
 277       energia(1)=evdw
 278 #ifdef SCP14
 279       energia(2)=evdw2-evdw2_14
 280       energia(18)=evdw2_14
 281 #else
 282       energia(2)=evdw2
 283       energia(18)=0.0d0
 284 #endif
 285 #ifdef SPLITELE
 286       energia(3)=ees
 287       energia(16)=evdw1
 288 #else
 289       energia(3)=ees+evdw1
 290       energia(16)=0.0d0
 291 #endif
 292       energia(4)=ecorr
 293       energia(5)=ecorr5
 294       energia(6)=ecorr6
 295       energia(7)=eel_loc
 296       energia(8)=eello_turn3
 297       energia(9)=eello_turn4
 298       energia(10)=eturn6
 299       energia(11)=ebe
 300       energia(12)=escloc
 301       energia(13)=etors
 302       energia(14)=etors_d
 303       energia(15)=ehpb
 304       energia(19)=edihcnstr
 305       energia(17)=estr
 306       energia(20)=Uconst+Uconst_back
 307       energia(21)=esccor
 308 c      print *," Processor",myrank," calls SUM_ENERGY"
 309       call sum_energy(energia,.true.)
 310       if (dyn_ss) call dyn_set_nss
 311 c      print *," Processor",myrank," left SUM_ENERGY"
 312 #ifdef TIMING
 313       time_sumene=time_sumene+MPI_Wtime()-time00
 314 #endif
 315       return
 316       end
 317 c-------------------------------------------------------------------------------
 318       subroutine sum_energy(energia,reduce)
 319       implicit real*8 (a-h,o-z)
 320       include 'DIMENSIONS'
 321 #ifndef ISNAN
 322       external proc_proc
 323 #ifdef WINPGI
 324 cMS$ATTRIBUTES C ::  proc_proc
 325 #endif
 326 #endif
 327 #ifdef MPI
 328       include "mpif.h"
 329 #endif
 330       include 'COMMON.SETUP'
 331       include 'COMMON.IOUNITS'
 332       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 333       include 'COMMON.FFIELD'
 334       include 'COMMON.DERIV'
 335       include 'COMMON.INTERACT'
 336       include 'COMMON.SBRIDGE'
 337       include 'COMMON.CHAIN'
 338       include 'COMMON.VAR'
 339       include 'COMMON.CONTROL'
 340       include 'COMMON.TIME1'
 341       logical reduce
 342 #ifdef MPI
 343       if (nfgtasks.gt.1 .and. reduce) then
 344 #ifdef DEBUG
 345         write (iout,*) "energies before REDUCE"
 346         call enerprint(energia)
 347         call flush(iout)
 348 #endif
 349         do i=0,n_ene
 350           enebuff(i)=energia(i)
 351         enddo
 352         time00=MPI_Wtime()
 353         call MPI_Barrier(FG_COMM,IERR)
 354         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 355         time00=MPI_Wtime()
 356         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 357      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 358 #ifdef DEBUG
 359         write (iout,*) "energies after REDUCE"
 360         call enerprint(energia)
 361         call flush(iout)
 362 #endif
 363         time_Reduce=time_Reduce+MPI_Wtime()-time00
 364       endif
 365       if (fg_rank.eq.0) then
 366 #endif
 367       evdw=energia(1)
 368 #ifdef SCP14
 369       evdw2=energia(2)+energia(18)
 370       evdw2_14=energia(18)
 371 #else
 372       evdw2=energia(2)
 373 #endif
 374 #ifdef SPLITELE
 375       ees=energia(3)
 376       evdw1=energia(16)
 377 #else
 378       ees=energia(3)
 379       evdw1=0.0d0
 380 #endif
 381       ecorr=energia(4)
 382       ecorr5=energia(5)
 383       ecorr6=energia(6)
 384       eel_loc=energia(7)
 385       eello_turn3=energia(8)
 386       eello_turn4=energia(9)
 387       eturn6=energia(10)
 388       ebe=energia(11)
 389       escloc=energia(12)
 390       etors=energia(13)
 391       etors_d=energia(14)
 392       ehpb=energia(15)
 393       edihcnstr=energia(19)
 394       estr=energia(17)
 395       Uconst=energia(20)
 396       esccor=energia(21)
 397 #ifdef SPLITELE
 398       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 399      & +wang*ebe+wtor*etors+wscloc*escloc
 400      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 401      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 402      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 403      & +wbond*estr+Uconst+wsccor*esccor
 404 #else
 405       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 406      & +wang*ebe+wtor*etors+wscloc*escloc
 407      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 408      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 409      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 410      & +wbond*estr+Uconst+wsccor*esccor
 411 #endif
 412       energia(0)=etot
 413 c detecting NaNQ
 414 #ifdef ISNAN
 415 #ifdef AIX
 416       if (isnan(etot).ne.0) energia(0)=1.0d+99
 417 #else
 418       if (isnan(etot)) energia(0)=1.0d+99
 419 #endif
 420 #else
 421       i=0
 422 #ifdef WINPGI
 423       idumm=proc_proc(etot,i)
 424 #else
 425       call proc_proc(etot,i)
 426 #endif
 427       if(i.eq.1)energia(0)=1.0d+99
 428 #endif
 429 #ifdef MPI
 430       endif
 431 #endif
 432       return
 433       end
 434 c-------------------------------------------------------------------------------
 435       subroutine sum_gradient
 436       implicit real*8 (a-h,o-z)
 437       include 'DIMENSIONS'
 438 #ifndef ISNAN
 439       external proc_proc
 440 #ifdef WINPGI
 441 cMS$ATTRIBUTES C ::  proc_proc
 442 #endif
 443 #endif
 444 #ifdef MPI
 445       include 'mpif.h'
 446 #endif
 447       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 448      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 449       include 'COMMON.SETUP'
 450       include 'COMMON.IOUNITS'
 451       include 'COMMON.FFIELD'
 452       include 'COMMON.DERIV'
 453       include 'COMMON.INTERACT'
 454       include 'COMMON.SBRIDGE'
 455       include 'COMMON.CHAIN'
 456       include 'COMMON.VAR'
 457       include 'COMMON.CONTROL'
 458       include 'COMMON.TIME1'
 459       include 'COMMON.MAXGRAD'
 460       include 'COMMON.SCCOR'
 461 #ifdef TIMING
 462       time01=MPI_Wtime()
 463 #endif
 464 #ifdef DEBUG
 465       write (iout,*) "sum_gradient gvdwc, gvdwx"
 466       do i=1,nres
 467         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 468      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 469       enddo
 470       call flush(iout)
 471 #endif
 472 #ifdef MPI
 473 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 474         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 475      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 476 #endif
 477 C
 478 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 479 C            in virtual-bond-vector coordinates
 480 C
 481 #ifdef DEBUG
 482 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 483 c      do i=1,nres-1
 484 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 485 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 486 c      enddo
 487 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 488 c      do i=1,nres-1
 489 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 490 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 491 c      enddo
 492       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 493       do i=1,nres
 494         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 495      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 496      &   g_corr5_loc(i)
 497       enddo
 498       call flush(iout)
 499 #endif
 500 #ifdef SPLITELE
 501       do i=1,nct
 502         do j=1,3
 503           gradbufc(j,i)=wsc*gvdwc(j,i)+
 504      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 505      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 506      &                wel_loc*gel_loc_long(j,i)+
 507      &                wcorr*gradcorr_long(j,i)+
 508      &                wcorr5*gradcorr5_long(j,i)+
 509      &                wcorr6*gradcorr6_long(j,i)+
 510      &                wturn6*gcorr6_turn_long(j,i)+
 511      &                wstrain*ghpbc(j,i)
 512         enddo
 513       enddo
 514 #else
 515       do i=1,nct
 516         do j=1,3
 517           gradbufc(j,i)=wsc*gvdwc(j,i)+
 518      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 519      &                welec*gelc_long(j,i)+
 520      &                wbond*gradb(j,i)+
 521      &                wel_loc*gel_loc_long(j,i)+
 522      &                wcorr*gradcorr_long(j,i)+
 523      &                wcorr5*gradcorr5_long(j,i)+
 524      &                wcorr6*gradcorr6_long(j,i)+
 525      &                wturn6*gcorr6_turn_long(j,i)+
 526      &                wstrain*ghpbc(j,i)
 527         enddo
 528       enddo
 529 #endif
 530 #ifdef MPI
 531       if (nfgtasks.gt.1) then
 532       time00=MPI_Wtime()
 533 #ifdef DEBUG
 534       write (iout,*) "gradbufc before allreduce"
 535       do i=1,nres
 536         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 537       enddo
 538       call flush(iout)
 539 #endif
 540       do i=1,nres
 541         do j=1,3
 542           gradbufc_sum(j,i)=gradbufc(j,i)
 543         enddo
 544       enddo
 545 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 546 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 547 c      time_reduce=time_reduce+MPI_Wtime()-time00
 548 #ifdef DEBUG
 549 c      write (iout,*) "gradbufc_sum after allreduce"
 550 c      do i=1,nres
 551 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 552 c      enddo
 553 c      call flush(iout)
 554 #endif
 555 #ifdef TIMING
 556 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 557 #endif
 558       do i=nnt,nres
 559         do k=1,3
 560           gradbufc(k,i)=0.0d0
 561         enddo
 562       enddo
 563 #ifdef DEBUG
 564       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 565       write (iout,*) (i," jgrad_start",jgrad_start(i),
 566      &                  " jgrad_end  ",jgrad_end(i),
 567      &                  i=igrad_start,igrad_end)
 568 #endif
 569 c
 570 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 571 c do not parallelize this part.
 572 c
 573 c      do i=igrad_start,igrad_end
 574 c        do j=jgrad_start(i),jgrad_end(i)
 575 c          do k=1,3
 576 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 577 c          enddo
 578 c        enddo
 579 c      enddo
 580       do j=1,3
 581         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 582       enddo
 583       do i=nres-2,nnt,-1
 584         do j=1,3
 585           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 586         enddo
 587       enddo
 588 #ifdef DEBUG
 589       write (iout,*) "gradbufc after summing"
 590       do i=1,nres
 591         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 592       enddo
 593       call flush(iout)
 594 #endif
 595       else
 596 #endif
 597 #ifdef DEBUG
 598       write (iout,*) "gradbufc"
 599       do i=1,nres
 600         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 601       enddo
 602       call flush(iout)
 603 #endif
 604       do i=1,nres
 605         do j=1,3
 606           gradbufc_sum(j,i)=gradbufc(j,i)
 607           gradbufc(j,i)=0.0d0
 608         enddo
 609       enddo
 610       do j=1,3
 611         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 612       enddo
 613       do i=nres-2,nnt,-1
 614         do j=1,3
 615           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 616         enddo
 617       enddo
 618 c      do i=nnt,nres-1
 619 c        do k=1,3
 620 c          gradbufc(k,i)=0.0d0
 621 c        enddo
 622 c        do j=i+1,nres
 623 c          do k=1,3
 624 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 625 c          enddo
 626 c        enddo
 627 c      enddo
 628 #ifdef DEBUG
 629       write (iout,*) "gradbufc after summing"
 630       do i=1,nres
 631         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 632       enddo
 633       call flush(iout)
 634 #endif
 635 #ifdef MPI
 636       endif
 637 #endif
 638       do k=1,3
 639         gradbufc(k,nres)=0.0d0
 640       enddo
 641       do i=1,nct
 642         do j=1,3
 643 #ifdef SPLITELE
 644           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 645      &                wel_loc*gel_loc(j,i)+
 646      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 647      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 648      &                wel_loc*gel_loc_long(j,i)+
 649      &                wcorr*gradcorr_long(j,i)+
 650      &                wcorr5*gradcorr5_long(j,i)+
 651      &                wcorr6*gradcorr6_long(j,i)+
 652      &                wturn6*gcorr6_turn_long(j,i))+
 653      &                wbond*gradb(j,i)+
 654      &                wcorr*gradcorr(j,i)+
 655      &                wturn3*gcorr3_turn(j,i)+
 656      &                wturn4*gcorr4_turn(j,i)+
 657      &                wcorr5*gradcorr5(j,i)+
 658      &                wcorr6*gradcorr6(j,i)+
 659      &                wturn6*gcorr6_turn(j,i)+
 660      &                wsccor*gsccorc(j,i)
 661      &               +wscloc*gscloc(j,i)
 662 #else
 663           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 664      &                wel_loc*gel_loc(j,i)+
 665      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 666      &                welec*gelc_long(j,i)
 667      &                wel_loc*gel_loc_long(j,i)+
 668      &                wcorr*gcorr_long(j,i)+
 669      &                wcorr5*gradcorr5_long(j,i)+
 670      &                wcorr6*gradcorr6_long(j,i)+
 671      &                wturn6*gcorr6_turn_long(j,i))+
 672      &                wbond*gradb(j,i)+
 673      &                wcorr*gradcorr(j,i)+
 674      &                wturn3*gcorr3_turn(j,i)+
 675      &                wturn4*gcorr4_turn(j,i)+
 676      &                wcorr5*gradcorr5(j,i)+
 677      &                wcorr6*gradcorr6(j,i)+
 678      &                wturn6*gcorr6_turn(j,i)+
 679      &                wsccor*gsccorc(j,i)
 680      &               +wscloc*gscloc(j,i)
 681 #endif
 682           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 683      &                  wbond*gradbx(j,i)+
 684      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 685      &                  wsccor*gsccorx(j,i)
 686      &                 +wscloc*gsclocx(j,i)
 687         enddo
 688       enddo
 689 #ifdef DEBUG
 690       write (iout,*) "gloc before adding corr"
 691       do i=1,4*nres
 692         write (iout,*) i,gloc(i,icg)
 693       enddo
 694 #endif
 695       do i=1,nres-3
 696         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 697      &   +wcorr5*g_corr5_loc(i)
 698      &   +wcorr6*g_corr6_loc(i)
 699      &   +wturn4*gel_loc_turn4(i)
 700      &   +wturn3*gel_loc_turn3(i)
 701      &   +wturn6*gel_loc_turn6(i)
 702      &   +wel_loc*gel_loc_loc(i)
 703       enddo
 704 #ifdef DEBUG
 705       write (iout,*) "gloc after adding corr"
 706       do i=1,4*nres
 707         write (iout,*) i,gloc(i,icg)
 708       enddo
 709 #endif
 710 #ifdef MPI
 711       if (nfgtasks.gt.1) then
 712         do j=1,3
 713           do i=1,nres
 714             gradbufc(j,i)=gradc(j,i,icg)
 715             gradbufx(j,i)=gradx(j,i,icg)
 716           enddo
 717         enddo
 718         do i=1,4*nres
 719           glocbuf(i)=gloc(i,icg)
 720         enddo
 721 #define DEBUG
 722 #ifdef DEBUG
 723       write (iout,*) "gloc_sc before reduce"
 724       do i=1,nres
 725        do j=1,1
 726         write (iout,*) i,j,gloc_sc(j,i,icg)
 727        enddo
 728       enddo
 729 #endif
 730 #undef DEBUG
 731         do i=1,nres
 732          do j=1,3
 733           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 734          enddo
 735         enddo
 736         time00=MPI_Wtime()
 737         call MPI_Barrier(FG_COMM,IERR)
 738         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 739         time00=MPI_Wtime()
 740         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 743      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 744         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 745      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 746         time_reduce=time_reduce+MPI_Wtime()-time00
 747         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 748      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 749         time_reduce=time_reduce+MPI_Wtime()-time00
 750 #define DEBUG
 751 #ifdef DEBUG
 752       write (iout,*) "gloc_sc after reduce"
 753       do i=1,nres
 754        do j=1,1
 755         write (iout,*) i,j,gloc_sc(j,i,icg)
 756        enddo
 757       enddo
 758 #endif
 759 #undef DEBUG
 760 #ifdef DEBUG
 761       write (iout,*) "gloc after reduce"
 762       do i=1,4*nres
 763         write (iout,*) i,gloc(i,icg)
 764       enddo
 765 #endif
 766       endif
 767 #endif
 768       if (gnorm_check) then
 769 c
 770 c Compute the maximum elements of the gradient
 771 c
 772       gvdwc_max=0.0d0
 773       gvdwc_scp_max=0.0d0
 774       gelc_max=0.0d0
 775       gvdwpp_max=0.0d0
 776       gradb_max=0.0d0
 777       ghpbc_max=0.0d0
 778       gradcorr_max=0.0d0
 779       gel_loc_max=0.0d0
 780       gcorr3_turn_max=0.0d0
 781       gcorr4_turn_max=0.0d0
 782       gradcorr5_max=0.0d0
 783       gradcorr6_max=0.0d0
 784       gcorr6_turn_max=0.0d0
 785       gsccorc_max=0.0d0
 786       gscloc_max=0.0d0
 787       gvdwx_max=0.0d0
 788       gradx_scp_max=0.0d0
 789       ghpbx_max=0.0d0
 790       gradxorr_max=0.0d0
 791       gsccorx_max=0.0d0
 792       gsclocx_max=0.0d0
 793       do i=1,nct
 794         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 795         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 796         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 797         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 798      &   gvdwc_scp_max=gvdwc_scp_norm
 799         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 800         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 801         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 802         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 803         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 804         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 805         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 806         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 807         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 808         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 809         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 810         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 811         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 812      &    gcorr3_turn(1,i)))
 813         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 814      &    gcorr3_turn_max=gcorr3_turn_norm
 815         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 816      &    gcorr4_turn(1,i)))
 817         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 818      &    gcorr4_turn_max=gcorr4_turn_norm
 819         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 820         if (gradcorr5_norm.gt.gradcorr5_max)
 821      &    gradcorr5_max=gradcorr5_norm
 822         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 823         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 824         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 825      &    gcorr6_turn(1,i)))
 826         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 827      &    gcorr6_turn_max=gcorr6_turn_norm
 828         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 829         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 830         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 831         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 832         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 833         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 834         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 835         if (gradx_scp_norm.gt.gradx_scp_max)
 836      &    gradx_scp_max=gradx_scp_norm
 837         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 838         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 839         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 840         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 841         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 842         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 843         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 844         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 845       enddo
 846       if (gradout) then
 847 #ifdef AIX
 848         open(istat,file=statname,position="append")
 849 #else
 850         open(istat,file=statname,access="append")
 851 #endif
 852         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 853      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 854      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 855      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 856      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 857      &     gsccorx_max,gsclocx_max
 858         close(istat)
 859         if (gvdwc_max.gt.1.0d4) then
 860           write (iout,*) "gvdwc gvdwx gradb gradbx"
 861           do i=nnt,nct
 862             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 863      &        gradb(j,i),gradbx(j,i),j=1,3)
 864           enddo
 865           call pdbout(0.0d0,'cipiszcze',iout)
 866           call flush(iout)
 867         endif
 868       endif
 869       endif
 870 #ifdef DEBUG
 871       write (iout,*) "gradc gradx gloc"
 872       do i=1,nres
 873         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 874      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 875       enddo
 876 #endif
 877 #ifdef TIMING
 878       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 879 #endif
 880       return
 881       end
 882 c-------------------------------------------------------------------------------
 883       subroutine rescale_weights(t_bath)
 884       implicit real*8 (a-h,o-z)
 885       include 'DIMENSIONS'
 886       include 'COMMON.IOUNITS'
 887       include 'COMMON.FFIELD'
 888       include 'COMMON.SBRIDGE'
 889       double precision kfac /2.4d0/
 890       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 891 c      facT=temp0/t_bath
 892 c      facT=2*temp0/(t_bath+temp0)
 893       if (rescale_mode.eq.0) then
 894         facT=1.0d0
 895         facT2=1.0d0
 896         facT3=1.0d0
 897         facT4=1.0d0
 898         facT5=1.0d0
 899       else if (rescale_mode.eq.1) then
 900         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 901         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 902         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 903         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 904         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 905       else if (rescale_mode.eq.2) then
 906         x=t_bath/temp0
 907         x2=x*x
 908         x3=x2*x
 909         x4=x3*x
 910         x5=x4*x
 911         facT=licznik/dlog(dexp(x)+dexp(-x))
 912         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 913         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 914         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 915         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 916       else
 917         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 918         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 919 #ifdef MPI
 920        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 921 #endif
 922        stop 555
 923       endif
 924       welec=weights(3)*fact
 925       wcorr=weights(4)*fact3
 926       wcorr5=weights(5)*fact4
 927       wcorr6=weights(6)*fact5
 928       wel_loc=weights(7)*fact2
 929       wturn3=weights(8)*fact2
 930       wturn4=weights(9)*fact3
 931       wturn6=weights(10)*fact5
 932       wtor=weights(13)*fact
 933       wtor_d=weights(14)*fact2
 934       wsccor=weights(21)*fact
 935
 936       return
 937       end
 938 C------------------------------------------------------------------------
 939       subroutine enerprint(energia)
 940       implicit real*8 (a-h,o-z)
 941       include 'DIMENSIONS'
 942       include 'COMMON.IOUNITS'
 943       include 'COMMON.FFIELD'
 944       include 'COMMON.SBRIDGE'
 945       include 'COMMON.MD'
 946       double precision energia(0:n_ene)
 947       etot=energia(0)
 948       evdw=energia(1)
 949       evdw2=energia(2)
 950 #ifdef SCP14
 951       evdw2=energia(2)+energia(18)
 952 #else
 953       evdw2=energia(2)
 954 #endif
 955       ees=energia(3)
 956 #ifdef SPLITELE
 957       evdw1=energia(16)
 958 #endif
 959       ecorr=energia(4)
 960       ecorr5=energia(5)
 961       ecorr6=energia(6)
 962       eel_loc=energia(7)
 963       eello_turn3=energia(8)
 964       eello_turn4=energia(9)
 965       eello_turn6=energia(10)
 966       ebe=energia(11)
 967       escloc=energia(12)
 968       etors=energia(13)
 969       etors_d=energia(14)
 970       ehpb=energia(15)
 971       edihcnstr=energia(19)
 972       estr=energia(17)
 973       Uconst=energia(20)
 974       esccor=energia(21)
 975 #ifdef SPLITELE
 976       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 977      &  estr,wbond,ebe,wang,
 978      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 979      &  ecorr,wcorr,
 980      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 981      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 982      &  edihcnstr,ebr*nss,
 983      &  Uconst,etot
 984    10 format (/'Virtual-chain energies:'//
 985      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 986      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 987      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 988      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 989      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 990      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 991      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 992      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 993      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 994      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 995      & ' (SS bridges & dist. cnstr.)'/
 996      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 999      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1000      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1001      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1002      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1003      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1004      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1005      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1006      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1007      & 'ETOT=  ',1pE16.6,' (total)')
1008 #else
1009       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1010      &  estr,wbond,ebe,wang,
1011      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1012      &  ecorr,wcorr,
1013      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1014      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1015      &  ebr*nss,Uconst,etot
1016    10 format (/'Virtual-chain energies:'//
1017      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1018      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1019      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1020      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1021      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1022      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1023      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1024      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1025      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1026      & ' (SS bridges & dist. cnstr.)'/
1027      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1029      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1030      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1031      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1032      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1033      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1034      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1035      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1036      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1037      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1038      & 'ETOT=  ',1pE16.6,' (total)')
1039 #endif
1040       return
1041       end
1042 C-----------------------------------------------------------------------
1043       subroutine elj(evdw)
1044 C
1045 C This subroutine calculates the interaction energy of nonbonded side chains
1046 C assuming the LJ potential of interaction.
1047 C
1048       implicit real*8 (a-h,o-z)
1049       include 'DIMENSIONS'
1050       parameter (accur=1.0d-10)
1051       include 'COMMON.GEO'
1052       include 'COMMON.VAR'
1053       include 'COMMON.LOCAL'
1054       include 'COMMON.CHAIN'
1055       include 'COMMON.DERIV'
1056       include 'COMMON.INTERACT'
1057       include 'COMMON.TORSION'
1058       include 'COMMON.SBRIDGE'
1059       include 'COMMON.NAMES'
1060       include 'COMMON.IOUNITS'
1061       include 'COMMON.CONTACTS'
1062       dimension gg(3)
1063 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1064       evdw=0.0D0
1065       do i=iatsc_s,iatsc_e
1066         itypi=itype(i)
1067         if (itypi.eq.21) cycle
1068         itypi1=itype(i+1)
1069         xi=c(1,nres+i)
1070         yi=c(2,nres+i)
1071         zi=c(3,nres+i)
1072 C Change 12/1/95
1073         num_conti=0
1074 C
1075 C Calculate SC interaction energy.
1076 C
1077         do iint=1,nint_gr(i)
1078 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1079 cd   &                  'iend=',iend(i,iint)
1080           do j=istart(i,iint),iend(i,iint)
1081             itypj=itype(j)
1082             if (itypj.eq.21) cycle
1083             xj=c(1,nres+j)-xi
1084             yj=c(2,nres+j)-yi
1085             zj=c(3,nres+j)-zi
1086 C Change 12/1/95 to calculate four-body interactions
1087             rij=xj*xj+yj*yj+zj*zj
1088             rrij=1.0D0/rij
1089 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1090             eps0ij=eps(itypi,itypj)
1091             fac=rrij**expon2
1092             e1=fac*fac*aa(itypi,itypj)
1093             e2=fac*bb(itypi,itypj)
1094             evdwij=e1+e2
1095 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1096 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1097 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1098 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1099 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1100 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1101             evdw=evdw+evdwij
1102 C
1103 C Calculate the components of the gradient in DC and X
1104 C
1105             fac=-rrij*(e1+evdwij)
1106             gg(1)=xj*fac
1107             gg(2)=yj*fac
1108             gg(3)=zj*fac
1109             do k=1,3
1110               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1111               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1112               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1113               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1114             enddo
1115 cgrad            do k=i,j-1
1116 cgrad              do l=1,3
1117 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1118 cgrad              enddo
1119 cgrad            enddo
1120 C
1121 C 12/1/95, revised on 5/20/97
1122 C
1123 C Calculate the contact function. The ith column of the array JCONT will
1124 C contain the numbers of atoms that make contacts with the atom I (of numbers
1125 C greater than I). The arrays FACONT and GACONT will contain the values of
1126 C the contact function and its derivative.
1127 C
1128 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1129 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1130 C Uncomment next line, if the correlation interactions are contact function only
1131             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1132               rij=dsqrt(rij)
1133               sigij=sigma(itypi,itypj)
1134               r0ij=rs0(itypi,itypj)
1135 C
1136 C Check whether the SC's are not too far to make a contact.
1137 C
1138               rcut=1.5d0*r0ij
1139               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1140 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1141 C
1142               if (fcont.gt.0.0D0) then
1143 C If the SC-SC distance if close to sigma, apply spline.
1144 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1145 cAdam &             fcont1,fprimcont1)
1146 cAdam           fcont1=1.0d0-fcont1
1147 cAdam           if (fcont1.gt.0.0d0) then
1148 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1149 cAdam             fcont=fcont*fcont1
1150 cAdam           endif
1151 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1152 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1153 cga             do k=1,3
1154 cga               gg(k)=gg(k)*eps0ij
1155 cga             enddo
1156 cga             eps0ij=-evdwij*eps0ij
1157 C Uncomment for AL's type of SC correlation interactions.
1158 cadam           eps0ij=-evdwij
1159                 num_conti=num_conti+1
1160                 jcont(num_conti,i)=j
1161                 facont(num_conti,i)=fcont*eps0ij
1162                 fprimcont=eps0ij*fprimcont/rij
1163                 fcont=expon*fcont
1164 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1165 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1166 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1167 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1168                 gacont(1,num_conti,i)=-fprimcont*xj
1169                 gacont(2,num_conti,i)=-fprimcont*yj
1170                 gacont(3,num_conti,i)=-fprimcont*zj
1171 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1172 cd              write (iout,'(2i3,3f10.5)')
1173 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1174               endif
1175             endif
1176           enddo      ! j
1177         enddo        ! iint
1178 C Change 12/1/95
1179         num_cont(i)=num_conti
1180       enddo          ! i
1181       do i=1,nct
1182         do j=1,3
1183           gvdwc(j,i)=expon*gvdwc(j,i)
1184           gvdwx(j,i)=expon*gvdwx(j,i)
1185         enddo
1186       enddo
1187 C******************************************************************************
1188 C
1189 C                              N O T E !!!
1190 C
1191 C To save time, the factor of EXPON has been extracted from ALL components
1192 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1193 C use!
1194 C
1195 C******************************************************************************
1196       return
1197       end
1198 C-----------------------------------------------------------------------------
1199       subroutine eljk(evdw)
1200 C
1201 C This subroutine calculates the interaction energy of nonbonded side chains
1202 C assuming the LJK potential of interaction.
1203 C
1204       implicit real*8 (a-h,o-z)
1205       include 'DIMENSIONS'
1206       include 'COMMON.GEO'
1207       include 'COMMON.VAR'
1208       include 'COMMON.LOCAL'
1209       include 'COMMON.CHAIN'
1210       include 'COMMON.DERIV'
1211       include 'COMMON.INTERACT'
1212       include 'COMMON.IOUNITS'
1213       include 'COMMON.NAMES'
1214       dimension gg(3)
1215       logical scheck
1216 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1217       evdw=0.0D0
1218       do i=iatsc_s,iatsc_e
1219         itypi=itype(i)
1220         if (itypi.eq.21) cycle
1221         itypi1=itype(i+1)
1222         xi=c(1,nres+i)
1223         yi=c(2,nres+i)
1224         zi=c(3,nres+i)
1225 C
1226 C Calculate SC interaction energy.
1227 C
1228         do iint=1,nint_gr(i)
1229           do j=istart(i,iint),iend(i,iint)
1230             itypj=itype(j)
1231             if (itypj.eq.21) cycle
1232             xj=c(1,nres+j)-xi
1233             yj=c(2,nres+j)-yi
1234             zj=c(3,nres+j)-zi
1235             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1236             fac_augm=rrij**expon
1237             e_augm=augm(itypi,itypj)*fac_augm
1238             r_inv_ij=dsqrt(rrij)
1239             rij=1.0D0/r_inv_ij
1240             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1241             fac=r_shift_inv**expon
1242             e1=fac*fac*aa(itypi,itypj)
1243             e2=fac*bb(itypi,itypj)
1244             evdwij=e_augm+e1+e2
1245 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1246 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1247 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1248 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1249 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1250 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1251 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1252             evdw=evdw+evdwij
1253 C
1254 C Calculate the components of the gradient in DC and X
1255 C
1256             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1257             gg(1)=xj*fac
1258             gg(2)=yj*fac
1259             gg(3)=zj*fac
1260             do k=1,3
1261               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1262               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1263               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1264               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1265             enddo
1266 cgrad            do k=i,j-1
1267 cgrad              do l=1,3
1268 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1269 cgrad              enddo
1270 cgrad            enddo
1271           enddo      ! j
1272         enddo        ! iint
1273       enddo          ! i
1274       do i=1,nct
1275         do j=1,3
1276           gvdwc(j,i)=expon*gvdwc(j,i)
1277           gvdwx(j,i)=expon*gvdwx(j,i)
1278         enddo
1279       enddo
1280       return
1281       end
1282 C-----------------------------------------------------------------------------
1283       subroutine ebp(evdw)
1284 C
1285 C This subroutine calculates the interaction energy of nonbonded side chains
1286 C assuming the Berne-Pechukas potential of interaction.
1287 C
1288       implicit real*8 (a-h,o-z)
1289       include 'DIMENSIONS'
1290       include 'COMMON.GEO'
1291       include 'COMMON.VAR'
1292       include 'COMMON.LOCAL'
1293       include 'COMMON.CHAIN'
1294       include 'COMMON.DERIV'
1295       include 'COMMON.NAMES'
1296       include 'COMMON.INTERACT'
1297       include 'COMMON.IOUNITS'
1298       include 'COMMON.CALC'
1299       common /srutu/ icall
1300 c     double precision rrsave(maxdim)
1301       logical lprn
1302       evdw=0.0D0
1303 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1304       evdw=0.0D0
1305 c     if (icall.eq.0) then
1306 c       lprn=.true.
1307 c     else
1308         lprn=.false.
1309 c     endif
1310       ind=0
1311       do i=iatsc_s,iatsc_e
1312         itypi=itype(i)
1313         if (itypi.eq.21) cycle
1314         itypi1=itype(i+1)
1315         xi=c(1,nres+i)
1316         yi=c(2,nres+i)
1317         zi=c(3,nres+i)
1318         dxi=dc_norm(1,nres+i)
1319         dyi=dc_norm(2,nres+i)
1320         dzi=dc_norm(3,nres+i)
1321 c        dsci_inv=dsc_inv(itypi)
1322         dsci_inv=vbld_inv(i+nres)
1323 C
1324 C Calculate SC interaction energy.
1325 C
1326         do iint=1,nint_gr(i)
1327           do j=istart(i,iint),iend(i,iint)
1328             ind=ind+1
1329             itypj=itype(j)
1330             if (itypj.eq.21) cycle
1331 c            dscj_inv=dsc_inv(itypj)
1332             dscj_inv=vbld_inv(j+nres)
1333             chi1=chi(itypi,itypj)
1334             chi2=chi(itypj,itypi)
1335             chi12=chi1*chi2
1336             chip1=chip(itypi)
1337             chip2=chip(itypj)
1338             chip12=chip1*chip2
1339             alf1=alp(itypi)
1340             alf2=alp(itypj)
1341             alf12=0.5D0*(alf1+alf2)
1342 C For diagnostics only!!!
1343 c           chi1=0.0D0
1344 c           chi2=0.0D0
1345 c           chi12=0.0D0
1346 c           chip1=0.0D0
1347 c           chip2=0.0D0
1348 c           chip12=0.0D0
1349 c           alf1=0.0D0
1350 c           alf2=0.0D0
1351 c           alf12=0.0D0
1352             xj=c(1,nres+j)-xi
1353             yj=c(2,nres+j)-yi
1354             zj=c(3,nres+j)-zi
1355             dxj=dc_norm(1,nres+j)
1356             dyj=dc_norm(2,nres+j)
1357             dzj=dc_norm(3,nres+j)
1358             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1359 cd          if (icall.eq.0) then
1360 cd            rrsave(ind)=rrij
1361 cd          else
1362 cd            rrij=rrsave(ind)
1363 cd          endif
1364             rij=dsqrt(rrij)
1365 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1366             call sc_angular
1367 C Calculate whole angle-dependent part of epsilon and contributions
1368 C to its derivatives
1369             fac=(rrij*sigsq)**expon2
1370             e1=fac*fac*aa(itypi,itypj)
1371             e2=fac*bb(itypi,itypj)
1372             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1373             eps2der=evdwij*eps3rt
1374             eps3der=evdwij*eps2rt
1375             evdwij=evdwij*eps2rt*eps3rt
1376             evdw=evdw+evdwij
1377             if (lprn) then
1378             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1379             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1380 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1381 cd     &        restyp(itypi),i,restyp(itypj),j,
1382 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1383 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1384 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1385 cd     &        evdwij
1386             endif
1387 C Calculate gradient components.
1388             e1=e1*eps1*eps2rt**2*eps3rt**2
1389             fac=-expon*(e1+evdwij)
1390             sigder=fac/sigsq
1391             fac=rrij*fac
1392 C Calculate radial part of the gradient
1393             gg(1)=xj*fac
1394             gg(2)=yj*fac
1395             gg(3)=zj*fac
1396 C Calculate the angular part of the gradient and sum add the contributions
1397 C to the appropriate components of the Cartesian gradient.
1398             call sc_grad
1399           enddo      ! j
1400         enddo        ! iint
1401       enddo          ! i
1402 c     stop
1403       return
1404       end
1405 C-----------------------------------------------------------------------------
1406       subroutine egb(evdw)
1407 C
1408 C This subroutine calculates the interaction energy of nonbonded side chains
1409 C assuming the Gay-Berne potential of interaction.
1410 C
1411       implicit real*8 (a-h,o-z)
1412       include 'DIMENSIONS'
1413       include 'COMMON.GEO'
1414       include 'COMMON.VAR'
1415       include 'COMMON.LOCAL'
1416       include 'COMMON.CHAIN'
1417       include 'COMMON.DERIV'
1418       include 'COMMON.NAMES'
1419       include 'COMMON.INTERACT'
1420       include 'COMMON.IOUNITS'
1421       include 'COMMON.CALC'
1422       include 'COMMON.CONTROL'
1423       include 'COMMON.SBRIDGE'
1424       logical lprn
1425       evdw=0.0D0
1426 ccccc      energy_dec=.false.
1427 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1428       evdw=0.0D0
1429       lprn=.false.
1430 c     if (icall.eq.0) lprn=.false.
1431       ind=0
1432       do i=iatsc_s,iatsc_e
1433         itypi=itype(i)
1434         if (itypi.eq.21) cycle
1435         itypi1=itype(i+1)
1436         xi=c(1,nres+i)
1437         yi=c(2,nres+i)
1438         zi=c(3,nres+i)
1439         dxi=dc_norm(1,nres+i)
1440         dyi=dc_norm(2,nres+i)
1441         dzi=dc_norm(3,nres+i)
1442 c        dsci_inv=dsc_inv(itypi)
1443         dsci_inv=vbld_inv(i+nres)
1444 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1445 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1446 C
1447 C Calculate SC interaction energy.
1448 C
1449         do iint=1,nint_gr(i)
1450           do j=istart(i,iint),iend(i,iint)
1451             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1452               call dyn_ssbond_ene(i,j,evdwij)
1453               evdw=evdw+evdwij
1454               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1455      &                        'evdw',i,j,evdwij,' ss'
1456             ELSE
1457             ind=ind+1
1458             itypj=itype(j)
1459             if (itypj.eq.21) cycle
1460 c            dscj_inv=dsc_inv(itypj)
1461             dscj_inv=vbld_inv(j+nres)
1462 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1463 c     &       1.0d0/vbld(j+nres)
1464 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1465             sig0ij=sigma(itypi,itypj)
1466             chi1=chi(itypi,itypj)
1467             chi2=chi(itypj,itypi)
1468             chi12=chi1*chi2
1469             chip1=chip(itypi)
1470             chip2=chip(itypj)
1471             chip12=chip1*chip2
1472             alf1=alp(itypi)
1473             alf2=alp(itypj)
1474             alf12=0.5D0*(alf1+alf2)
1475 C For diagnostics only!!!
1476 c           chi1=0.0D0
1477 c           chi2=0.0D0
1478 c           chi12=0.0D0
1479 c           chip1=0.0D0
1480 c           chip2=0.0D0
1481 c           chip12=0.0D0
1482 c           alf1=0.0D0
1483 c           alf2=0.0D0
1484 c           alf12=0.0D0
1485             xj=c(1,nres+j)-xi
1486             yj=c(2,nres+j)-yi
1487             zj=c(3,nres+j)-zi
1488             dxj=dc_norm(1,nres+j)
1489             dyj=dc_norm(2,nres+j)
1490             dzj=dc_norm(3,nres+j)
1491 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1492 c            write (iout,*) "j",j," dc_norm",
1493 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1494             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1495             rij=dsqrt(rrij)
1496 C Calculate angle-dependent terms of energy and contributions to their
1497 C derivatives.
1498             call sc_angular
1499             sigsq=1.0D0/sigsq
1500             sig=sig0ij*dsqrt(sigsq)
1501             rij_shift=1.0D0/rij-sig+sig0ij
1502 c for diagnostics; uncomment
1503 c            rij_shift=1.2*sig0ij
1504 C I hate to put IF's in the loops, but here don't have another choice!!!!
1505             if (rij_shift.le.0.0D0) then
1506               evdw=1.0D20
1507 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1508 cd     &        restyp(itypi),i,restyp(itypj),j,
1509 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1510               return
1511             endif
1512             sigder=-sig*sigsq
1513 c---------------------------------------------------------------
1514             rij_shift=1.0D0/rij_shift
1515             fac=rij_shift**expon
1516             e1=fac*fac*aa(itypi,itypj)
1517             e2=fac*bb(itypi,itypj)
1518             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1519             eps2der=evdwij*eps3rt
1520             eps3der=evdwij*eps2rt
1521 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1522 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1523             evdwij=evdwij*eps2rt*eps3rt
1524             evdw=evdw+evdwij
1525             if (lprn) then
1526             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1527             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1528             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1529      &        restyp(itypi),i,restyp(itypj),j,
1530      &        epsi,sigm,chi1,chi2,chip1,chip2,
1531      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1532      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1533      &        evdwij
1534             endif
1535
1536             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1537      &                        'evdw',i,j,evdwij
1538
1539 C Calculate gradient components.
1540             e1=e1*eps1*eps2rt**2*eps3rt**2
1541             fac=-expon*(e1+evdwij)*rij_shift
1542             sigder=fac*sigder
1543             fac=rij*fac
1544 c            fac=0.0d0
1545 C Calculate the radial part of the gradient
1546             gg(1)=xj*fac
1547             gg(2)=yj*fac
1548             gg(3)=zj*fac
1549 C Calculate angular part of the gradient.
1550             call sc_grad
1551             ENDIF    ! dyn_ss
1552           enddo      ! j
1553         enddo        ! iint
1554       enddo          ! i
1555 c      write (iout,*) "Number of loop steps in EGB:",ind
1556 cccc      energy_dec=.false.
1557       return
1558       end
1559 C-----------------------------------------------------------------------------
1560       subroutine egbv(evdw)
1561 C
1562 C This subroutine calculates the interaction energy of nonbonded side chains
1563 C assuming the Gay-Berne-Vorobjev potential of interaction.
1564 C
1565       implicit real*8 (a-h,o-z)
1566       include 'DIMENSIONS'
1567       include 'COMMON.GEO'
1568       include 'COMMON.VAR'
1569       include 'COMMON.LOCAL'
1570       include 'COMMON.CHAIN'
1571       include 'COMMON.DERIV'
1572       include 'COMMON.NAMES'
1573       include 'COMMON.INTERACT'
1574       include 'COMMON.IOUNITS'
1575       include 'COMMON.CALC'
1576       common /srutu/ icall
1577       logical lprn
1578       evdw=0.0D0
1579 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1580       evdw=0.0D0
1581       lprn=.false.
1582 c     if (icall.eq.0) lprn=.true.
1583       ind=0
1584       do i=iatsc_s,iatsc_e
1585         itypi=itype(i)
1586         if (itypi.eq.21) cycle
1587         itypi1=itype(i+1)
1588         xi=c(1,nres+i)
1589         yi=c(2,nres+i)
1590         zi=c(3,nres+i)
1591         dxi=dc_norm(1,nres+i)
1592         dyi=dc_norm(2,nres+i)
1593         dzi=dc_norm(3,nres+i)
1594 c        dsci_inv=dsc_inv(itypi)
1595         dsci_inv=vbld_inv(i+nres)
1596 C
1597 C Calculate SC interaction energy.
1598 C
1599         do iint=1,nint_gr(i)
1600           do j=istart(i,iint),iend(i,iint)
1601             ind=ind+1
1602             itypj=itype(j)
1603             if (itypj.eq.21) cycle
1604 c            dscj_inv=dsc_inv(itypj)
1605             dscj_inv=vbld_inv(j+nres)
1606             sig0ij=sigma(itypi,itypj)
1607             r0ij=r0(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             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1634             rij=dsqrt(rrij)
1635 C Calculate angle-dependent terms of energy and contributions to their
1636 C derivatives.
1637             call sc_angular
1638             sigsq=1.0D0/sigsq
1639             sig=sig0ij*dsqrt(sigsq)
1640             rij_shift=1.0D0/rij-sig+r0ij
1641 C I hate to put IF's in the loops, but here don't have another choice!!!!
1642             if (rij_shift.le.0.0D0) then
1643               evdw=1.0D20
1644               return
1645             endif
1646             sigder=-sig*sigsq
1647 c---------------------------------------------------------------
1648             rij_shift=1.0D0/rij_shift
1649             fac=rij_shift**expon
1650             e1=fac*fac*aa(itypi,itypj)
1651             e2=fac*bb(itypi,itypj)
1652             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1653             eps2der=evdwij*eps3rt
1654             eps3der=evdwij*eps2rt
1655             fac_augm=rrij**expon
1656             e_augm=augm(itypi,itypj)*fac_augm
1657             evdwij=evdwij*eps2rt*eps3rt
1658             evdw=evdw+evdwij+e_augm
1659             if (lprn) then
1660             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1661             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1662             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1663      &        restyp(itypi),i,restyp(itypj),j,
1664      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1665      &        chi1,chi2,chip1,chip2,
1666      &        eps1,eps2rt**2,eps3rt**2,
1667      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1668      &        evdwij+e_augm
1669             endif
1670 C Calculate gradient components.
1671             e1=e1*eps1*eps2rt**2*eps3rt**2
1672             fac=-expon*(e1+evdwij)*rij_shift
1673             sigder=fac*sigder
1674             fac=rij*fac-2*expon*rrij*e_augm
1675 C Calculate the radial part of the gradient
1676             gg(1)=xj*fac
1677             gg(2)=yj*fac
1678             gg(3)=zj*fac
1679 C Calculate angular part of the gradient.
1680             call sc_grad
1681           enddo      ! j
1682         enddo        ! iint
1683       enddo          ! i
1684       end
1685 C-----------------------------------------------------------------------------
1686       subroutine sc_angular
1687 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1688 C om12. Called by ebp, egb, and egbv.
1689       implicit none
1690       include 'COMMON.CALC'
1691       include 'COMMON.IOUNITS'
1692       erij(1)=xj*rij
1693       erij(2)=yj*rij
1694       erij(3)=zj*rij
1695       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1696       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1697       om12=dxi*dxj+dyi*dyj+dzi*dzj
1698       chiom12=chi12*om12
1699 C Calculate eps1(om12) and its derivative in om12
1700       faceps1=1.0D0-om12*chiom12
1701       faceps1_inv=1.0D0/faceps1
1702       eps1=dsqrt(faceps1_inv)
1703 C Following variable is eps1*deps1/dom12
1704       eps1_om12=faceps1_inv*chiom12
1705 c diagnostics only
1706 c      faceps1_inv=om12
1707 c      eps1=om12
1708 c      eps1_om12=1.0d0
1709 c      write (iout,*) "om12",om12," eps1",eps1
1710 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1711 C and om12.
1712       om1om2=om1*om2
1713       chiom1=chi1*om1
1714       chiom2=chi2*om2
1715       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1716       sigsq=1.0D0-facsig*faceps1_inv
1717       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1718       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1719       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1720 c diagnostics only
1721 c      sigsq=1.0d0
1722 c      sigsq_om1=0.0d0
1723 c      sigsq_om2=0.0d0
1724 c      sigsq_om12=0.0d0
1725 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1726 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1727 c     &    " eps1",eps1
1728 C Calculate eps2 and its derivatives in om1, om2, and om12.
1729       chipom1=chip1*om1
1730       chipom2=chip2*om2
1731       chipom12=chip12*om12
1732       facp=1.0D0-om12*chipom12
1733       facp_inv=1.0D0/facp
1734       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1735 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1736 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1737 C Following variable is the square root of eps2
1738       eps2rt=1.0D0-facp1*facp_inv
1739 C Following three variables are the derivatives of the square root of eps
1740 C in om1, om2, and om12.
1741       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1742       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1743       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1744 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1745       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1746 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1747 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1748 c     &  " eps2rt_om12",eps2rt_om12
1749 C Calculate whole angle-dependent part of epsilon and contributions
1750 C to its derivatives
1751       return
1752       end
1753 C----------------------------------------------------------------------------
1754       subroutine sc_grad
1755       implicit real*8 (a-h,o-z)
1756       include 'DIMENSIONS'
1757       include 'COMMON.CHAIN'
1758       include 'COMMON.DERIV'
1759       include 'COMMON.CALC'
1760       include 'COMMON.IOUNITS'
1761       double precision dcosom1(3),dcosom2(3)
1762       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1763       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1764       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1765      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1766 c diagnostics only
1767 c      eom1=0.0d0
1768 c      eom2=0.0d0
1769 c      eom12=evdwij*eps1_om12
1770 c end diagnostics
1771 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1772 c     &  " sigder",sigder
1773 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1774 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1775       do k=1,3
1776         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1777         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1778       enddo
1779       do k=1,3
1780         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1781       enddo
1782 c      write (iout,*) "gg",(gg(k),k=1,3)
1783       do k=1,3
1784         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1785      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1786      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1787         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1788      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1789      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1790 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1791 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1792 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1793 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1794       enddo
1795 C
1796 C Calculate the components of the gradient in DC and X
1797 C
1798 cgrad      do k=i,j-1
1799 cgrad        do l=1,3
1800 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1801 cgrad        enddo
1802 cgrad      enddo
1803       do l=1,3
1804         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1805         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1806       enddo
1807       return
1808       end
1809 C-----------------------------------------------------------------------
1810       subroutine e_softsphere(evdw)
1811 C
1812 C This subroutine calculates the interaction energy of nonbonded side chains
1813 C assuming the LJ potential of interaction.
1814 C
1815       implicit real*8 (a-h,o-z)
1816       include 'DIMENSIONS'
1817       parameter (accur=1.0d-10)
1818       include 'COMMON.GEO'
1819       include 'COMMON.VAR'
1820       include 'COMMON.LOCAL'
1821       include 'COMMON.CHAIN'
1822       include 'COMMON.DERIV'
1823       include 'COMMON.INTERACT'
1824       include 'COMMON.TORSION'
1825       include 'COMMON.SBRIDGE'
1826       include 'COMMON.NAMES'
1827       include 'COMMON.IOUNITS'
1828       include 'COMMON.CONTACTS'
1829       dimension gg(3)
1830 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1831       evdw=0.0D0
1832       do i=iatsc_s,iatsc_e
1833         itypi=itype(i)
1834         if (itypi.eq.21) cycle
1835         itypi1=itype(i+1)
1836         xi=c(1,nres+i)
1837         yi=c(2,nres+i)
1838         zi=c(3,nres+i)
1839 C
1840 C Calculate SC interaction energy.
1841 C
1842         do iint=1,nint_gr(i)
1843 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1844 cd   &                  'iend=',iend(i,iint)
1845           do j=istart(i,iint),iend(i,iint)
1846             itypj=itype(j)
1847             if (itypj.eq.21) cycle
1848             xj=c(1,nres+j)-xi
1849             yj=c(2,nres+j)-yi
1850             zj=c(3,nres+j)-zi
1851             rij=xj*xj+yj*yj+zj*zj
1852 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1853             r0ij=r0(itypi,itypj)
1854             r0ijsq=r0ij*r0ij
1855 c            print *,i,j,r0ij,dsqrt(rij)
1856             if (rij.lt.r0ijsq) then
1857               evdwij=0.25d0*(rij-r0ijsq)**2
1858               fac=rij-r0ijsq
1859             else
1860               evdwij=0.0d0
1861               fac=0.0d0
1862             endif
1863             evdw=evdw+evdwij
1864 C
1865 C Calculate the components of the gradient in DC and X
1866 C
1867             gg(1)=xj*fac
1868             gg(2)=yj*fac
1869             gg(3)=zj*fac
1870             do k=1,3
1871               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1872               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1873               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1874               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1875             enddo
1876 cgrad            do k=i,j-1
1877 cgrad              do l=1,3
1878 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1879 cgrad              enddo
1880 cgrad            enddo
1881           enddo ! j
1882         enddo ! iint
1883       enddo ! i
1884       return
1885       end
1886 C--------------------------------------------------------------------------
1887       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1888      &              eello_turn4)
1889 C
1890 C Soft-sphere potential of p-p interaction
1891 C
1892       implicit real*8 (a-h,o-z)
1893       include 'DIMENSIONS'
1894       include 'COMMON.CONTROL'
1895       include 'COMMON.IOUNITS'
1896       include 'COMMON.GEO'
1897       include 'COMMON.VAR'
1898       include 'COMMON.LOCAL'
1899       include 'COMMON.CHAIN'
1900       include 'COMMON.DERIV'
1901       include 'COMMON.INTERACT'
1902       include 'COMMON.CONTACTS'
1903       include 'COMMON.TORSION'
1904       include 'COMMON.VECTORS'
1905       include 'COMMON.FFIELD'
1906       dimension ggg(3)
1907 cd      write(iout,*) 'In EELEC_soft_sphere'
1908       ees=0.0D0
1909       evdw1=0.0D0
1910       eel_loc=0.0d0
1911       eello_turn3=0.0d0
1912       eello_turn4=0.0d0
1913       ind=0
1914       do i=iatel_s,iatel_e
1915         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1916         dxi=dc(1,i)
1917         dyi=dc(2,i)
1918         dzi=dc(3,i)
1919         xmedi=c(1,i)+0.5d0*dxi
1920         ymedi=c(2,i)+0.5d0*dyi
1921         zmedi=c(3,i)+0.5d0*dzi
1922         num_conti=0
1923 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1924         do j=ielstart(i),ielend(i)
1925           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1926           ind=ind+1
1927           iteli=itel(i)
1928           itelj=itel(j)
1929           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1930           r0ij=rpp(iteli,itelj)
1931           r0ijsq=r0ij*r0ij
1932           dxj=dc(1,j)
1933           dyj=dc(2,j)
1934           dzj=dc(3,j)
1935           xj=c(1,j)+0.5D0*dxj-xmedi
1936           yj=c(2,j)+0.5D0*dyj-ymedi
1937           zj=c(3,j)+0.5D0*dzj-zmedi
1938           rij=xj*xj+yj*yj+zj*zj
1939           if (rij.lt.r0ijsq) then
1940             evdw1ij=0.25d0*(rij-r0ijsq)**2
1941             fac=rij-r0ijsq
1942           else
1943             evdw1ij=0.0d0
1944             fac=0.0d0
1945           endif
1946           evdw1=evdw1+evdw1ij
1947 C
1948 C Calculate contributions to the Cartesian gradient.
1949 C
1950           ggg(1)=fac*xj
1951           ggg(2)=fac*yj
1952           ggg(3)=fac*zj
1953           do k=1,3
1954             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1955             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1956           enddo
1957 *
1958 * Loop over residues i+1 thru j-1.
1959 *
1960 cgrad          do k=i+1,j-1
1961 cgrad            do l=1,3
1962 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1963 cgrad            enddo
1964 cgrad          enddo
1965         enddo ! j
1966       enddo   ! i
1967 cgrad      do i=nnt,nct-1
1968 cgrad        do k=1,3
1969 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1970 cgrad        enddo
1971 cgrad        do j=i+1,nct-1
1972 cgrad          do k=1,3
1973 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1974 cgrad          enddo
1975 cgrad        enddo
1976 cgrad      enddo
1977       return
1978       end
1979 c------------------------------------------------------------------------------
1980       subroutine vec_and_deriv
1981       implicit real*8 (a-h,o-z)
1982       include 'DIMENSIONS'
1983 #ifdef MPI
1984       include 'mpif.h'
1985 #endif
1986       include 'COMMON.IOUNITS'
1987       include 'COMMON.GEO'
1988       include 'COMMON.VAR'
1989       include 'COMMON.LOCAL'
1990       include 'COMMON.CHAIN'
1991       include 'COMMON.VECTORS'
1992       include 'COMMON.SETUP'
1993       include 'COMMON.TIME1'
1994       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1995 C Compute the local reference systems. For reference system (i), the
1996 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1997 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1998 #ifdef PARVEC
1999       do i=ivec_start,ivec_end
2000 #else
2001       do i=1,nres-1
2002 #endif
2003           if (i.eq.nres-1) then
2004 C Case of the last full residue
2005 C Compute the Z-axis
2006             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2007             costh=dcos(pi-theta(nres))
2008             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2009             do k=1,3
2010               uz(k,i)=fac*uz(k,i)
2011             enddo
2012 C Compute the derivatives of uz
2013             uzder(1,1,1)= 0.0d0
2014             uzder(2,1,1)=-dc_norm(3,i-1)
2015             uzder(3,1,1)= dc_norm(2,i-1)
2016             uzder(1,2,1)= dc_norm(3,i-1)
2017             uzder(2,2,1)= 0.0d0
2018             uzder(3,2,1)=-dc_norm(1,i-1)
2019             uzder(1,3,1)=-dc_norm(2,i-1)
2020             uzder(2,3,1)= dc_norm(1,i-1)
2021             uzder(3,3,1)= 0.0d0
2022             uzder(1,1,2)= 0.0d0
2023             uzder(2,1,2)= dc_norm(3,i)
2024             uzder(3,1,2)=-dc_norm(2,i)
2025             uzder(1,2,2)=-dc_norm(3,i)
2026             uzder(2,2,2)= 0.0d0
2027             uzder(3,2,2)= dc_norm(1,i)
2028             uzder(1,3,2)= dc_norm(2,i)
2029             uzder(2,3,2)=-dc_norm(1,i)
2030             uzder(3,3,2)= 0.0d0
2031 C Compute the Y-axis
2032             facy=fac
2033             do k=1,3
2034               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2035             enddo
2036 C Compute the derivatives of uy
2037             do j=1,3
2038               do k=1,3
2039                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2040      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2041                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2042               enddo
2043               uyder(j,j,1)=uyder(j,j,1)-costh
2044               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2045             enddo
2046             do j=1,2
2047               do k=1,3
2048                 do l=1,3
2049                   uygrad(l,k,j,i)=uyder(l,k,j)
2050                   uzgrad(l,k,j,i)=uzder(l,k,j)
2051                 enddo
2052               enddo
2053             enddo
2054             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2055             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2056             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2057             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2058           else
2059 C Other residues
2060 C Compute the Z-axis
2061             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2062             costh=dcos(pi-theta(i+2))
2063             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2064             do k=1,3
2065               uz(k,i)=fac*uz(k,i)
2066             enddo
2067 C Compute the derivatives of uz
2068             uzder(1,1,1)= 0.0d0
2069             uzder(2,1,1)=-dc_norm(3,i+1)
2070             uzder(3,1,1)= dc_norm(2,i+1)
2071             uzder(1,2,1)= dc_norm(3,i+1)
2072             uzder(2,2,1)= 0.0d0
2073             uzder(3,2,1)=-dc_norm(1,i+1)
2074             uzder(1,3,1)=-dc_norm(2,i+1)
2075             uzder(2,3,1)= dc_norm(1,i+1)
2076             uzder(3,3,1)= 0.0d0
2077             uzder(1,1,2)= 0.0d0
2078             uzder(2,1,2)= dc_norm(3,i)
2079             uzder(3,1,2)=-dc_norm(2,i)
2080             uzder(1,2,2)=-dc_norm(3,i)
2081             uzder(2,2,2)= 0.0d0
2082             uzder(3,2,2)= dc_norm(1,i)
2083             uzder(1,3,2)= dc_norm(2,i)
2084             uzder(2,3,2)=-dc_norm(1,i)
2085             uzder(3,3,2)= 0.0d0
2086 C Compute the Y-axis
2087             facy=fac
2088             do k=1,3
2089               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2090             enddo
2091 C Compute the derivatives of uy
2092             do j=1,3
2093               do k=1,3
2094                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2095      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2096                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2097               enddo
2098               uyder(j,j,1)=uyder(j,j,1)-costh
2099               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2100             enddo
2101             do j=1,2
2102               do k=1,3
2103                 do l=1,3
2104                   uygrad(l,k,j,i)=uyder(l,k,j)
2105                   uzgrad(l,k,j,i)=uzder(l,k,j)
2106                 enddo
2107               enddo
2108             enddo
2109             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2110             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2111             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2112             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2113           endif
2114       enddo
2115       do i=1,nres-1
2116         vbld_inv_temp(1)=vbld_inv(i+1)
2117         if (i.lt.nres-1) then
2118           vbld_inv_temp(2)=vbld_inv(i+2)
2119           else
2120           vbld_inv_temp(2)=vbld_inv(i)
2121           endif
2122         do j=1,2
2123           do k=1,3
2124             do l=1,3
2125               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2126               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2127             enddo
2128           enddo
2129         enddo
2130       enddo
2131 #if defined(PARVEC) && defined(MPI)
2132       if (nfgtasks1.gt.1) then
2133         time00=MPI_Wtime()
2134 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2135 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2136 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2137         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2138      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2139      &   FG_COMM1,IERR)
2140         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2141      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2142      &   FG_COMM1,IERR)
2143         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2144      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2145      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2146         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2147      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2148      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2149         time_gather=time_gather+MPI_Wtime()-time00
2150       endif
2151 c      if (fg_rank.eq.0) then
2152 c        write (iout,*) "Arrays UY and UZ"
2153 c        do i=1,nres-1
2154 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2155 c     &     (uz(k,i),k=1,3)
2156 c        enddo
2157 c      endif
2158 #endif
2159       return
2160       end
2161 C-----------------------------------------------------------------------------
2162       subroutine check_vecgrad
2163       implicit real*8 (a-h,o-z)
2164       include 'DIMENSIONS'
2165       include 'COMMON.IOUNITS'
2166       include 'COMMON.GEO'
2167       include 'COMMON.VAR'
2168       include 'COMMON.LOCAL'
2169       include 'COMMON.CHAIN'
2170       include 'COMMON.VECTORS'
2171       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2172       dimension uyt(3,maxres),uzt(3,maxres)
2173       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2174       double precision delta /1.0d-7/
2175       call vec_and_deriv
2176 cd      do i=1,nres
2177 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2178 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2179 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2180 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2181 cd     &     (dc_norm(if90,i),if90=1,3)
2182 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2183 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2184 cd          write(iout,'(a)')
2185 cd      enddo
2186       do i=1,nres
2187         do j=1,2
2188           do k=1,3
2189             do l=1,3
2190               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2191               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2192             enddo
2193           enddo
2194         enddo
2195       enddo
2196       call vec_and_deriv
2197       do i=1,nres
2198         do j=1,3
2199           uyt(j,i)=uy(j,i)
2200           uzt(j,i)=uz(j,i)
2201         enddo
2202       enddo
2203       do i=1,nres
2204 cd        write (iout,*) 'i=',i
2205         do k=1,3
2206           erij(k)=dc_norm(k,i)
2207         enddo
2208         do j=1,3
2209           do k=1,3
2210             dc_norm(k,i)=erij(k)
2211           enddo
2212           dc_norm(j,i)=dc_norm(j,i)+delta
2213 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2214 c          do k=1,3
2215 c            dc_norm(k,i)=dc_norm(k,i)/fac
2216 c          enddo
2217 c          write (iout,*) (dc_norm(k,i),k=1,3)
2218 c          write (iout,*) (erij(k),k=1,3)
2219           call vec_and_deriv
2220           do k=1,3
2221             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2222             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2223             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2224             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2225           enddo
2226 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2227 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2228 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2229         enddo
2230         do k=1,3
2231           dc_norm(k,i)=erij(k)
2232         enddo
2233 cd        do k=1,3
2234 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2235 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2236 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2237 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2238 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2239 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2240 cd          write (iout,'(a)')
2241 cd        enddo
2242       enddo
2243       return
2244       end
2245 C--------------------------------------------------------------------------
2246       subroutine set_matrices
2247       implicit real*8 (a-h,o-z)
2248       include 'DIMENSIONS'
2249 #ifdef MPI
2250       include "mpif.h"
2251       include "COMMON.SETUP"
2252       integer IERR
2253       integer status(MPI_STATUS_SIZE)
2254 #endif
2255       include 'COMMON.IOUNITS'
2256       include 'COMMON.GEO'
2257       include 'COMMON.VAR'
2258       include 'COMMON.LOCAL'
2259       include 'COMMON.CHAIN'
2260       include 'COMMON.DERIV'
2261       include 'COMMON.INTERACT'
2262       include 'COMMON.CONTACTS'
2263       include 'COMMON.TORSION'
2264       include 'COMMON.VECTORS'
2265       include 'COMMON.FFIELD'
2266       double precision auxvec(2),auxmat(2,2)
2267 C
2268 C Compute the virtual-bond-torsional-angle dependent quantities needed
2269 C to calculate the el-loc multibody terms of various order.
2270 C
2271 #ifdef PARMAT
2272       do i=ivec_start+2,ivec_end+2
2273 #else
2274       do i=3,nres+1
2275 #endif
2276         if (i .lt. nres+1) then
2277           sin1=dsin(phi(i))
2278           cos1=dcos(phi(i))
2279           sintab(i-2)=sin1
2280           costab(i-2)=cos1
2281           obrot(1,i-2)=cos1
2282           obrot(2,i-2)=sin1
2283           sin2=dsin(2*phi(i))
2284           cos2=dcos(2*phi(i))
2285           sintab2(i-2)=sin2
2286           costab2(i-2)=cos2
2287           obrot2(1,i-2)=cos2
2288           obrot2(2,i-2)=sin2
2289           Ug(1,1,i-2)=-cos1
2290           Ug(1,2,i-2)=-sin1
2291           Ug(2,1,i-2)=-sin1
2292           Ug(2,2,i-2)= cos1
2293           Ug2(1,1,i-2)=-cos2
2294           Ug2(1,2,i-2)=-sin2
2295           Ug2(2,1,i-2)=-sin2
2296           Ug2(2,2,i-2)= cos2
2297         else
2298           costab(i-2)=1.0d0
2299           sintab(i-2)=0.0d0
2300           obrot(1,i-2)=1.0d0
2301           obrot(2,i-2)=0.0d0
2302           obrot2(1,i-2)=0.0d0
2303           obrot2(2,i-2)=0.0d0
2304           Ug(1,1,i-2)=1.0d0
2305           Ug(1,2,i-2)=0.0d0
2306           Ug(2,1,i-2)=0.0d0
2307           Ug(2,2,i-2)=1.0d0
2308           Ug2(1,1,i-2)=0.0d0
2309           Ug2(1,2,i-2)=0.0d0
2310           Ug2(2,1,i-2)=0.0d0
2311           Ug2(2,2,i-2)=0.0d0
2312         endif
2313         if (i .gt. 3 .and. i .lt. nres+1) then
2314           obrot_der(1,i-2)=-sin1
2315           obrot_der(2,i-2)= cos1
2316           Ugder(1,1,i-2)= sin1
2317           Ugder(1,2,i-2)=-cos1
2318           Ugder(2,1,i-2)=-cos1
2319           Ugder(2,2,i-2)=-sin1
2320           dwacos2=cos2+cos2
2321           dwasin2=sin2+sin2
2322           obrot2_der(1,i-2)=-dwasin2
2323           obrot2_der(2,i-2)= dwacos2
2324           Ug2der(1,1,i-2)= dwasin2
2325           Ug2der(1,2,i-2)=-dwacos2
2326           Ug2der(2,1,i-2)=-dwacos2
2327           Ug2der(2,2,i-2)=-dwasin2
2328         else
2329           obrot_der(1,i-2)=0.0d0
2330           obrot_der(2,i-2)=0.0d0
2331           Ugder(1,1,i-2)=0.0d0
2332           Ugder(1,2,i-2)=0.0d0
2333           Ugder(2,1,i-2)=0.0d0
2334           Ugder(2,2,i-2)=0.0d0
2335           obrot2_der(1,i-2)=0.0d0
2336           obrot2_der(2,i-2)=0.0d0
2337           Ug2der(1,1,i-2)=0.0d0
2338           Ug2der(1,2,i-2)=0.0d0
2339           Ug2der(2,1,i-2)=0.0d0
2340           Ug2der(2,2,i-2)=0.0d0
2341         endif
2342 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2343         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2344 c        write(iout,*) (itype(i-2))
2345           iti = itortyp(itype(i-2))
2346         else
2347           iti=ntortyp+1
2348         endif
2349 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2350         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2351           iti1 = itortyp(itype(i-1))
2352         else
2353           iti1=ntortyp+1
2354         endif
2355 cd        write (iout,*) '*******i',i,' iti1',iti
2356 cd        write (iout,*) 'b1',b1(:,iti)
2357 cd        write (iout,*) 'b2',b2(:,iti)
2358 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2359 c        if (i .gt. iatel_s+2) then
2360         if (i .gt. nnt+2) then
2361           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2362           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2363           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2364      &    then
2365           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2366           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2367           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2368           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2369           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2370           endif
2371         else
2372           do k=1,2
2373             Ub2(k,i-2)=0.0d0
2374             Ctobr(k,i-2)=0.0d0
2375             Dtobr2(k,i-2)=0.0d0
2376             do l=1,2
2377               EUg(l,k,i-2)=0.0d0
2378               CUg(l,k,i-2)=0.0d0
2379               DUg(l,k,i-2)=0.0d0
2380               DtUg2(l,k,i-2)=0.0d0
2381             enddo
2382           enddo
2383         endif
2384         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2385         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2386         do k=1,2
2387           muder(k,i-2)=Ub2der(k,i-2)
2388         enddo
2389 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2390         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2391           iti1 = itortyp(itype(i-1))
2392         else
2393           iti1=ntortyp+1
2394         endif
2395         do k=1,2
2396           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2397         enddo
2398 cd        write (iout,*) 'mu ',mu(:,i-2)
2399 cd        write (iout,*) 'mu1',mu1(:,i-2)
2400 cd        write (iout,*) 'mu2',mu2(:,i-2)
2401         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2402      &  then
2403         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2404         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2405         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2406         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2407         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2408 C Vectors and matrices dependent on a single virtual-bond dihedral.
2409         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2410         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2411         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2412         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2413         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2414         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2415         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2416         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2417         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2418         endif
2419       enddo
2420 C Matrices dependent on two consecutive virtual-bond dihedrals.
2421 C The order of matrices is from left to right.
2422       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2423      &then
2424 c      do i=max0(ivec_start,2),ivec_end
2425       do i=2,nres-1
2426         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2427         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2428         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2429         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2430         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2431         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2432         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2433         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2434       enddo
2435       endif
2436 #if defined(MPI) && defined(PARMAT)
2437 #ifdef DEBUG
2438 c      if (fg_rank.eq.0) then
2439         write (iout,*) "Arrays UG and UGDER before GATHER"
2440         do i=1,nres-1
2441           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2442      &     ((ug(l,k,i),l=1,2),k=1,2),
2443      &     ((ugder(l,k,i),l=1,2),k=1,2)
2444         enddo
2445         write (iout,*) "Arrays UG2 and UG2DER"
2446         do i=1,nres-1
2447           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2448      &     ((ug2(l,k,i),l=1,2),k=1,2),
2449      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2450         enddo
2451         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2452         do i=1,nres-1
2453           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2454      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2455      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2456         enddo
2457         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2458         do i=1,nres-1
2459           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2460      &     costab(i),sintab(i),costab2(i),sintab2(i)
2461         enddo
2462         write (iout,*) "Array MUDER"
2463         do i=1,nres-1
2464           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2465         enddo
2466 c      endif
2467 #endif
2468       if (nfgtasks.gt.1) then
2469         time00=MPI_Wtime()
2470 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2471 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2472 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2473 #ifdef MATGATHER
2474         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2475      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2476      &   FG_COMM1,IERR)
2477         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2478      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2479      &   FG_COMM1,IERR)
2480         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2481      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2482      &   FG_COMM1,IERR)
2483         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2484      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2485      &   FG_COMM1,IERR)
2486         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2487      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2488      &   FG_COMM1,IERR)
2489         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2490      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2491      &   FG_COMM1,IERR)
2492         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2493      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2494      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2495         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2496      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2497      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2498         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2499      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2500      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2501         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2502      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2503      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2504         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2505      &  then
2506         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2507      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2508      &   FG_COMM1,IERR)
2509         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2510      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2511      &   FG_COMM1,IERR)
2512         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2513      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2514      &   FG_COMM1,IERR)
2515        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2516      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2517      &   FG_COMM1,IERR)
2518         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2519      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2522      &   ivec_count(fg_rank1),
2523      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2524      &   FG_COMM1,IERR)
2525         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2526      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2527      &   FG_COMM1,IERR)
2528         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2529      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2530      &   FG_COMM1,IERR)
2531         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2532      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2533      &   FG_COMM1,IERR)
2534         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2535      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2536      &   FG_COMM1,IERR)
2537         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2538      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2539      &   FG_COMM1,IERR)
2540         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2541      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2542      &   FG_COMM1,IERR)
2543         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2544      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2545      &   FG_COMM1,IERR)
2546         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2547      &   ivec_count(fg_rank1),
2548      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2549      &   FG_COMM1,IERR)
2550         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2551      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2552      &   FG_COMM1,IERR)
2553        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2554      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2555      &   FG_COMM1,IERR)
2556         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2557      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2558      &   FG_COMM1,IERR)
2559        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2560      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2563      &   ivec_count(fg_rank1),
2564      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2565      &   FG_COMM1,IERR)
2566         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2567      &   ivec_count(fg_rank1),
2568      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2571      &   ivec_count(fg_rank1),
2572      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2573      &   MPI_MAT2,FG_COMM1,IERR)
2574         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2575      &   ivec_count(fg_rank1),
2576      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2577      &   MPI_MAT2,FG_COMM1,IERR)
2578         endif
2579 #else
2580 c Passes matrix info through the ring
2581       isend=fg_rank1
2582       irecv=fg_rank1-1
2583       if (irecv.lt.0) irecv=nfgtasks1-1
2584       iprev=irecv
2585       inext=fg_rank1+1
2586       if (inext.ge.nfgtasks1) inext=0
2587       do i=1,nfgtasks1-1
2588 c        write (iout,*) "isend",isend," irecv",irecv
2589 c        call flush(iout)
2590         lensend=lentyp(isend)
2591         lenrecv=lentyp(irecv)
2592 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2593 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2594 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2595 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2596 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2597 c        write (iout,*) "Gather ROTAT1"
2598 c        call flush(iout)
2599 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2600 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2601 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2602 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2603 c        write (iout,*) "Gather ROTAT2"
2604 c        call flush(iout)
2605         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2606      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2607      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2608      &   iprev,4400+irecv,FG_COMM,status,IERR)
2609 c        write (iout,*) "Gather ROTAT_OLD"
2610 c        call flush(iout)
2611         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2612      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2613      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2614      &   iprev,5500+irecv,FG_COMM,status,IERR)
2615 c        write (iout,*) "Gather PRECOMP11"
2616 c        call flush(iout)
2617         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2618      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2619      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2620      &   iprev,6600+irecv,FG_COMM,status,IERR)
2621 c        write (iout,*) "Gather PRECOMP12"
2622 c        call flush(iout)
2623         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2624      &  then
2625         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2626      &   MPI_ROTAT2(lensend),inext,7700+isend,
2627      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2628      &   iprev,7700+irecv,FG_COMM,status,IERR)
2629 c        write (iout,*) "Gather PRECOMP21"
2630 c        call flush(iout)
2631         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2632      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2633      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2634      &   iprev,8800+irecv,FG_COMM,status,IERR)
2635 c        write (iout,*) "Gather PRECOMP22"
2636 c        call flush(iout)
2637         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2638      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2639      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2640      &   MPI_PRECOMP23(lenrecv),
2641      &   iprev,9900+irecv,FG_COMM,status,IERR)
2642 c        write (iout,*) "Gather PRECOMP23"
2643 c        call flush(iout)
2644         endif
2645         isend=irecv
2646         irecv=irecv-1
2647         if (irecv.lt.0) irecv=nfgtasks1-1
2648       enddo
2649 #endif
2650         time_gather=time_gather+MPI_Wtime()-time00
2651       endif
2652 #ifdef DEBUG
2653 c      if (fg_rank.eq.0) then
2654         write (iout,*) "Arrays UG and UGDER"
2655         do i=1,nres-1
2656           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2657      &     ((ug(l,k,i),l=1,2),k=1,2),
2658      &     ((ugder(l,k,i),l=1,2),k=1,2)
2659         enddo
2660         write (iout,*) "Arrays UG2 and UG2DER"
2661         do i=1,nres-1
2662           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2663      &     ((ug2(l,k,i),l=1,2),k=1,2),
2664      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2665         enddo
2666         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2667         do i=1,nres-1
2668           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2669      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2670      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2671         enddo
2672         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2673         do i=1,nres-1
2674           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2675      &     costab(i),sintab(i),costab2(i),sintab2(i)
2676         enddo
2677         write (iout,*) "Array MUDER"
2678         do i=1,nres-1
2679           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2680         enddo
2681 c      endif
2682 #endif
2683 #endif
2684 cd      do i=1,nres
2685 cd        iti = itortyp(itype(i))
2686 cd        write (iout,*) i
2687 cd        do j=1,2
2688 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2689 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2690 cd        enddo
2691 cd      enddo
2692       return
2693       end
2694 C--------------------------------------------------------------------------
2695       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2696 C
2697 C This subroutine calculates the average interaction energy and its gradient
2698 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2699 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2700 C The potential depends both on the distance of peptide-group centers and on
2701 C the orientation of the CA-CA virtual bonds.
2702 C
2703       implicit real*8 (a-h,o-z)
2704 #ifdef MPI
2705       include 'mpif.h'
2706 #endif
2707       include 'DIMENSIONS'
2708       include 'COMMON.CONTROL'
2709       include 'COMMON.SETUP'
2710       include 'COMMON.IOUNITS'
2711       include 'COMMON.GEO'
2712       include 'COMMON.VAR'
2713       include 'COMMON.LOCAL'
2714       include 'COMMON.CHAIN'
2715       include 'COMMON.DERIV'
2716       include 'COMMON.INTERACT'
2717       include 'COMMON.CONTACTS'
2718       include 'COMMON.TORSION'
2719       include 'COMMON.VECTORS'
2720       include 'COMMON.FFIELD'
2721       include 'COMMON.TIME1'
2722       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2723      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2724       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2725      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),eel_loc_ij
2726       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2727      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2728      &    num_conti,j1,j2
2729 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2730 #ifdef MOMENT
2731       double precision scal_el /1.0d0/
2732 #else
2733       double precision scal_el /0.5d0/
2734 #endif
2735 C 12/13/98
2736 C 13-go grudnia roku pamietnego...
2737       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2738      &                   0.0d0,1.0d0,0.0d0,
2739      &                   0.0d0,0.0d0,1.0d0/
2740 cd      write(iout,*) 'In EELEC'
2741 cd      do i=1,nloctyp
2742 cd        write(iout,*) 'Type',i
2743 cd        write(iout,*) 'B1',B1(:,i)
2744 cd        write(iout,*) 'B2',B2(:,i)
2745 cd        write(iout,*) 'CC',CC(:,:,i)
2746 cd        write(iout,*) 'DD',DD(:,:,i)
2747 cd        write(iout,*) 'EE',EE(:,:,i)
2748 cd      enddo
2749 cd      call check_vecgrad
2750 cd      stop
2751       if (icheckgrad.eq.1) then
2752         do i=1,nres-1
2753           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2754           do k=1,3
2755             dc_norm(k,i)=dc(k,i)*fac
2756           enddo
2757 c          write (iout,*) 'i',i,' fac',fac
2758         enddo
2759       endif
2760       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2761      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2762      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2763 c        call vec_and_deriv
2764 #ifdef TIMING
2765         time01=MPI_Wtime()
2766 #endif
2767         call set_matrices
2768 c        write (iout,*) "after set matrices"
2769 #ifdef TIMING
2770         time_mat=time_mat+MPI_Wtime()-time01
2771 #endif
2772       endif
2773 cd      do i=1,nres-1
2774 cd        write (iout,*) 'i=',i
2775 cd        do k=1,3
2776 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2777 cd        enddo
2778 cd        do k=1,3
2779 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2780 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2781 cd        enddo
2782 cd      enddo
2783       t_eelecij=0.0d0
2784       ees=0.0D0
2785       evdw1=0.0D0
2786       eel_loc=0.0d0
2787       eello_turn3=0.0d0
2788       eello_turn4=0.0d0
2789       ind=0
2790       do i=1,nres
2791         num_cont_hb(i)=0
2792       enddo
2793 cd      print '(a)','Enter EELEC'
2794 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2795       do i=1,nres
2796         gel_loc_loc(i)=0.0d0
2797         gcorr_loc(i)=0.0d0
2798       enddo
2799 c
2800 c
2801 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2802 C
2803 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2804 C
2805 c      write(iout,*) "przed turnem3 loop"
2806       do i=iturn3_start,iturn3_end
2807         if (itype(i).eq.21 .or. itype(i+1).eq.21
2808      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2809         dxi=dc(1,i)
2810         dyi=dc(2,i)
2811         dzi=dc(3,i)
2812         dx_normi=dc_norm(1,i)
2813         dy_normi=dc_norm(2,i)
2814         dz_normi=dc_norm(3,i)
2815         xmedi=c(1,i)+0.5d0*dxi
2816         ymedi=c(2,i)+0.5d0*dyi
2817         zmedi=c(3,i)+0.5d0*dzi
2818         num_conti=0
2819         call eelecij(i,i+2,ees,evdw1,eel_loc)
2820         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2821         num_cont_hb(i)=num_conti
2822       enddo
2823       do i=iturn4_start,iturn4_end
2824         if (itype(i).eq.21 .or. itype(i+1).eq.21
2825      &    .or. itype(i+3).eq.21
2826      &    .or. itype(i+4).eq.21) cycle
2827         dxi=dc(1,i)
2828         dyi=dc(2,i)
2829         dzi=dc(3,i)
2830         dx_normi=dc_norm(1,i)
2831         dy_normi=dc_norm(2,i)
2832         dz_normi=dc_norm(3,i)
2833         xmedi=c(1,i)+0.5d0*dxi
2834         ymedi=c(2,i)+0.5d0*dyi
2835         zmedi=c(3,i)+0.5d0*dzi
2836         num_conti=num_cont_hb(i)
2837         call eelecij(i,i+3,ees,evdw1,eel_loc)
2838         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2839      &   call eturn4(i,eello_turn4)
2840         num_cont_hb(i)=num_conti
2841       enddo   ! i
2842 c
2843 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2844 c
2845       do i=iatel_s,iatel_e
2846         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2847         dxi=dc(1,i)
2848         dyi=dc(2,i)
2849         dzi=dc(3,i)
2850         dx_normi=dc_norm(1,i)
2851         dy_normi=dc_norm(2,i)
2852         dz_normi=dc_norm(3,i)
2853         xmedi=c(1,i)+0.5d0*dxi
2854         ymedi=c(2,i)+0.5d0*dyi
2855         zmedi=c(3,i)+0.5d0*dzi
2856 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2857         num_conti=num_cont_hb(i)
2858         do j=ielstart(i),ielend(i)
2859 c          write (iout,*) i,j,itype(i),itype(j)
2860           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2861           call eelecij(i,j,ees,evdw1,eel_loc)
2862         enddo ! j
2863         num_cont_hb(i)=num_conti
2864       enddo   ! i
2865 c      write (iout,*) "Number of loop steps in EELEC:",ind
2866 cd      do i=1,nres
2867 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2868 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2869 cd      enddo
2870 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2871 ccc      eel_loc=eel_loc+eello_turn3
2872 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2873       return
2874       end
2875 C-------------------------------------------------------------------------------
2876       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2877       implicit real*8 (a-h,o-z)
2878       include 'DIMENSIONS'
2879 #ifdef MPI
2880       include "mpif.h"
2881 #endif
2882       include 'COMMON.CONTROL'
2883       include 'COMMON.IOUNITS'
2884       include 'COMMON.GEO'
2885       include 'COMMON.VAR'
2886       include 'COMMON.LOCAL'
2887       include 'COMMON.CHAIN'
2888       include 'COMMON.DERIV'
2889       include 'COMMON.INTERACT'
2890       include 'COMMON.CONTACTS'
2891       include 'COMMON.TORSION'
2892       include 'COMMON.VECTORS'
2893       include 'COMMON.FFIELD'
2894       include 'COMMON.TIME1'
2895       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2896      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2897       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2898      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),a22,a23,a32,a33
2899       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2900      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2901      &    num_conti,j1,j2
2902 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2903 #ifdef MOMENT
2904       double precision scal_el /1.0d0/
2905 #else
2906       double precision scal_el /0.5d0/
2907 #endif
2908 C 12/13/98
2909 C 13-go grudnia roku pamietnego...
2910       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2911      &                   0.0d0,1.0d0,0.0d0,
2912      &                   0.0d0,0.0d0,1.0d0/
2913 c          time00=MPI_Wtime()
2914 cd      write (iout,*) "eelecij",i,j
2915 c          ind=ind+1
2916           iteli=itel(i)
2917           itelj=itel(j)
2918           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2919           aaa=app(iteli,itelj)
2920           bbb=bpp(iteli,itelj)
2921           ael6i=ael6(iteli,itelj)
2922           ael3i=ael3(iteli,itelj)
2923           dxj=dc(1,j)
2924           dyj=dc(2,j)
2925           dzj=dc(3,j)
2926           dx_normj=dc_norm(1,j)
2927           dy_normj=dc_norm(2,j)
2928           dz_normj=dc_norm(3,j)
2929           xj=c(1,j)+0.5D0*dxj-xmedi
2930           yj=c(2,j)+0.5D0*dyj-ymedi
2931           zj=c(3,j)+0.5D0*dzj-zmedi
2932           rij=xj*xj+yj*yj+zj*zj
2933           rrmij=1.0D0/rij
2934           rij=dsqrt(rij)
2935           rmij=1.0D0/rij
2936           r3ij=rrmij*rmij
2937           r6ij=r3ij*r3ij
2938           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2939           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2940           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2941           fac=cosa-3.0D0*cosb*cosg
2942           ev1=aaa*r6ij*r6ij
2943 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2944           if (j.eq.i+2) ev1=scal_el*ev1
2945           ev2=bbb*r6ij
2946           fac3=ael6i*r6ij
2947           fac4=ael3i*r3ij
2948           evdwij=ev1+ev2
2949           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2950           el2=fac4*fac
2951           eesij=el1+el2
2952 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2953           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2954           ees=ees+eesij
2955           evdw1=evdw1+evdwij
2956 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2957 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2958 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2959 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2960
2961           if (energy_dec) then
2962               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2963               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2964           endif
2965
2966 C
2967 C Calculate contributions to the Cartesian gradient.
2968 C
2969 #ifdef SPLITELE
2970           facvdw=-6*rrmij*(ev1+evdwij)
2971           facel=-3*rrmij*(el1+eesij)
2972           fac1=fac
2973           erij(1)=xj*rmij
2974           erij(2)=yj*rmij
2975           erij(3)=zj*rmij
2976 *
2977 * Radial derivatives. First process both termini of the fragment (i,j)
2978 *
2979           ggg(1)=facel*xj
2980           ggg(2)=facel*yj
2981           ggg(3)=facel*zj
2982 c          do k=1,3
2983 c            ghalf=0.5D0*ggg(k)
2984 c            gelc(k,i)=gelc(k,i)+ghalf
2985 c            gelc(k,j)=gelc(k,j)+ghalf
2986 c          enddo
2987 c 9/28/08 AL Gradient compotents will be summed only at the end
2988           do k=1,3
2989             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2990             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2991           enddo
2992 *
2993 * Loop over residues i+1 thru j-1.
2994 *
2995 cgrad          do k=i+1,j-1
2996 cgrad            do l=1,3
2997 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2998 cgrad            enddo
2999 cgrad          enddo
3000           ggg(1)=facvdw*xj
3001           ggg(2)=facvdw*yj
3002           ggg(3)=facvdw*zj
3003 c          do k=1,3
3004 c            ghalf=0.5D0*ggg(k)
3005 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3006 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3007 c          enddo
3008 c 9/28/08 AL Gradient compotents will be summed only at the end
3009           do k=1,3
3010             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3011             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3012           enddo
3013 *
3014 * Loop over residues i+1 thru j-1.
3015 *
3016 cgrad          do k=i+1,j-1
3017 cgrad            do l=1,3
3018 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3019 cgrad            enddo
3020 cgrad          enddo
3021 #else
3022           facvdw=ev1+evdwij
3023           facel=el1+eesij
3024           fac1=fac
3025           fac=-3*rrmij*(facvdw+facvdw+facel)
3026           erij(1)=xj*rmij
3027           erij(2)=yj*rmij
3028           erij(3)=zj*rmij
3029 *
3030 * Radial derivatives. First process both termini of the fragment (i,j)
3031 *
3032           ggg(1)=fac*xj
3033           ggg(2)=fac*yj
3034           ggg(3)=fac*zj
3035 c          do k=1,3
3036 c            ghalf=0.5D0*ggg(k)
3037 c            gelc(k,i)=gelc(k,i)+ghalf
3038 c            gelc(k,j)=gelc(k,j)+ghalf
3039 c          enddo
3040 c 9/28/08 AL Gradient compotents will be summed only at the end
3041           do k=1,3
3042             gelc_long(k,j)=gelc(k,j)+ggg(k)
3043             gelc_long(k,i)=gelc(k,i)-ggg(k)
3044           enddo
3045 *
3046 * Loop over residues i+1 thru j-1.
3047 *
3048 cgrad          do k=i+1,j-1
3049 cgrad            do l=1,3
3050 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3051 cgrad            enddo
3052 cgrad          enddo
3053 c 9/28/08 AL Gradient compotents will be summed only at the end
3054           ggg(1)=facvdw*xj
3055           ggg(2)=facvdw*yj
3056           ggg(3)=facvdw*zj
3057           do k=1,3
3058             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3059             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3060           enddo
3061 #endif
3062 *
3063 * Angular part
3064 *
3065           ecosa=2.0D0*fac3*fac1+fac4
3066           fac4=-3.0D0*fac4
3067           fac3=-6.0D0*fac3
3068           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3069           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3070           do k=1,3
3071             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3072             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3073           enddo
3074 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3075 cd   &          (dcosg(k),k=1,3)
3076           do k=1,3
3077             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3078           enddo
3079 c          do k=1,3
3080 c            ghalf=0.5D0*ggg(k)
3081 c            gelc(k,i)=gelc(k,i)+ghalf
3082 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3083 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3084 c            gelc(k,j)=gelc(k,j)+ghalf
3085 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3086 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3087 c          enddo
3088 cgrad          do k=i+1,j-1
3089 cgrad            do l=1,3
3090 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3091 cgrad            enddo
3092 cgrad          enddo
3093           do k=1,3
3094             gelc(k,i)=gelc(k,i)
3095      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3096      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3097             gelc(k,j)=gelc(k,j)
3098      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3099      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3100             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3101             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3102           enddo
3103           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3104      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3105      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3106 C
3107 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3108 C   energy of a peptide unit is assumed in the form of a second-order
3109 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3110 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3111 C   are computed for EVERY pair of non-contiguous peptide groups.
3112 C
3113           if (j.lt.nres-1) then
3114             j1=j+1
3115             j2=j-1
3116           else
3117             j1=j-1
3118             j2=j-2
3119           endif
3120           kkk=0
3121           do k=1,2
3122             do l=1,2
3123               kkk=kkk+1
3124               muij(kkk)=mu(k,i)*mu(l,j)
3125             enddo
3126           enddo
3127 cd         write (iout,*) 'EELEC: i',i,' j',j
3128 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3129 cd          write(iout,*) 'muij',muij
3130           ury=scalar(uy(1,i),erij)
3131           urz=scalar(uz(1,i),erij)
3132           vry=scalar(uy(1,j),erij)
3133           vrz=scalar(uz(1,j),erij)
3134           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3135           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3136           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3137           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3138           fac=dsqrt(-ael6i)*r3ij
3139           a22=a22*fac
3140           a23=a23*fac
3141           a32=a32*fac
3142           a33=a33*fac
3143 cd          write (iout,'(4i5,4f10.5)')
3144 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3145 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3146 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3147 cd     &      uy(:,j),uz(:,j)
3148 cd          write (iout,'(4f10.5)')
3149 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3150 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3151 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3152 cd           write (iout,'(9f10.5/)')
3153 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3154 C Derivatives of the elements of A in virtual-bond vectors
3155           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3156           do k=1,3
3157             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3158             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3159             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3160             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3161             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3162             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3163             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3164             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3165             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3166             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3167             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3168             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3169           enddo
3170 C Compute radial contributions to the gradient
3171           facr=-3.0d0*rrmij
3172           a22der=a22*facr
3173           a23der=a23*facr
3174           a32der=a32*facr
3175           a33der=a33*facr
3176           agg(1,1)=a22der*xj
3177           agg(2,1)=a22der*yj
3178           agg(3,1)=a22der*zj
3179           agg(1,2)=a23der*xj
3180           agg(2,2)=a23der*yj
3181           agg(3,2)=a23der*zj
3182           agg(1,3)=a32der*xj
3183           agg(2,3)=a32der*yj
3184           agg(3,3)=a32der*zj
3185           agg(1,4)=a33der*xj
3186           agg(2,4)=a33der*yj
3187           agg(3,4)=a33der*zj
3188 C Add the contributions coming from er
3189           fac3=-3.0d0*fac
3190           do k=1,3
3191             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3192             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3193             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3194             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3195           enddo
3196           do k=1,3
3197 C Derivatives in DC(i)
3198 cgrad            ghalf1=0.5d0*agg(k,1)
3199 cgrad            ghalf2=0.5d0*agg(k,2)
3200 cgrad            ghalf3=0.5d0*agg(k,3)
3201 cgrad            ghalf4=0.5d0*agg(k,4)
3202             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3203      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3204             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3205      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3206             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3207      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3208             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3209      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3210 C Derivatives in DC(i+1)
3211             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3212      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3213             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3214      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3215             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3216      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3217             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3218      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3219 C Derivatives in DC(j)
3220             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3221      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3222             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3223      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3224             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3225      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3226             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3227      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3228 C Derivatives in DC(j+1) or DC(nres-1)
3229             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3230      &      -3.0d0*vryg(k,3)*ury)
3231             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3232      &      -3.0d0*vrzg(k,3)*ury)
3233             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3234      &      -3.0d0*vryg(k,3)*urz)
3235             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3236      &      -3.0d0*vrzg(k,3)*urz)
3237 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3238 cgrad              do l=1,4
3239 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3240 cgrad              enddo
3241 cgrad            endif
3242           enddo
3243           acipa(1,1)=a22
3244           acipa(1,2)=a23
3245           acipa(2,1)=a32
3246           acipa(2,2)=a33
3247           a22=-a22
3248           a23=-a23
3249           do l=1,2
3250             do k=1,3
3251               agg(k,l)=-agg(k,l)
3252               aggi(k,l)=-aggi(k,l)
3253               aggi1(k,l)=-aggi1(k,l)
3254               aggj(k,l)=-aggj(k,l)
3255               aggj1(k,l)=-aggj1(k,l)
3256             enddo
3257           enddo
3258           if (j.lt.nres-1) then
3259             a22=-a22
3260             a32=-a32
3261             do l=1,3,2
3262               do k=1,3
3263                 agg(k,l)=-agg(k,l)
3264                 aggi(k,l)=-aggi(k,l)
3265                 aggi1(k,l)=-aggi1(k,l)
3266                 aggj(k,l)=-aggj(k,l)
3267                 aggj1(k,l)=-aggj1(k,l)
3268               enddo
3269             enddo
3270           else
3271             a22=-a22
3272             a23=-a23
3273             a32=-a32
3274             a33=-a33
3275             do l=1,4
3276               do k=1,3
3277                 agg(k,l)=-agg(k,l)
3278                 aggi(k,l)=-aggi(k,l)
3279                 aggi1(k,l)=-aggi1(k,l)
3280                 aggj(k,l)=-aggj(k,l)
3281                 aggj1(k,l)=-aggj1(k,l)
3282               enddo
3283             enddo
3284           endif
3285           ENDIF ! WCORR
3286           IF (wel_loc.gt.0.0d0) THEN
3287 C Contribution to the local-electrostatic energy coming from the i-j pair
3288           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3289      &     +a33*muij(4)
3290 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3291
3292           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3293      &            'eelloc',i,j,eel_loc_ij
3294
3295           eel_loc=eel_loc+eel_loc_ij
3296 C Partial derivatives in virtual-bond dihedral angles gamma
3297           if (i.gt.1)
3298      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3299      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3300      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3301           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3302      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3303      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3304 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3305           do l=1,3
3306             ggg(l)=agg(l,1)*muij(1)+
3307      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3308             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3309             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3310 cgrad            ghalf=0.5d0*ggg(l)
3311 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3312 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3313           enddo
3314 cgrad          do k=i+1,j2
3315 cgrad            do l=1,3
3316 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3317 cgrad            enddo
3318 cgrad          enddo
3319 C Remaining derivatives of eello
3320           do l=1,3
3321             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3322      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3323             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3324      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3325             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3326      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3327             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3328      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3329           enddo
3330           ENDIF
3331 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3332 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3333           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3334      &       .and. num_conti.le.maxconts) then
3335 c            write (iout,*) i,j," entered corr"
3336 C
3337 C Calculate the contact function. The ith column of the array JCONT will
3338 C contain the numbers of atoms that make contacts with the atom I (of numbers
3339 C greater than I). The arrays FACONT and GACONT will contain the values of
3340 C the contact function and its derivative.
3341 c           r0ij=1.02D0*rpp(iteli,itelj)
3342 c           r0ij=1.11D0*rpp(iteli,itelj)
3343             r0ij=2.20D0*rpp(iteli,itelj)
3344 c           r0ij=1.55D0*rpp(iteli,itelj)
3345             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3346             if (fcont.gt.0.0D0) then
3347               num_conti=num_conti+1
3348               if (num_conti.gt.maxconts) then
3349                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3350      &                         ' will skip next contacts for this conf.'
3351               else
3352                 jcont_hb(num_conti,i)=j
3353 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3354 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3355                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3356      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3357 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3358 C  terms.
3359                 d_cont(num_conti,i)=rij
3360 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3361 C     --- Electrostatic-interaction matrix ---
3362                 a_chuj(1,1,num_conti,i)=a22
3363                 a_chuj(1,2,num_conti,i)=a23
3364                 a_chuj(2,1,num_conti,i)=a32
3365                 a_chuj(2,2,num_conti,i)=a33
3366 C     --- Gradient of rij
3367                 do kkk=1,3
3368                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3369                 enddo
3370                 kkll=0
3371                 do k=1,2
3372                   do l=1,2
3373                     kkll=kkll+1
3374                     do m=1,3
3375                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3376                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3377                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3378                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3379                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3380                     enddo
3381                   enddo
3382                 enddo
3383                 ENDIF
3384                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3385 C Calculate contact energies
3386                 cosa4=4.0D0*cosa
3387                 wij=cosa-3.0D0*cosb*cosg
3388                 cosbg1=cosb+cosg
3389                 cosbg2=cosb-cosg
3390 c               fac3=dsqrt(-ael6i)/r0ij**3
3391                 fac3=dsqrt(-ael6i)*r3ij
3392 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3393                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3394                 if (ees0tmp.gt.0) then
3395                   ees0pij=dsqrt(ees0tmp)
3396                 else
3397                   ees0pij=0
3398                 endif
3399 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3400                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3401                 if (ees0tmp.gt.0) then
3402                   ees0mij=dsqrt(ees0tmp)
3403                 else
3404                   ees0mij=0
3405                 endif
3406 c               ees0mij=0.0D0
3407                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3408                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3409 C Diagnostics. Comment out or remove after debugging!
3410 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3411 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3412 c               ees0m(num_conti,i)=0.0D0
3413 C End diagnostics.
3414 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3415 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3416 C Angular derivatives of the contact function
3417                 ees0pij1=fac3/ees0pij
3418                 ees0mij1=fac3/ees0mij
3419                 fac3p=-3.0D0*fac3*rrmij
3420                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3421                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3422 c               ees0mij1=0.0D0
3423                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3424                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3425                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3426                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3427                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3428                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3429                 ecosap=ecosa1+ecosa2
3430                 ecosbp=ecosb1+ecosb2
3431                 ecosgp=ecosg1+ecosg2
3432                 ecosam=ecosa1-ecosa2
3433                 ecosbm=ecosb1-ecosb2
3434                 ecosgm=ecosg1-ecosg2
3435 C Diagnostics
3436 c               ecosap=ecosa1
3437 c               ecosbp=ecosb1
3438 c               ecosgp=ecosg1
3439 c               ecosam=0.0D0
3440 c               ecosbm=0.0D0
3441 c               ecosgm=0.0D0
3442 C End diagnostics
3443                 facont_hb(num_conti,i)=fcont
3444                 fprimcont=fprimcont/rij
3445 cd              facont_hb(num_conti,i)=1.0D0
3446 C Following line is for diagnostics.
3447 cd              fprimcont=0.0D0
3448                 do k=1,3
3449                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3450                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3451                 enddo
3452                 do k=1,3
3453                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3454                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3455                 enddo
3456                 gggp(1)=gggp(1)+ees0pijp*xj
3457                 gggp(2)=gggp(2)+ees0pijp*yj
3458                 gggp(3)=gggp(3)+ees0pijp*zj
3459                 gggm(1)=gggm(1)+ees0mijp*xj
3460                 gggm(2)=gggm(2)+ees0mijp*yj
3461                 gggm(3)=gggm(3)+ees0mijp*zj
3462 C Derivatives due to the contact function
3463                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3464                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3465                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3466                 do k=1,3
3467 c
3468 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3469 c          following the change of gradient-summation algorithm.
3470 c
3471 cgrad                  ghalfp=0.5D0*gggp(k)
3472 cgrad                  ghalfm=0.5D0*gggm(k)
3473                   gacontp_hb1(k,num_conti,i)=!ghalfp
3474      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3475      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3476                   gacontp_hb2(k,num_conti,i)=!ghalfp
3477      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3478      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3479                   gacontp_hb3(k,num_conti,i)=gggp(k)
3480                   gacontm_hb1(k,num_conti,i)=!ghalfm
3481      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3482      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3483                   gacontm_hb2(k,num_conti,i)=!ghalfm
3484      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3485      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3486                   gacontm_hb3(k,num_conti,i)=gggm(k)
3487                 enddo
3488 C Diagnostics. Comment out or remove after debugging!
3489 cdiag           do k=1,3
3490 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3491 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3492 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3493 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3494 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3495 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3496 cdiag           enddo
3497               ENDIF ! wcorr
3498               endif  ! num_conti.le.maxconts
3499             endif  ! fcont.gt.0
3500           endif    ! j.gt.i+1
3501           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3502             do k=1,4
3503               do l=1,3
3504                 ghalf=0.5d0*agg(l,k)
3505                 aggi(l,k)=aggi(l,k)+ghalf
3506                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3507                 aggj(l,k)=aggj(l,k)+ghalf
3508               enddo
3509             enddo
3510             if (j.eq.nres-1 .and. i.lt.j-2) then
3511               do k=1,4
3512                 do l=1,3
3513                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3514                 enddo
3515               enddo
3516             endif
3517           endif
3518 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3519       return
3520       end
3521 C-----------------------------------------------------------------------------
3522       subroutine eturn3(i,eello_turn3)
3523 C Third- and fourth-order contributions from turns
3524       implicit real*8 (a-h,o-z)
3525       include 'DIMENSIONS'
3526       include 'COMMON.IOUNITS'
3527       include 'COMMON.GEO'
3528       include 'COMMON.VAR'
3529       include 'COMMON.LOCAL'
3530       include 'COMMON.CHAIN'
3531       include 'COMMON.DERIV'
3532       include 'COMMON.INTERACT'
3533       include 'COMMON.CONTACTS'
3534       include 'COMMON.TORSION'
3535       include 'COMMON.VECTORS'
3536       include 'COMMON.FFIELD'
3537       include 'COMMON.CONTROL'
3538       dimension ggg(3)
3539       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3540      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3541      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3542       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3543      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3544       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3545      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3546      &    num_conti,j1,j2
3547       j=i+2
3548 c      write (iout,*) "eturn3",i,j,j1,j2
3549       a_temp(1,1)=a22
3550       a_temp(1,2)=a23
3551       a_temp(2,1)=a32
3552       a_temp(2,2)=a33
3553 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3554 C
3555 C               Third-order contributions
3556 C
3557 C                 (i+2)o----(i+3)
3558 C                      | |
3559 C                      | |
3560 C                 (i+1)o----i
3561 C
3562 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3563 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3564         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3565         call transpose2(auxmat(1,1),auxmat1(1,1))
3566         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3567         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3568         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3569      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3570 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3571 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3572 cd     &    ' eello_turn3_num',4*eello_turn3_num
3573 C Derivatives in gamma(i)
3574         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3575         call transpose2(auxmat2(1,1),auxmat3(1,1))
3576         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3577         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3578 C Derivatives in gamma(i+1)
3579         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3580         call transpose2(auxmat2(1,1),auxmat3(1,1))
3581         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3582         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3583      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3584 C Cartesian derivatives
3585         do l=1,3
3586 c            ghalf1=0.5d0*agg(l,1)
3587 c            ghalf2=0.5d0*agg(l,2)
3588 c            ghalf3=0.5d0*agg(l,3)
3589 c            ghalf4=0.5d0*agg(l,4)
3590           a_temp(1,1)=aggi(l,1)!+ghalf1
3591           a_temp(1,2)=aggi(l,2)!+ghalf2
3592           a_temp(2,1)=aggi(l,3)!+ghalf3
3593           a_temp(2,2)=aggi(l,4)!+ghalf4
3594           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3595           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3596      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3597           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3598           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3599           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3600           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3601           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3602           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3603      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3604           a_temp(1,1)=aggj(l,1)!+ghalf1
3605           a_temp(1,2)=aggj(l,2)!+ghalf2
3606           a_temp(2,1)=aggj(l,3)!+ghalf3
3607           a_temp(2,2)=aggj(l,4)!+ghalf4
3608           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3609           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3610      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3611           a_temp(1,1)=aggj1(l,1)
3612           a_temp(1,2)=aggj1(l,2)
3613           a_temp(2,1)=aggj1(l,3)
3614           a_temp(2,2)=aggj1(l,4)
3615           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3616           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3617      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3618         enddo
3619       return
3620       end
3621 C-------------------------------------------------------------------------------
3622       subroutine eturn4(i,eello_turn4)
3623 C Third- and fourth-order contributions from turns
3624       implicit real*8 (a-h,o-z)
3625       include 'DIMENSIONS'
3626       include 'COMMON.IOUNITS'
3627       include 'COMMON.GEO'
3628       include 'COMMON.VAR'
3629       include 'COMMON.LOCAL'
3630       include 'COMMON.CHAIN'
3631       include 'COMMON.DERIV'
3632       include 'COMMON.INTERACT'
3633       include 'COMMON.CONTACTS'
3634       include 'COMMON.TORSION'
3635       include 'COMMON.VECTORS'
3636       include 'COMMON.FFIELD'
3637       include 'COMMON.CONTROL'
3638       dimension ggg(3)
3639       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3640      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3641      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3642       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3643      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3644       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3645      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3646      &    num_conti,j1,j2
3647       j=i+3
3648 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3649 C
3650 C               Fourth-order contributions
3651 C
3652 C                 (i+3)o----(i+4)
3653 C                     /  |
3654 C               (i+2)o   |
3655 C                     \  |
3656 C                 (i+1)o----i
3657 C
3658 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3659 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3660 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3661         a_temp(1,1)=a22
3662         a_temp(1,2)=a23
3663         a_temp(2,1)=a32
3664         a_temp(2,2)=a33
3665         iti1=itortyp(itype(i+1))
3666         iti2=itortyp(itype(i+2))
3667         iti3=itortyp(itype(i+3))
3668         write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3669         call transpose2(EUg(1,1,i+1),e1t(1,1))
3670         call transpose2(Eug(1,1,i+2),e2t(1,1))
3671         call transpose2(Eug(1,1,i+3),e3t(1,1))
3672         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3673         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3674         s1=scalar2(b1(1,iti2),auxvec(1))
3675         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3676         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3677         s2=scalar2(b1(1,iti1),auxvec(1))
3678         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3679         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3680         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3681         eello_turn4=eello_turn4-(s1+s2+s3)
3682         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3683      &      'eturn4',i,j,-(s1+s2+s3)
3684 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3685 cd     &    ' eello_turn4_num',8*eello_turn4_num
3686 C Derivatives in gamma(i)
3687         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3688         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3689         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3690         s1=scalar2(b1(1,iti2),auxvec(1))
3691         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3692         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3693         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3694 C Derivatives in gamma(i+1)
3695         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3696         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3697         s2=scalar2(b1(1,iti1),auxvec(1))
3698         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3699         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3700         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3701         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3702 C Derivatives in gamma(i+2)
3703         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3704         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3705         s1=scalar2(b1(1,iti2),auxvec(1))
3706         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3707         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3708         s2=scalar2(b1(1,iti1),auxvec(1))
3709         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3710         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3711         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3712         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3713 C Cartesian derivatives
3714 C Derivatives of this turn contributions in DC(i+2)
3715         if (j.lt.nres-1) then
3716           do l=1,3
3717             a_temp(1,1)=agg(l,1)
3718             a_temp(1,2)=agg(l,2)
3719             a_temp(2,1)=agg(l,3)
3720             a_temp(2,2)=agg(l,4)
3721             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3722             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3723             s1=scalar2(b1(1,iti2),auxvec(1))
3724             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3725             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3726             s2=scalar2(b1(1,iti1),auxvec(1))
3727             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3728             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3729             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3730             ggg(l)=-(s1+s2+s3)
3731             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3732           enddo
3733         endif
3734 C Remaining derivatives of this turn contribution
3735         do l=1,3
3736           a_temp(1,1)=aggi(l,1)
3737           a_temp(1,2)=aggi(l,2)
3738           a_temp(2,1)=aggi(l,3)
3739           a_temp(2,2)=aggi(l,4)
3740           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3741           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3742           s1=scalar2(b1(1,iti2),auxvec(1))
3743           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3744           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3745           s2=scalar2(b1(1,iti1),auxvec(1))
3746           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3747           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3748           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3749           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3750           a_temp(1,1)=aggi1(l,1)
3751           a_temp(1,2)=aggi1(l,2)
3752           a_temp(2,1)=aggi1(l,3)
3753           a_temp(2,2)=aggi1(l,4)
3754           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3755           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3756           s1=scalar2(b1(1,iti2),auxvec(1))
3757           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3758           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3759           s2=scalar2(b1(1,iti1),auxvec(1))
3760           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3761           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3762           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3763           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3764           a_temp(1,1)=aggj(l,1)
3765           a_temp(1,2)=aggj(l,2)
3766           a_temp(2,1)=aggj(l,3)
3767           a_temp(2,2)=aggj(l,4)
3768           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3769           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3770           s1=scalar2(b1(1,iti2),auxvec(1))
3771           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3772           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3773           s2=scalar2(b1(1,iti1),auxvec(1))
3774           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3775           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3776           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3777           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3778           a_temp(1,1)=aggj1(l,1)
3779           a_temp(1,2)=aggj1(l,2)
3780           a_temp(2,1)=aggj1(l,3)
3781           a_temp(2,2)=aggj1(l,4)
3782           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3783           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3784           s1=scalar2(b1(1,iti2),auxvec(1))
3785           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3786           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3787           s2=scalar2(b1(1,iti1),auxvec(1))
3788           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3789           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3790           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3791 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3792           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3793         enddo
3794       return
3795       end
3796 C-----------------------------------------------------------------------------
3797       subroutine vecpr(u,v,w)
3798       implicit real*8(a-h,o-z)
3799       dimension u(3),v(3),w(3)
3800       w(1)=u(2)*v(3)-u(3)*v(2)
3801       w(2)=-u(1)*v(3)+u(3)*v(1)
3802       w(3)=u(1)*v(2)-u(2)*v(1)
3803       return
3804       end
3805 C-----------------------------------------------------------------------------
3806       subroutine unormderiv(u,ugrad,unorm,ungrad)
3807 C This subroutine computes the derivatives of a normalized vector u, given
3808 C the derivatives computed without normalization conditions, ugrad. Returns
3809 C ungrad.
3810       implicit none
3811       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3812       double precision vec(3)
3813       double precision scalar
3814       integer i,j
3815 c      write (2,*) 'ugrad',ugrad
3816 c      write (2,*) 'u',u
3817       do i=1,3
3818         vec(i)=scalar(ugrad(1,i),u(1))
3819       enddo
3820 c      write (2,*) 'vec',vec
3821       do i=1,3
3822         do j=1,3
3823           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3824         enddo
3825       enddo
3826 c      write (2,*) 'ungrad',ungrad
3827       return
3828       end
3829 C-----------------------------------------------------------------------------
3830       subroutine escp_soft_sphere(evdw2,evdw2_14)
3831 C
3832 C This subroutine calculates the excluded-volume interaction energy between
3833 C peptide-group centers and side chains and its gradient in virtual-bond and
3834 C side-chain vectors.
3835 C
3836       implicit real*8 (a-h,o-z)
3837       include 'DIMENSIONS'
3838       include 'COMMON.GEO'
3839       include 'COMMON.VAR'
3840       include 'COMMON.LOCAL'
3841       include 'COMMON.CHAIN'
3842       include 'COMMON.DERIV'
3843       include 'COMMON.INTERACT'
3844       include 'COMMON.FFIELD'
3845       include 'COMMON.IOUNITS'
3846       include 'COMMON.CONTROL'
3847       dimension ggg(3)
3848       evdw2=0.0D0
3849       evdw2_14=0.0d0
3850       r0_scp=4.5d0
3851 cd    print '(a)','Enter ESCP'
3852 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3853       do i=iatscp_s,iatscp_e
3854         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3855         iteli=itel(i)
3856         xi=0.5D0*(c(1,i)+c(1,i+1))
3857         yi=0.5D0*(c(2,i)+c(2,i+1))
3858         zi=0.5D0*(c(3,i)+c(3,i+1))
3859
3860         do iint=1,nscp_gr(i)
3861
3862         do j=iscpstart(i,iint),iscpend(i,iint)
3863           if (itype(j).eq.21) cycle
3864           itypj=itype(j)
3865 C Uncomment following three lines for SC-p interactions
3866 c         xj=c(1,nres+j)-xi
3867 c         yj=c(2,nres+j)-yi
3868 c         zj=c(3,nres+j)-zi
3869 C Uncomment following three lines for Ca-p interactions
3870           xj=c(1,j)-xi
3871           yj=c(2,j)-yi
3872           zj=c(3,j)-zi
3873           rij=xj*xj+yj*yj+zj*zj
3874           r0ij=r0_scp
3875           r0ijsq=r0ij*r0ij
3876           if (rij.lt.r0ijsq) then
3877             evdwij=0.25d0*(rij-r0ijsq)**2
3878             fac=rij-r0ijsq
3879           else
3880             evdwij=0.0d0
3881             fac=0.0d0
3882           endif
3883           evdw2=evdw2+evdwij
3884 C
3885 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3886 C
3887           ggg(1)=xj*fac
3888           ggg(2)=yj*fac
3889           ggg(3)=zj*fac
3890 cgrad          if (j.lt.i) then
3891 cd          write (iout,*) 'j<i'
3892 C Uncomment following three lines for SC-p interactions
3893 c           do k=1,3
3894 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3895 c           enddo
3896 cgrad          else
3897 cd          write (iout,*) 'j>i'
3898 cgrad            do k=1,3
3899 cgrad              ggg(k)=-ggg(k)
3900 C Uncomment following line for SC-p interactions
3901 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3902 cgrad            enddo
3903 cgrad          endif
3904 cgrad          do k=1,3
3905 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3906 cgrad          enddo
3907 cgrad          kstart=min0(i+1,j)
3908 cgrad          kend=max0(i-1,j-1)
3909 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3910 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3911 cgrad          do k=kstart,kend
3912 cgrad            do l=1,3
3913 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3914 cgrad            enddo
3915 cgrad          enddo
3916           do k=1,3
3917             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3918             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3919           enddo
3920         enddo
3921
3922         enddo ! iint
3923       enddo ! i
3924       return
3925       end
3926 C-----------------------------------------------------------------------------
3927       subroutine escp(evdw2,evdw2_14)
3928 C
3929 C This subroutine calculates the excluded-volume interaction energy between
3930 C peptide-group centers and side chains and its gradient in virtual-bond and
3931 C side-chain vectors.
3932 C
3933       implicit real*8 (a-h,o-z)
3934       include 'DIMENSIONS'
3935       include 'COMMON.GEO'
3936       include 'COMMON.VAR'
3937       include 'COMMON.LOCAL'
3938       include 'COMMON.CHAIN'
3939       include 'COMMON.DERIV'
3940       include 'COMMON.INTERACT'
3941       include 'COMMON.FFIELD'
3942       include 'COMMON.IOUNITS'
3943       include 'COMMON.CONTROL'
3944       dimension ggg(3)
3945       evdw2=0.0D0
3946       evdw2_14=0.0d0
3947 cd    print '(a)','Enter ESCP'
3948 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3949       do i=iatscp_s,iatscp_e
3950         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3951         iteli=itel(i)
3952         xi=0.5D0*(c(1,i)+c(1,i+1))
3953         yi=0.5D0*(c(2,i)+c(2,i+1))
3954         zi=0.5D0*(c(3,i)+c(3,i+1))
3955
3956         do iint=1,nscp_gr(i)
3957
3958         do j=iscpstart(i,iint),iscpend(i,iint)
3959           itypj=itype(j)
3960           if (itypj.eq.21) cycle
3961 C Uncomment following three lines for SC-p interactions
3962 c         xj=c(1,nres+j)-xi
3963 c         yj=c(2,nres+j)-yi
3964 c         zj=c(3,nres+j)-zi
3965 C Uncomment following three lines for Ca-p interactions
3966           xj=c(1,j)-xi
3967           yj=c(2,j)-yi
3968           zj=c(3,j)-zi
3969           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3970           fac=rrij**expon2
3971           e1=fac*fac*aad(itypj,iteli)
3972           e2=fac*bad(itypj,iteli)
3973           if (iabs(j-i) .le. 2) then
3974             e1=scal14*e1
3975             e2=scal14*e2
3976             evdw2_14=evdw2_14+e1+e2
3977           endif
3978           evdwij=e1+e2
3979           evdw2=evdw2+evdwij
3980           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3981      &        'evdw2',i,j,evdwij
3982 C
3983 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3984 C
3985           fac=-(evdwij+e1)*rrij
3986           ggg(1)=xj*fac
3987           ggg(2)=yj*fac
3988           ggg(3)=zj*fac
3989 cgrad          if (j.lt.i) then
3990 cd          write (iout,*) 'j<i'
3991 C Uncomment following three lines for SC-p interactions
3992 c           do k=1,3
3993 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3994 c           enddo
3995 cgrad          else
3996 cd          write (iout,*) 'j>i'
3997 cgrad            do k=1,3
3998 cgrad              ggg(k)=-ggg(k)
3999 C Uncomment following line for SC-p interactions
4000 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4001 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4002 cgrad            enddo
4003 cgrad          endif
4004 cgrad          do k=1,3
4005 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4006 cgrad          enddo
4007 cgrad          kstart=min0(i+1,j)
4008 cgrad          kend=max0(i-1,j-1)
4009 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4010 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4011 cgrad          do k=kstart,kend
4012 cgrad            do l=1,3
4013 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4014 cgrad            enddo
4015 cgrad          enddo
4016           do k=1,3
4017             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4018             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4019           enddo
4020         enddo
4021
4022         enddo ! iint
4023       enddo ! i
4024       do i=1,nct
4025         do j=1,3
4026           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4027           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4028           gradx_scp(j,i)=expon*gradx_scp(j,i)
4029         enddo
4030       enddo
4031 C******************************************************************************
4032 C
4033 C                              N O T E !!!
4034 C
4035 C To save time the factor EXPON has been extracted from ALL components
4036 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4037 C use!
4038 C
4039 C******************************************************************************
4040       return
4041       end
4042 C--------------------------------------------------------------------------
4043       subroutine edis(ehpb)
4044 C
4045 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4046 C
4047       implicit real*8 (a-h,o-z)
4048       include 'DIMENSIONS'
4049       include 'COMMON.SBRIDGE'
4050       include 'COMMON.CHAIN'
4051       include 'COMMON.DERIV'
4052       include 'COMMON.VAR'
4053       include 'COMMON.INTERACT'
4054       include 'COMMON.IOUNITS'
4055       dimension ggg(3)
4056       ehpb=0.0D0
4057 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4058 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4059       if (link_end.eq.0) return
4060       do i=link_start,link_end
4061 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4062 C CA-CA distance used in regularization of structure.
4063         ii=ihpb(i)
4064         jj=jhpb(i)
4065 C iii and jjj point to the residues for which the distance is assigned.
4066         if (ii.gt.nres) then
4067           iii=ii-nres
4068           jjj=jj-nres
4069         else
4070           iii=ii
4071           jjj=jj
4072         endif
4073 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4074 c     &    dhpb(i),dhpb1(i),forcon(i)
4075 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4076 C    distance and angle dependent SS bond potential.
4077 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4078 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4079         if (.not.dyn_ss .and. i.le.nss) then
4080 C 15/02/13 CC dynamic SSbond - additional check
4081          if (ii.gt.nres
4082      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4083           call ssbond_ene(iii,jjj,eij)
4084           ehpb=ehpb+2*eij
4085          endif
4086 cd          write (iout,*) "eij",eij
4087         else
4088 C Calculate the distance between the two points and its difference from the
4089 C target distance.
4090           dd=dist(ii,jj)
4091             rdis=dd-dhpb(i)
4092 C Get the force constant corresponding to this distance.
4093             waga=forcon(i)
4094 C Calculate the contribution to energy.
4095             ehpb=ehpb+waga*rdis*rdis
4096 C
4097 C Evaluate gradient.
4098 C
4099             fac=waga*rdis/dd
4100 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4101 cd   &   ' waga=',waga,' fac=',fac
4102             do j=1,3
4103               ggg(j)=fac*(c(j,jj)-c(j,ii))
4104             enddo
4105 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4106 C If this is a SC-SC distance, we need to calculate the contributions to the
4107 C Cartesian gradient in the SC vectors (ghpbx).
4108           if (iii.lt.ii) then
4109           do j=1,3
4110             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4111             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4112           enddo
4113           endif
4114 cgrad        do j=iii,jjj-1
4115 cgrad          do k=1,3
4116 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4117 cgrad          enddo
4118 cgrad        enddo
4119           do k=1,3
4120             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4121             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4122           enddo
4123         endif
4124       enddo
4125       ehpb=0.5D0*ehpb
4126       return
4127       end
4128 C--------------------------------------------------------------------------
4129       subroutine ssbond_ene(i,j,eij)
4130 C
4131 C Calculate the distance and angle dependent SS-bond potential energy
4132 C using a free-energy function derived based on RHF/6-31G** ab initio
4133 C calculations of diethyl disulfide.
4134 C
4135 C A. Liwo and U. Kozlowska, 11/24/03
4136 C
4137       implicit real*8 (a-h,o-z)
4138       include 'DIMENSIONS'
4139       include 'COMMON.SBRIDGE'
4140       include 'COMMON.CHAIN'
4141       include 'COMMON.DERIV'
4142       include 'COMMON.LOCAL'
4143       include 'COMMON.INTERACT'
4144       include 'COMMON.VAR'
4145       include 'COMMON.IOUNITS'
4146       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4147       itypi=itype(i)
4148       xi=c(1,nres+i)
4149       yi=c(2,nres+i)
4150       zi=c(3,nres+i)
4151       dxi=dc_norm(1,nres+i)
4152       dyi=dc_norm(2,nres+i)
4153       dzi=dc_norm(3,nres+i)
4154 c      dsci_inv=dsc_inv(itypi)
4155       dsci_inv=vbld_inv(nres+i)
4156       itypj=itype(j)
4157 c      dscj_inv=dsc_inv(itypj)
4158       dscj_inv=vbld_inv(nres+j)
4159       xj=c(1,nres+j)-xi
4160       yj=c(2,nres+j)-yi
4161       zj=c(3,nres+j)-zi
4162       dxj=dc_norm(1,nres+j)
4163       dyj=dc_norm(2,nres+j)
4164       dzj=dc_norm(3,nres+j)
4165       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4166       rij=dsqrt(rrij)
4167       erij(1)=xj*rij
4168       erij(2)=yj*rij
4169       erij(3)=zj*rij
4170       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4171       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4172       om12=dxi*dxj+dyi*dyj+dzi*dzj
4173       do k=1,3
4174         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4175         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4176       enddo
4177       rij=1.0d0/rij
4178       deltad=rij-d0cm
4179       deltat1=1.0d0-om1
4180       deltat2=1.0d0+om2
4181       deltat12=om2-om1+2.0d0
4182       cosphi=om12-om1*om2
4183       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4184      &  +akct*deltad*deltat12
4185      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4186 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4187 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4188 c     &  " deltat12",deltat12," eij",eij
4189       ed=2*akcm*deltad+akct*deltat12
4190       pom1=akct*deltad
4191       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4192       eom1=-2*akth*deltat1-pom1-om2*pom2
4193       eom2= 2*akth*deltat2+pom1-om1*pom2
4194       eom12=pom2
4195       do k=1,3
4196         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4197         ghpbx(k,i)=ghpbx(k,i)-ggk
4198      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4199      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4200         ghpbx(k,j)=ghpbx(k,j)+ggk
4201      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4202      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4203         ghpbc(k,i)=ghpbc(k,i)-ggk
4204         ghpbc(k,j)=ghpbc(k,j)+ggk
4205       enddo
4206 C
4207 C Calculate the components of the gradient in DC and X
4208 C
4209 cgrad      do k=i,j-1
4210 cgrad        do l=1,3
4211 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4212 cgrad        enddo
4213 cgrad      enddo
4214       return
4215       end
4216 C--------------------------------------------------------------------------
4217       subroutine ebond(estr)
4218 c
4219 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4220 c
4221       implicit real*8 (a-h,o-z)
4222       include 'DIMENSIONS'
4223       include 'COMMON.LOCAL'
4224       include 'COMMON.GEO'
4225       include 'COMMON.INTERACT'
4226       include 'COMMON.DERIV'
4227       include 'COMMON.VAR'
4228       include 'COMMON.CHAIN'
4229       include 'COMMON.IOUNITS'
4230       include 'COMMON.NAMES'
4231       include 'COMMON.FFIELD'
4232       include 'COMMON.CONTROL'
4233       include 'COMMON.SETUP'
4234       double precision u(3),ud(3)
4235       estr=0.0d0
4236       estr1=0.0d0
4237       do i=ibondp_start,ibondp_end
4238         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4239           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4240           do j=1,3
4241           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4242      &      *dc(j,i-1)/vbld(i)
4243           enddo
4244           if (energy_dec) write(iout,*)
4245      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4246         else
4247         diff = vbld(i)-vbldp0
4248         if (energy_dec) write (iout,*)
4249      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4250         estr=estr+diff*diff
4251         do j=1,3
4252           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4253         enddo
4254 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4255         endif
4256       enddo
4257       estr=0.5d0*AKP*estr+estr1
4258 c
4259 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4260 c
4261       do i=ibond_start,ibond_end
4262         iti=itype(i)
4263         if (iti.ne.10 .and. iti.ne.21) then
4264           nbi=nbondterm(iti)
4265           if (nbi.eq.1) then
4266             diff=vbld(i+nres)-vbldsc0(1,iti)
4267             if (energy_dec) write (iout,*)
4268      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4269      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4270             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4271             do j=1,3
4272               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4273             enddo
4274           else
4275             do j=1,nbi
4276               diff=vbld(i+nres)-vbldsc0(j,iti)
4277               ud(j)=aksc(j,iti)*diff
4278               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4279             enddo
4280             uprod=u(1)
4281             do j=2,nbi
4282               uprod=uprod*u(j)
4283             enddo
4284             usum=0.0d0
4285             usumsqder=0.0d0
4286             do j=1,nbi
4287               uprod1=1.0d0
4288               uprod2=1.0d0
4289               do k=1,nbi
4290                 if (k.ne.j) then
4291                   uprod1=uprod1*u(k)
4292                   uprod2=uprod2*u(k)*u(k)
4293                 endif
4294               enddo
4295               usum=usum+uprod1
4296               usumsqder=usumsqder+ud(j)*uprod2
4297             enddo
4298             estr=estr+uprod/usum
4299             do j=1,3
4300              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4301             enddo
4302           endif
4303         endif
4304       enddo
4305       return
4306       end
4307 #ifdef CRYST_THETA
4308 C--------------------------------------------------------------------------
4309       subroutine ebend(etheta)
4310 C
4311 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4312 C angles gamma and its derivatives in consecutive thetas and gammas.
4313 C
4314       implicit real*8 (a-h,o-z)
4315       include 'DIMENSIONS'
4316       include 'COMMON.LOCAL'
4317       include 'COMMON.GEO'
4318       include 'COMMON.INTERACT'
4319       include 'COMMON.DERIV'
4320       include 'COMMON.VAR'
4321       include 'COMMON.CHAIN'
4322       include 'COMMON.IOUNITS'
4323       include 'COMMON.NAMES'
4324       include 'COMMON.FFIELD'
4325       include 'COMMON.CONTROL'
4326       common /calcthet/ term1,term2,termm,diffak,ratak,
4327      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4328      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4329       double precision y(2),z(2)
4330       delta=0.02d0*pi
4331 c      time11=dexp(-2*time)
4332 c      time12=1.0d0
4333       etheta=0.0D0
4334 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4335       do i=ithet_start,ithet_end
4336         if (itype(i-1).eq.21) cycle
4337 C Zero the energy function and its derivative at 0 or pi.
4338         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4339         it=itype(i-1)
4340         if (i.gt.3 .and. itype(i-2).ne.21) then
4341 #ifdef OSF
4342           phii=phi(i)
4343           if (phii.ne.phii) phii=150.0
4344 #else
4345           phii=phi(i)
4346 #endif
4347           y(1)=dcos(phii)
4348           y(2)=dsin(phii)
4349         else
4350           y(1)=0.0D0
4351           y(2)=0.0D0
4352         endif
4353         if (i.lt.nres .and. itype(i).ne.21) then
4354 #ifdef OSF
4355           phii1=phi(i+1)
4356           if (phii1.ne.phii1) phii1=150.0
4357           phii1=pinorm(phii1)
4358           z(1)=cos(phii1)
4359 #else
4360           phii1=phi(i+1)
4361           z(1)=dcos(phii1)
4362 #endif
4363           z(2)=dsin(phii1)
4364         else
4365           z(1)=0.0D0
4366           z(2)=0.0D0
4367         endif
4368 C Calculate the "mean" value of theta from the part of the distribution
4369 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4370 C In following comments this theta will be referred to as t_c.
4371         thet_pred_mean=0.0d0
4372         do k=1,2
4373           athetk=athet(k,it)
4374           bthetk=bthet(k,it)
4375           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4376         enddo
4377         dthett=thet_pred_mean*ssd
4378         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4379 C Derivatives of the "mean" values in gamma1 and gamma2.
4380         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4381         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4382         if (theta(i).gt.pi-delta) then
4383           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4384      &         E_tc0)
4385           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4386           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4387           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4388      &        E_theta)
4389           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4390      &        E_tc)
4391         else if (theta(i).lt.delta) then
4392           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4393           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4394           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4395      &        E_theta)
4396           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4397           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4398      &        E_tc)
4399         else
4400           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4401      &        E_theta,E_tc)
4402         endif
4403         etheta=etheta+ethetai
4404         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4405      &      'ebend',i,ethetai
4406         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4407         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4408         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4409       enddo
4410 C Ufff.... We've done all this!!!
4411       return
4412       end
4413 C---------------------------------------------------------------------------
4414       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4415      &     E_tc)
4416       implicit real*8 (a-h,o-z)
4417       include 'DIMENSIONS'
4418       include 'COMMON.LOCAL'
4419       include 'COMMON.IOUNITS'
4420       common /calcthet/ term1,term2,termm,diffak,ratak,
4421      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4422      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4423 C Calculate the contributions to both Gaussian lobes.
4424 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4425 C The "polynomial part" of the "standard deviation" of this part of
4426 C the distribution.
4427         sig=polthet(3,it)
4428         do j=2,0,-1
4429           sig=sig*thet_pred_mean+polthet(j,it)
4430         enddo
4431 C Derivative of the "interior part" of the "standard deviation of the"
4432 C gamma-dependent Gaussian lobe in t_c.
4433         sigtc=3*polthet(3,it)
4434         do j=2,1,-1
4435           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4436         enddo
4437         sigtc=sig*sigtc
4438 C Set the parameters of both Gaussian lobes of the distribution.
4439 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4440         fac=sig*sig+sigc0(it)
4441         sigcsq=fac+fac
4442         sigc=1.0D0/sigcsq
4443 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4444         sigsqtc=-4.0D0*sigcsq*sigtc
4445 c       print *,i,sig,sigtc,sigsqtc
4446 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4447         sigtc=-sigtc/(fac*fac)
4448 C Following variable is sigma(t_c)**(-2)
4449         sigcsq=sigcsq*sigcsq
4450         sig0i=sig0(it)
4451         sig0inv=1.0D0/sig0i**2
4452         delthec=thetai-thet_pred_mean
4453         delthe0=thetai-theta0i
4454         term1=-0.5D0*sigcsq*delthec*delthec
4455         term2=-0.5D0*sig0inv*delthe0*delthe0
4456 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4457 C NaNs in taking the logarithm. We extract the largest exponent which is added
4458 C to the energy (this being the log of the distribution) at the end of energy
4459 C term evaluation for this virtual-bond angle.
4460         if (term1.gt.term2) then
4461           termm=term1
4462           term2=dexp(term2-termm)
4463           term1=1.0d0
4464         else
4465           termm=term2
4466           term1=dexp(term1-termm)
4467           term2=1.0d0
4468         endif
4469 C The ratio between the gamma-independent and gamma-dependent lobes of
4470 C the distribution is a Gaussian function of thet_pred_mean too.
4471         diffak=gthet(2,it)-thet_pred_mean
4472         ratak=diffak/gthet(3,it)**2
4473         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4474 C Let's differentiate it in thet_pred_mean NOW.
4475         aktc=ak*ratak
4476 C Now put together the distribution terms to make complete distribution.
4477         termexp=term1+ak*term2
4478         termpre=sigc+ak*sig0i
4479 C Contribution of the bending energy from this theta is just the -log of
4480 C the sum of the contributions from the two lobes and the pre-exponential
4481 C factor. Simple enough, isn't it?
4482         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4483 C NOW the derivatives!!!
4484 C 6/6/97 Take into account the deformation.
4485         E_theta=(delthec*sigcsq*term1
4486      &       +ak*delthe0*sig0inv*term2)/termexp
4487         E_tc=((sigtc+aktc*sig0i)/termpre
4488      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4489      &       aktc*term2)/termexp)
4490       return
4491       end
4492 c-----------------------------------------------------------------------------
4493       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4494       implicit real*8 (a-h,o-z)
4495       include 'DIMENSIONS'
4496       include 'COMMON.LOCAL'
4497       include 'COMMON.IOUNITS'
4498       common /calcthet/ term1,term2,termm,diffak,ratak,
4499      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4500      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4501       delthec=thetai-thet_pred_mean
4502       delthe0=thetai-theta0i
4503 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4504       t3 = thetai-thet_pred_mean
4505       t6 = t3**2
4506       t9 = term1
4507       t12 = t3*sigcsq
4508       t14 = t12+t6*sigsqtc
4509       t16 = 1.0d0
4510       t21 = thetai-theta0i
4511       t23 = t21**2
4512       t26 = term2
4513       t27 = t21*t26
4514       t32 = termexp
4515       t40 = t32**2
4516       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4517      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4518      & *(-t12*t9-ak*sig0inv*t27)
4519       return
4520       end
4521 #else
4522 C--------------------------------------------------------------------------
4523       subroutine ebend(etheta)
4524 C
4525 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4526 C angles gamma and its derivatives in consecutive thetas and gammas.
4527 C ab initio-derived potentials from
4528 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4529 C
4530       implicit real*8 (a-h,o-z)
4531       include 'DIMENSIONS'
4532       include 'COMMON.LOCAL'
4533       include 'COMMON.GEO'
4534       include 'COMMON.INTERACT'
4535       include 'COMMON.DERIV'
4536       include 'COMMON.VAR'
4537       include 'COMMON.CHAIN'
4538       include 'COMMON.IOUNITS'
4539       include 'COMMON.NAMES'
4540       include 'COMMON.FFIELD'
4541       include 'COMMON.CONTROL'
4542       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4543      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4544      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4545      & sinph1ph2(maxdouble,maxdouble)
4546       logical lprn /.false./, lprn1 /.false./
4547       etheta=0.0D0
4548       do i=ithet_start,ithet_end
4549         if (itype(i-1).eq.21) cycle
4550         dethetai=0.0d0
4551         dephii=0.0d0
4552         dephii1=0.0d0
4553         theti2=0.5d0*theta(i)
4554         ityp2=ithetyp(itype(i-1))
4555         do k=1,nntheterm
4556           coskt(k)=dcos(k*theti2)
4557           sinkt(k)=dsin(k*theti2)
4558         enddo
4559         if (i.gt.3 .and. itype(i-2).ne.21) then
4560 #ifdef OSF
4561           phii=phi(i)
4562           if (phii.ne.phii) phii=150.0
4563 #else
4564           phii=phi(i)
4565 #endif
4566           ityp1=ithetyp(itype(i-2))
4567           do k=1,nsingle
4568             cosph1(k)=dcos(k*phii)
4569             sinph1(k)=dsin(k*phii)
4570           enddo
4571         else
4572           phii=0.0d0
4573           ityp1=nthetyp+1
4574           do k=1,nsingle
4575             cosph1(k)=0.0d0
4576             sinph1(k)=0.0d0
4577           enddo
4578         endif
4579         if (i.lt.nres .and. itype(i).ne.21) then
4580 #ifdef OSF
4581           phii1=phi(i+1)
4582           if (phii1.ne.phii1) phii1=150.0
4583           phii1=pinorm(phii1)
4584 #else
4585           phii1=phi(i+1)
4586 #endif
4587           ityp3=ithetyp(itype(i))
4588           do k=1,nsingle
4589             cosph2(k)=dcos(k*phii1)
4590             sinph2(k)=dsin(k*phii1)
4591           enddo
4592         else
4593           phii1=0.0d0
4594           ityp3=nthetyp+1
4595           do k=1,nsingle
4596             cosph2(k)=0.0d0
4597             sinph2(k)=0.0d0
4598           enddo
4599         endif
4600         ethetai=aa0thet(ityp1,ityp2,ityp3)
4601         do k=1,ndouble
4602           do l=1,k-1
4603             ccl=cosph1(l)*cosph2(k-l)
4604             ssl=sinph1(l)*sinph2(k-l)
4605             scl=sinph1(l)*cosph2(k-l)
4606             csl=cosph1(l)*sinph2(k-l)
4607             cosph1ph2(l,k)=ccl-ssl
4608             cosph1ph2(k,l)=ccl+ssl
4609             sinph1ph2(l,k)=scl+csl
4610             sinph1ph2(k,l)=scl-csl
4611           enddo
4612         enddo
4613         if (lprn) then
4614         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4615      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4616         write (iout,*) "coskt and sinkt"
4617         do k=1,nntheterm
4618           write (iout,*) k,coskt(k),sinkt(k)
4619         enddo
4620         endif
4621         do k=1,ntheterm
4622           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4623           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4624      &      *coskt(k)
4625           if (lprn)
4626      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4627      &     " ethetai",ethetai
4628         enddo
4629         if (lprn) then
4630         write (iout,*) "cosph and sinph"
4631         do k=1,nsingle
4632           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4633         enddo
4634         write (iout,*) "cosph1ph2 and sinph2ph2"
4635         do k=2,ndouble
4636           do l=1,k-1
4637             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4638      &         sinph1ph2(l,k),sinph1ph2(k,l)
4639           enddo
4640         enddo
4641         write(iout,*) "ethetai",ethetai
4642         endif
4643         do m=1,ntheterm2
4644           do k=1,nsingle
4645             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4646      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4647      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4648      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4649             ethetai=ethetai+sinkt(m)*aux
4650             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4651             dephii=dephii+k*sinkt(m)*(
4652      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4653      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4654             dephii1=dephii1+k*sinkt(m)*(
4655      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4656      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4657             if (lprn)
4658      &      write (iout,*) "m",m," k",k," bbthet",
4659      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4660      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4661      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4662      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4663           enddo
4664         enddo
4665         if (lprn)
4666      &  write(iout,*) "ethetai",ethetai
4667         do m=1,ntheterm3
4668           do k=2,ndouble
4669             do l=1,k-1
4670               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4671      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4672      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4673      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4674               ethetai=ethetai+sinkt(m)*aux
4675               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4676               dephii=dephii+l*sinkt(m)*(
4677      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4678      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4679      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4680      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4681               dephii1=dephii1+(k-l)*sinkt(m)*(
4682      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4683      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4684      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4685      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4686               if (lprn) then
4687               write (iout,*) "m",m," k",k," l",l," ffthet",
4688      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4689      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4690      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4691      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4692               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4693      &            cosph1ph2(k,l)*sinkt(m),
4694      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4695               endif
4696             enddo
4697           enddo
4698         enddo
4699 10      continue
4700         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4701      &   i,theta(i)*rad2deg,phii*rad2deg,
4702      &   phii1*rad2deg,ethetai
4703         etheta=etheta+ethetai
4704         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4705         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4706         gloc(nphi+i-2,icg)=wang*dethetai
4707       enddo
4708       return
4709       end
4710 #endif
4711 #ifdef CRYST_SC
4712 c-----------------------------------------------------------------------------
4713       subroutine esc(escloc)
4714 C Calculate the local energy of a side chain and its derivatives in the
4715 C corresponding virtual-bond valence angles THETA and the spherical angles
4716 C ALPHA and OMEGA.
4717       implicit real*8 (a-h,o-z)
4718       include 'DIMENSIONS'
4719       include 'COMMON.GEO'
4720       include 'COMMON.LOCAL'
4721       include 'COMMON.VAR'
4722       include 'COMMON.INTERACT'
4723       include 'COMMON.DERIV'
4724       include 'COMMON.CHAIN'
4725       include 'COMMON.IOUNITS'
4726       include 'COMMON.NAMES'
4727       include 'COMMON.FFIELD'
4728       include 'COMMON.CONTROL'
4729       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4730      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4731       common /sccalc/ time11,time12,time112,theti,it,nlobit
4732       delta=0.02d0*pi
4733       escloc=0.0D0
4734 c     write (iout,'(a)') 'ESC'
4735       do i=loc_start,loc_end
4736         it=itype(i)
4737         if (it.eq.21) cycle
4738         if (it.eq.10) goto 1
4739         nlobit=nlob(it)
4740 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4741 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4742         theti=theta(i+1)-pipol
4743         x(1)=dtan(theti)
4744         x(2)=alph(i)
4745         x(3)=omeg(i)
4746
4747         if (x(2).gt.pi-delta) then
4748           xtemp(1)=x(1)
4749           xtemp(2)=pi-delta
4750           xtemp(3)=x(3)
4751           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4752           xtemp(2)=pi
4753           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4754           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4755      &        escloci,dersc(2))
4756           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4757      &        ddersc0(1),dersc(1))
4758           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4759      &        ddersc0(3),dersc(3))
4760           xtemp(2)=pi-delta
4761           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4762           xtemp(2)=pi
4763           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4764           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4765      &            dersc0(2),esclocbi,dersc02)
4766           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4767      &            dersc12,dersc01)
4768           call splinthet(x(2),0.5d0*delta,ss,ssd)
4769           dersc0(1)=dersc01
4770           dersc0(2)=dersc02
4771           dersc0(3)=0.0d0
4772           do k=1,3
4773             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4774           enddo
4775           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4776 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4777 c    &             esclocbi,ss,ssd
4778           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4779 c         escloci=esclocbi
4780 c         write (iout,*) escloci
4781         else if (x(2).lt.delta) then
4782           xtemp(1)=x(1)
4783           xtemp(2)=delta
4784           xtemp(3)=x(3)
4785           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4786           xtemp(2)=0.0d0
4787           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4788           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4789      &        escloci,dersc(2))
4790           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4791      &        ddersc0(1),dersc(1))
4792           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4793      &        ddersc0(3),dersc(3))
4794           xtemp(2)=delta
4795           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4796           xtemp(2)=0.0d0
4797           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4798           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4799      &            dersc0(2),esclocbi,dersc02)
4800           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4801      &            dersc12,dersc01)
4802           dersc0(1)=dersc01
4803           dersc0(2)=dersc02
4804           dersc0(3)=0.0d0
4805           call splinthet(x(2),0.5d0*delta,ss,ssd)
4806           do k=1,3
4807             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4808           enddo
4809           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4810 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4811 c    &             esclocbi,ss,ssd
4812           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4813 c         write (iout,*) escloci
4814         else
4815           call enesc(x,escloci,dersc,ddummy,.false.)
4816         endif
4817
4818         escloc=escloc+escloci
4819         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4820      &     'escloc',i,escloci
4821 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4822
4823         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4824      &   wscloc*dersc(1)
4825         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4826         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4827     1   continue
4828       enddo
4829       return
4830       end
4831 C---------------------------------------------------------------------------
4832       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4833       implicit real*8 (a-h,o-z)
4834       include 'DIMENSIONS'
4835       include 'COMMON.GEO'
4836       include 'COMMON.LOCAL'
4837       include 'COMMON.IOUNITS'
4838       common /sccalc/ time11,time12,time112,theti,it,nlobit
4839       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4840       double precision contr(maxlob,-1:1)
4841       logical mixed
4842 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4843         escloc_i=0.0D0
4844         do j=1,3
4845           dersc(j)=0.0D0
4846           if (mixed) ddersc(j)=0.0d0
4847         enddo
4848         x3=x(3)
4849
4850 C Because of periodicity of the dependence of the SC energy in omega we have
4851 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4852 C To avoid underflows, first compute & store the exponents.
4853
4854         do iii=-1,1
4855
4856           x(3)=x3+iii*dwapi
4857
4858           do j=1,nlobit
4859             do k=1,3
4860               z(k)=x(k)-censc(k,j,it)
4861             enddo
4862             do k=1,3
4863               Axk=0.0D0
4864               do l=1,3
4865                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4866               enddo
4867               Ax(k,j,iii)=Axk
4868             enddo
4869             expfac=0.0D0
4870             do k=1,3
4871               expfac=expfac+Ax(k,j,iii)*z(k)
4872             enddo
4873             contr(j,iii)=expfac
4874           enddo ! j
4875
4876         enddo ! iii
4877
4878         x(3)=x3
4879 C As in the case of ebend, we want to avoid underflows in exponentiation and
4880 C subsequent NaNs and INFs in energy calculation.
4881 C Find the largest exponent
4882         emin=contr(1,-1)
4883         do iii=-1,1
4884           do j=1,nlobit
4885             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4886           enddo
4887         enddo
4888         emin=0.5D0*emin
4889 cd      print *,'it=',it,' emin=',emin
4890
4891 C Compute the contribution to SC energy and derivatives
4892         do iii=-1,1
4893
4894           do j=1,nlobit
4895 #ifdef OSF
4896             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4897             if(adexp.ne.adexp) adexp=1.0
4898             expfac=dexp(adexp)
4899 #else
4900             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4901 #endif
4902 cd          print *,'j=',j,' expfac=',expfac
4903             escloc_i=escloc_i+expfac
4904             do k=1,3
4905               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4906             enddo
4907             if (mixed) then
4908               do k=1,3,2
4909                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4910      &            +gaussc(k,2,j,it))*expfac
4911               enddo
4912             endif
4913           enddo
4914
4915         enddo ! iii
4916
4917         dersc(1)=dersc(1)/cos(theti)**2
4918         ddersc(1)=ddersc(1)/cos(theti)**2
4919         ddersc(3)=ddersc(3)
4920
4921         escloci=-(dlog(escloc_i)-emin)
4922         do j=1,3
4923           dersc(j)=dersc(j)/escloc_i
4924         enddo
4925         if (mixed) then
4926           do j=1,3,2
4927             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4928           enddo
4929         endif
4930       return
4931       end
4932 C------------------------------------------------------------------------------
4933       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4934       implicit real*8 (a-h,o-z)
4935       include 'DIMENSIONS'
4936       include 'COMMON.GEO'
4937       include 'COMMON.LOCAL'
4938       include 'COMMON.IOUNITS'
4939       common /sccalc/ time11,time12,time112,theti,it,nlobit
4940       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4941       double precision contr(maxlob)
4942       logical mixed
4943
4944       escloc_i=0.0D0
4945
4946       do j=1,3
4947         dersc(j)=0.0D0
4948       enddo
4949
4950       do j=1,nlobit
4951         do k=1,2
4952           z(k)=x(k)-censc(k,j,it)
4953         enddo
4954         z(3)=dwapi
4955         do k=1,3
4956           Axk=0.0D0
4957           do l=1,3
4958             Axk=Axk+gaussc(l,k,j,it)*z(l)
4959           enddo
4960           Ax(k,j)=Axk
4961         enddo
4962         expfac=0.0D0
4963         do k=1,3
4964           expfac=expfac+Ax(k,j)*z(k)
4965         enddo
4966         contr(j)=expfac
4967       enddo ! j
4968
4969 C As in the case of ebend, we want to avoid underflows in exponentiation and
4970 C subsequent NaNs and INFs in energy calculation.
4971 C Find the largest exponent
4972       emin=contr(1)
4973       do j=1,nlobit
4974         if (emin.gt.contr(j)) emin=contr(j)
4975       enddo
4976       emin=0.5D0*emin
4977
4978 C Compute the contribution to SC energy and derivatives
4979
4980       dersc12=0.0d0
4981       do j=1,nlobit
4982         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4983         escloc_i=escloc_i+expfac
4984         do k=1,2
4985           dersc(k)=dersc(k)+Ax(k,j)*expfac
4986         enddo
4987         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4988      &            +gaussc(1,2,j,it))*expfac
4989         dersc(3)=0.0d0
4990       enddo
4991
4992       dersc(1)=dersc(1)/cos(theti)**2
4993       dersc12=dersc12/cos(theti)**2
4994       escloci=-(dlog(escloc_i)-emin)
4995       do j=1,2
4996         dersc(j)=dersc(j)/escloc_i
4997       enddo
4998       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4999       return
5000       end
5001 #else
5002 c----------------------------------------------------------------------------------
5003       subroutine esc(escloc)
5004 C Calculate the local energy of a side chain and its derivatives in the
5005 C corresponding virtual-bond valence angles THETA and the spherical angles
5006 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5007 C added by Urszula Kozlowska. 07/11/2007
5008 C
5009       implicit real*8 (a-h,o-z)
5010       include 'DIMENSIONS'
5011       include 'COMMON.GEO'
5012       include 'COMMON.LOCAL'
5013       include 'COMMON.VAR'
5014       include 'COMMON.SCROT'
5015       include 'COMMON.INTERACT'
5016       include 'COMMON.DERIV'
5017       include 'COMMON.CHAIN'
5018       include 'COMMON.IOUNITS'
5019       include 'COMMON.NAMES'
5020       include 'COMMON.FFIELD'
5021       include 'COMMON.CONTROL'
5022       include 'COMMON.VECTORS'
5023       double precision x_prime(3),y_prime(3),z_prime(3)
5024      &    , sumene,dsc_i,dp2_i,x(65),
5025      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5026      &    de_dxx,de_dyy,de_dzz,de_dt
5027       double precision s1_t,s1_6_t,s2_t,s2_6_t
5028       double precision
5029      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5030      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5031      & dt_dCi(3),dt_dCi1(3)
5032       common /sccalc/ time11,time12,time112,theti,it,nlobit
5033       delta=0.02d0*pi
5034       escloc=0.0D0
5035       do i=loc_start,loc_end
5036         if (itype(i).eq.21) cycle
5037         costtab(i+1) =dcos(theta(i+1))
5038         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5039         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5040         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5041         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5042         cosfac=dsqrt(cosfac2)
5043         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5044         sinfac=dsqrt(sinfac2)
5045         it=itype(i)
5046         if (it.eq.10) goto 1
5047 c
5048 C  Compute the axes of tghe local cartesian coordinates system; store in
5049 c   x_prime, y_prime and z_prime
5050 c
5051         do j=1,3
5052           x_prime(j) = 0.00
5053           y_prime(j) = 0.00
5054           z_prime(j) = 0.00
5055         enddo
5056 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5057 C     &   dc_norm(3,i+nres)
5058         do j = 1,3
5059           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5060           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5061         enddo
5062         do j = 1,3
5063           z_prime(j) = -uz(j,i-1)
5064         enddo
5065 c       write (2,*) "i",i
5066 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5067 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5068 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5069 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5070 c      & " xy",scalar(x_prime(1),y_prime(1)),
5071 c      & " xz",scalar(x_prime(1),z_prime(1)),
5072 c      & " yy",scalar(y_prime(1),y_prime(1)),
5073 c      & " yz",scalar(y_prime(1),z_prime(1)),
5074 c      & " zz",scalar(z_prime(1),z_prime(1))
5075 c
5076 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5077 C to local coordinate system. Store in xx, yy, zz.
5078 c
5079         xx=0.0d0
5080         yy=0.0d0
5081         zz=0.0d0
5082         do j = 1,3
5083           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5084           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5085           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5086         enddo
5087
5088         xxtab(i)=xx
5089         yytab(i)=yy
5090         zztab(i)=zz
5091 C
5092 C Compute the energy of the ith side cbain
5093 C
5094 c        write (2,*) "xx",xx," yy",yy," zz",zz
5095         it=itype(i)
5096         do j = 1,65
5097           x(j) = sc_parmin(j,it)
5098         enddo
5099 #ifdef CHECK_COORD
5100 Cc diagnostics - remove later
5101         xx1 = dcos(alph(2))
5102         yy1 = dsin(alph(2))*dcos(omeg(2))
5103         zz1 = -dsin(alph(2))*dsin(omeg(2))
5104         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5105      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5106      &    xx1,yy1,zz1
5107 C,"  --- ", xx_w,yy_w,zz_w
5108 c end diagnostics
5109 #endif
5110         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5111      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5112      &   + x(10)*yy*zz
5113         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5114      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5115      & + x(20)*yy*zz
5116         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5117      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5118      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5119      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5120      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5121      &  +x(40)*xx*yy*zz
5122         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5123      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5124      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5125      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5126      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5127      &  +x(60)*xx*yy*zz
5128         dsc_i   = 0.743d0+x(61)
5129         dp2_i   = 1.9d0+x(62)
5130         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5131      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5132         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5133      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5134         s1=(1+x(63))/(0.1d0 + dscp1)
5135         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5136         s2=(1+x(65))/(0.1d0 + dscp2)
5137         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5138         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5139      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5140 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5141 c     &   sumene4,
5142 c     &   dscp1,dscp2,sumene
5143 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5144         escloc = escloc + sumene
5145 c        write (2,*) "i",i," escloc",sumene,escloc
5146 #ifdef DEBUG
5147 C
5148 C This section to check the numerical derivatives of the energy of ith side
5149 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5150 C #define DEBUG in the code to turn it on.
5151 C
5152         write (2,*) "sumene               =",sumene
5153         aincr=1.0d-7
5154         xxsave=xx
5155         xx=xx+aincr
5156         write (2,*) xx,yy,zz
5157         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5158         de_dxx_num=(sumenep-sumene)/aincr
5159         xx=xxsave
5160         write (2,*) "xx+ sumene from enesc=",sumenep
5161         yysave=yy
5162         yy=yy+aincr
5163         write (2,*) xx,yy,zz
5164         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5165         de_dyy_num=(sumenep-sumene)/aincr
5166         yy=yysave
5167         write (2,*) "yy+ sumene from enesc=",sumenep
5168         zzsave=zz
5169         zz=zz+aincr
5170         write (2,*) xx,yy,zz
5171         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5172         de_dzz_num=(sumenep-sumene)/aincr
5173         zz=zzsave
5174         write (2,*) "zz+ sumene from enesc=",sumenep
5175         costsave=cost2tab(i+1)
5176         sintsave=sint2tab(i+1)
5177         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5178         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5179         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5180         de_dt_num=(sumenep-sumene)/aincr
5181         write (2,*) " t+ sumene from enesc=",sumenep
5182         cost2tab(i+1)=costsave
5183         sint2tab(i+1)=sintsave
5184 C End of diagnostics section.
5185 #endif
5186 C
5187 C Compute the gradient of esc
5188 C
5189         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5190         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5191         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5192         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5193         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5194         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5195         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5196         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5197         pom1=(sumene3*sint2tab(i+1)+sumene1)
5198      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5199         pom2=(sumene4*cost2tab(i+1)+sumene2)
5200      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5201         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5202         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5203      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5204      &  +x(40)*yy*zz
5205         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5206         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5207      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5208      &  +x(60)*yy*zz
5209         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5210      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5211      &        +(pom1+pom2)*pom_dx
5212 #ifdef DEBUG
5213         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5214 #endif
5215 C
5216         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5217         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5218      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5219      &  +x(40)*xx*zz
5220         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5221         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5222      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5223      &  +x(59)*zz**2 +x(60)*xx*zz
5224         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5225      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5226      &        +(pom1-pom2)*pom_dy
5227 #ifdef DEBUG
5228         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5229 #endif
5230 C
5231         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5232      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5233      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5234      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5235      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5236      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5237      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5238      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5239 #ifdef DEBUG
5240         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5241 #endif
5242 C
5243         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5244      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5245      &  +pom1*pom_dt1+pom2*pom_dt2
5246 #ifdef DEBUG
5247         write(2,*), "de_dt = ", de_dt,de_dt_num
5248 #endif
5249 c
5250 C
5251        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5252        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5253        cosfac2xx=cosfac2*xx
5254        sinfac2yy=sinfac2*yy
5255        do k = 1,3
5256          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5257      &      vbld_inv(i+1)
5258          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5259      &      vbld_inv(i)
5260          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5261          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5262 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5263 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5264 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5265 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5266          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5267          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5268          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5269          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5270          dZZ_Ci1(k)=0.0d0
5271          dZZ_Ci(k)=0.0d0
5272          do j=1,3
5273            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5274            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5275          enddo
5276
5277          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5278          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5279          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5280 c
5281          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5282          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5283        enddo
5284
5285        do k=1,3
5286          dXX_Ctab(k,i)=dXX_Ci(k)
5287          dXX_C1tab(k,i)=dXX_Ci1(k)
5288          dYY_Ctab(k,i)=dYY_Ci(k)
5289          dYY_C1tab(k,i)=dYY_Ci1(k)
5290          dZZ_Ctab(k,i)=dZZ_Ci(k)
5291          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5292          dXX_XYZtab(k,i)=dXX_XYZ(k)
5293          dYY_XYZtab(k,i)=dYY_XYZ(k)
5294          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5295        enddo
5296
5297        do k = 1,3
5298 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5299 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5300 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5301 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5302 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5303 c     &    dt_dci(k)
5304 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5305 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5306          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5307      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5308          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5309      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5310          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5311      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5312        enddo
5313 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5314 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5315
5316 C to check gradient call subroutine check_grad
5317
5318     1 continue
5319       enddo
5320       return
5321       end
5322 c------------------------------------------------------------------------------
5323       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5324       implicit none
5325       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5326      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5327       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5328      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5329      &   + x(10)*yy*zz
5330       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5331      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5332      & + x(20)*yy*zz
5333       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5334      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5335      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5336      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5337      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5338      &  +x(40)*xx*yy*zz
5339       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5340      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5341      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5342      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5343      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5344      &  +x(60)*xx*yy*zz
5345       dsc_i   = 0.743d0+x(61)
5346       dp2_i   = 1.9d0+x(62)
5347       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5348      &          *(xx*cost2+yy*sint2))
5349       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5350      &          *(xx*cost2-yy*sint2))
5351       s1=(1+x(63))/(0.1d0 + dscp1)
5352       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5353       s2=(1+x(65))/(0.1d0 + dscp2)
5354       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5355       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5356      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5357       enesc=sumene
5358       return
5359       end
5360 #endif
5361 c------------------------------------------------------------------------------
5362       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5363 C
5364 C This procedure calculates two-body contact function g(rij) and its derivative:
5365 C
5366 C           eps0ij                                     !       x < -1
5367 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5368 C            0                                         !       x > 1
5369 C
5370 C where x=(rij-r0ij)/delta
5371 C
5372 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5373 C
5374       implicit none
5375       double precision rij,r0ij,eps0ij,fcont,fprimcont
5376       double precision x,x2,x4,delta
5377 c     delta=0.02D0*r0ij
5378 c      delta=0.2D0*r0ij
5379       x=(rij-r0ij)/delta
5380       if (x.lt.-1.0D0) then
5381         fcont=eps0ij
5382         fprimcont=0.0D0
5383       else if (x.le.1.0D0) then
5384         x2=x*x
5385         x4=x2*x2
5386         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5387         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5388       else
5389         fcont=0.0D0
5390         fprimcont=0.0D0
5391       endif
5392       return
5393       end
5394 c------------------------------------------------------------------------------
5395       subroutine splinthet(theti,delta,ss,ssder)
5396       implicit real*8 (a-h,o-z)
5397       include 'DIMENSIONS'
5398       include 'COMMON.VAR'
5399       include 'COMMON.GEO'
5400       thetup=pi-delta
5401       thetlow=delta
5402       if (theti.gt.pipol) then
5403         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5404       else
5405         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5406         ssder=-ssder
5407       endif
5408       return
5409       end
5410 c------------------------------------------------------------------------------
5411       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5412       implicit none
5413       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5414       double precision ksi,ksi2,ksi3,a1,a2,a3
5415       a1=fprim0*delta/(f1-f0)
5416       a2=3.0d0-2.0d0*a1
5417       a3=a1-2.0d0
5418       ksi=(x-x0)/delta
5419       ksi2=ksi*ksi
5420       ksi3=ksi2*ksi
5421       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5422       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5423       return
5424       end
5425 c------------------------------------------------------------------------------
5426       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5427       implicit none
5428       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5429       double precision ksi,ksi2,ksi3,a1,a2,a3
5430       ksi=(x-x0)/delta
5431       ksi2=ksi*ksi
5432       ksi3=ksi2*ksi
5433       a1=fprim0x*delta
5434       a2=3*(f1x-f0x)-2*fprim0x*delta
5435       a3=fprim0x*delta-2*(f1x-f0x)
5436       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5437       return
5438       end
5439 C-----------------------------------------------------------------------------
5440 #ifdef CRYST_TOR
5441 C-----------------------------------------------------------------------------
5442       subroutine etor(etors,edihcnstr)
5443       implicit real*8 (a-h,o-z)
5444       include 'DIMENSIONS'
5445       include 'COMMON.VAR'
5446       include 'COMMON.GEO'
5447       include 'COMMON.LOCAL'
5448       include 'COMMON.TORSION'
5449       include 'COMMON.INTERACT'
5450       include 'COMMON.DERIV'
5451       include 'COMMON.CHAIN'
5452       include 'COMMON.NAMES'
5453       include 'COMMON.IOUNITS'
5454       include 'COMMON.FFIELD'
5455       include 'COMMON.TORCNSTR'
5456       include 'COMMON.CONTROL'
5457       logical lprn
5458 C Set lprn=.true. for debugging
5459       lprn=.false.
5460 c      lprn=.true.
5461       etors=0.0D0
5462       do i=iphi_start,iphi_end
5463       etors_ii=0.0D0
5464         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5465      &      .or. itype(i).eq.21) cycle
5466         itori=itortyp(itype(i-2))
5467         itori1=itortyp(itype(i-1))
5468         phii=phi(i)
5469         gloci=0.0D0
5470 C Proline-Proline pair is a special case...
5471         if (itori.eq.3 .and. itori1.eq.3) then
5472           if (phii.gt.-dwapi3) then
5473             cosphi=dcos(3*phii)
5474             fac=1.0D0/(1.0D0-cosphi)
5475             etorsi=v1(1,3,3)*fac
5476             etorsi=etorsi+etorsi
5477             etors=etors+etorsi-v1(1,3,3)
5478             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5479             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5480           endif
5481           do j=1,3
5482             v1ij=v1(j+1,itori,itori1)
5483             v2ij=v2(j+1,itori,itori1)
5484             cosphi=dcos(j*phii)
5485             sinphi=dsin(j*phii)
5486             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5487             if (energy_dec) etors_ii=etors_ii+
5488      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5489             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5490           enddo
5491         else
5492           do j=1,nterm_old
5493             v1ij=v1(j,itori,itori1)
5494             v2ij=v2(j,itori,itori1)
5495             cosphi=dcos(j*phii)
5496             sinphi=dsin(j*phii)
5497             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5498             if (energy_dec) etors_ii=etors_ii+
5499      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5500             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5501           enddo
5502         endif
5503         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5504              'etor',i,etors_ii
5505         if (lprn)
5506      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5507      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5508      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5509         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5510 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5511       enddo
5512 ! 6/20/98 - dihedral angle constraints
5513       edihcnstr=0.0d0
5514       do i=1,ndih_constr
5515         itori=idih_constr(i)
5516         phii=phi(itori)
5517         difi=phii-phi0(i)
5518         if (difi.gt.drange(i)) then
5519           difi=difi-drange(i)
5520           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5521           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5522         else if (difi.lt.-drange(i)) then
5523           difi=difi+drange(i)
5524           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5525           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5526         endif
5527 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5528 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5529       enddo
5530 !      write (iout,*) 'edihcnstr',edihcnstr
5531       return
5532       end
5533 c------------------------------------------------------------------------------
5534       subroutine etor_d(etors_d)
5535       etors_d=0.0d0
5536       return
5537       end
5538 c----------------------------------------------------------------------------
5539 #else
5540       subroutine etor(etors,edihcnstr)
5541       implicit real*8 (a-h,o-z)
5542       include 'DIMENSIONS'
5543       include 'COMMON.VAR'
5544       include 'COMMON.GEO'
5545       include 'COMMON.LOCAL'
5546       include 'COMMON.TORSION'
5547       include 'COMMON.INTERACT'
5548       include 'COMMON.DERIV'
5549       include 'COMMON.CHAIN'
5550       include 'COMMON.NAMES'
5551       include 'COMMON.IOUNITS'
5552       include 'COMMON.FFIELD'
5553       include 'COMMON.TORCNSTR'
5554       include 'COMMON.CONTROL'
5555       logical lprn
5556 C Set lprn=.true. for debugging
5557       lprn=.false.
5558 c     lprn=.true.
5559       etors=0.0D0
5560       do i=iphi_start,iphi_end
5561         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5562      &       .or. itype(i).eq.21) cycle
5563       etors_ii=0.0D0
5564         itori=itortyp(itype(i-2))
5565         itori1=itortyp(itype(i-1))
5566         phii=phi(i)
5567         gloci=0.0D0
5568 C Regular cosine and sine terms
5569         do j=1,nterm(itori,itori1)
5570           v1ij=v1(j,itori,itori1)
5571           v2ij=v2(j,itori,itori1)
5572           cosphi=dcos(j*phii)
5573           sinphi=dsin(j*phii)
5574           etors=etors+v1ij*cosphi+v2ij*sinphi
5575           if (energy_dec) etors_ii=etors_ii+
5576      &                v1ij*cosphi+v2ij*sinphi
5577           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5578         enddo
5579 C Lorentz terms
5580 C                         v1
5581 C  E = SUM ----------------------------------- - v1
5582 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5583 C
5584         cosphi=dcos(0.5d0*phii)
5585         sinphi=dsin(0.5d0*phii)
5586         do j=1,nlor(itori,itori1)
5587           vl1ij=vlor1(j,itori,itori1)
5588           vl2ij=vlor2(j,itori,itori1)
5589           vl3ij=vlor3(j,itori,itori1)
5590           pom=vl2ij*cosphi+vl3ij*sinphi
5591           pom1=1.0d0/(pom*pom+1.0d0)
5592           etors=etors+vl1ij*pom1
5593           if (energy_dec) etors_ii=etors_ii+
5594      &                vl1ij*pom1
5595           pom=-pom*pom1*pom1
5596           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5597         enddo
5598 C Subtract the constant term
5599         etors=etors-v0(itori,itori1)
5600           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5601      &         'etor',i,etors_ii-v0(itori,itori1)
5602         if (lprn)
5603      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5604      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5605      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5606         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5607 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5608       enddo
5609 ! 6/20/98 - dihedral angle constraints
5610       edihcnstr=0.0d0
5611 c      do i=1,ndih_constr
5612       do i=idihconstr_start,idihconstr_end
5613         itori=idih_constr(i)
5614         phii=phi(itori)
5615         difi=pinorm(phii-phi0(i))
5616         if (difi.gt.drange(i)) then
5617           difi=difi-drange(i)
5618           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5619           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5620         else if (difi.lt.-drange(i)) then
5621           difi=difi+drange(i)
5622           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5623           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5624         else
5625           difi=0.0
5626         endif
5627 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5628 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5629 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5630       enddo
5631 cd       write (iout,*) 'edihcnstr',edihcnstr
5632       return
5633       end
5634 c----------------------------------------------------------------------------
5635       subroutine etor_d(etors_d)
5636 C 6/23/01 Compute double torsional energy
5637       implicit real*8 (a-h,o-z)
5638       include 'DIMENSIONS'
5639       include 'COMMON.VAR'
5640       include 'COMMON.GEO'
5641       include 'COMMON.LOCAL'
5642       include 'COMMON.TORSION'
5643       include 'COMMON.INTERACT'
5644       include 'COMMON.DERIV'
5645       include 'COMMON.CHAIN'
5646       include 'COMMON.NAMES'
5647       include 'COMMON.IOUNITS'
5648       include 'COMMON.FFIELD'
5649       include 'COMMON.TORCNSTR'
5650       logical lprn
5651 C Set lprn=.true. for debugging
5652       lprn=.false.
5653 c     lprn=.true.
5654       etors_d=0.0D0
5655 C      write(iout,*) "a tu??"
5656       do i=iphid_start,iphid_end
5657         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5658      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
5659         itori=itortyp(itype(i-2))
5660         itori1=itortyp(itype(i-1))
5661         itori2=itortyp(itype(i))
5662         phii=phi(i)
5663         phii1=phi(i+1)
5664         gloci1=0.0D0
5665         gloci2=0.0D0
5666 C Regular cosine and sine terms
5667         do j=1,ntermd_1(itori,itori1,itori2)
5668           v1cij=v1c(1,j,itori,itori1,itori2)
5669           v1sij=v1s(1,j,itori,itori1,itori2)
5670           v2cij=v1c(2,j,itori,itori1,itori2)
5671           v2sij=v1s(2,j,itori,itori1,itori2)
5672           cosphi1=dcos(j*phii)
5673           sinphi1=dsin(j*phii)
5674           cosphi2=dcos(j*phii1)
5675           sinphi2=dsin(j*phii1)
5676           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5677      &     v2cij*cosphi2+v2sij*sinphi2
5678           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5679           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5680         enddo
5681         do k=2,ntermd_2(itori,itori1,itori2)
5682           do l=1,k-1
5683             v1cdij = v2c(k,l,itori,itori1,itori2)
5684             v2cdij = v2c(l,k,itori,itori1,itori2)
5685             v1sdij = v2s(k,l,itori,itori1,itori2)
5686             v2sdij = v2s(l,k,itori,itori1,itori2)
5687             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5688             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5689             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5690             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5691             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5692      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5693             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5694      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5695             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5696      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5697           enddo
5698         enddo
5699         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5700         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5701       enddo
5702       return
5703       end
5704 #endif
5705 c------------------------------------------------------------------------------
5706       subroutine eback_sc_corr(esccor)
5707 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5708 c        conformational states; temporarily implemented as differences
5709 c        between UNRES torsional potentials (dependent on three types of
5710 c        residues) and the torsional potentials dependent on all 20 types
5711 c        of residues computed from AM1  energy surfaces of terminally-blocked
5712 c        amino-acid residues.
5713       implicit real*8 (a-h,o-z)
5714       include 'DIMENSIONS'
5715       include 'COMMON.VAR'
5716       include 'COMMON.GEO'
5717       include 'COMMON.LOCAL'
5718       include 'COMMON.TORSION'
5719       include 'COMMON.SCCOR'
5720       include 'COMMON.INTERACT'
5721       include 'COMMON.DERIV'
5722       include 'COMMON.CHAIN'
5723       include 'COMMON.NAMES'
5724       include 'COMMON.IOUNITS'
5725       include 'COMMON.FFIELD'
5726       include 'COMMON.CONTROL'
5727       logical lprn
5728 C Set lprn=.true. for debugging
5729       lprn=.false.
5730 c      lprn=.true.
5731 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5732       esccor=0.0D0
5733       do i=itau_start,itau_end
5734         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5735         esccor_ii=0.0D0
5736         isccori=isccortyp(itype(i-2))
5737         isccori1=isccortyp(itype(i-1))
5738 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5739         phii=phi(i)
5740         do intertyp=1,3 !intertyp
5741 cc Added 09 May 2012 (Adasko)
5742 cc  Intertyp means interaction type of backbone mainchain correlation:
5743 c   1 = SC...Ca...Ca...Ca
5744 c   2 = Ca...Ca...Ca...SC
5745 c   3 = SC...Ca...Ca...SCi
5746         gloci=0.0D0
5747         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5748      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5749      &      (itype(i-1).eq.ntyp1)))
5750      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5751      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5752      &     .or.(itype(i).eq.ntyp1)))
5753      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5754      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5755      &      (itype(i-3).eq.ntyp1)))) cycle
5756         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5757         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5758      & cycle
5759        do j=1,nterm_sccor(isccori,isccori1)
5760           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5761           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5762           cosphi=dcos(j*tauangle(intertyp,i))
5763           sinphi=dsin(j*tauangle(intertyp,i))
5764           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5765           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5766         enddo
5767 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5768         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5769         if (lprn)
5770      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5771      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5772      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5773      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5774         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5775        enddo !intertyp
5776       enddo
5777
5778       return
5779       end
5780 c----------------------------------------------------------------------------
5781       subroutine multibody(ecorr)
5782 C This subroutine calculates multi-body contributions to energy following
5783 C the idea of Skolnick et al. If side chains I and J make a contact and
5784 C at the same time side chains I+1 and J+1 make a contact, an extra
5785 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5786       implicit real*8 (a-h,o-z)
5787       include 'DIMENSIONS'
5788       include 'COMMON.IOUNITS'
5789       include 'COMMON.DERIV'
5790       include 'COMMON.INTERACT'
5791       include 'COMMON.CONTACTS'
5792       double precision gx(3),gx1(3)
5793       logical lprn
5794
5795 C Set lprn=.true. for debugging
5796       lprn=.false.
5797
5798       if (lprn) then
5799         write (iout,'(a)') 'Contact function values:'
5800         do i=nnt,nct-2
5801           write (iout,'(i2,20(1x,i2,f10.5))')
5802      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5803         enddo
5804       endif
5805       ecorr=0.0D0
5806       do i=nnt,nct
5807         do j=1,3
5808           gradcorr(j,i)=0.0D0
5809           gradxorr(j,i)=0.0D0
5810         enddo
5811       enddo
5812       do i=nnt,nct-2
5813
5814         DO ISHIFT = 3,4
5815
5816         i1=i+ishift
5817         num_conti=num_cont(i)
5818         num_conti1=num_cont(i1)
5819         do jj=1,num_conti
5820           j=jcont(jj,i)
5821           do kk=1,num_conti1
5822             j1=jcont(kk,i1)
5823             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5824 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5825 cd   &                   ' ishift=',ishift
5826 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5827 C The system gains extra energy.
5828               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5829             endif   ! j1==j+-ishift
5830           enddo     ! kk
5831         enddo       ! jj
5832
5833         ENDDO ! ISHIFT
5834
5835       enddo         ! i
5836       return
5837       end
5838 c------------------------------------------------------------------------------
5839       double precision function esccorr(i,j,k,l,jj,kk)
5840       implicit real*8 (a-h,o-z)
5841       include 'DIMENSIONS'
5842       include 'COMMON.IOUNITS'
5843       include 'COMMON.DERIV'
5844       include 'COMMON.INTERACT'
5845       include 'COMMON.CONTACTS'
5846       double precision gx(3),gx1(3)
5847       logical lprn
5848       lprn=.false.
5849       eij=facont(jj,i)
5850       ekl=facont(kk,k)
5851 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5852 C Calculate the multi-body contribution to energy.
5853 C Calculate multi-body contributions to the gradient.
5854 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5855 cd   & k,l,(gacont(m,kk,k),m=1,3)
5856       do m=1,3
5857         gx(m) =ekl*gacont(m,jj,i)
5858         gx1(m)=eij*gacont(m,kk,k)
5859         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5860         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5861         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5862         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5863       enddo
5864       do m=i,j-1
5865         do ll=1,3
5866           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5867         enddo
5868       enddo
5869       do m=k,l-1
5870         do ll=1,3
5871           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5872         enddo
5873       enddo
5874       esccorr=-eij*ekl
5875       return
5876       end
5877 c------------------------------------------------------------------------------
5878       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5879 C This subroutine calculates multi-body contributions to hydrogen-bonding
5880       implicit real*8 (a-h,o-z)
5881       include 'DIMENSIONS'
5882       include 'COMMON.IOUNITS'
5883 #ifdef MPI
5884       include "mpif.h"
5885       parameter (max_cont=maxconts)
5886       parameter (max_dim=26)
5887       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5888       double precision zapas(max_dim,maxconts,max_fg_procs),
5889      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5890       common /przechowalnia/ zapas
5891       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5892      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5893 #endif
5894       include 'COMMON.SETUP'
5895       include 'COMMON.FFIELD'
5896       include 'COMMON.DERIV'
5897       include 'COMMON.INTERACT'
5898       include 'COMMON.CONTACTS'
5899       include 'COMMON.CONTROL'
5900       include 'COMMON.LOCAL'
5901       double precision gx(3),gx1(3),time00
5902       logical lprn,ldone
5903
5904 C Set lprn=.true. for debugging
5905       lprn=.false.
5906 #ifdef MPI
5907       n_corr=0
5908       n_corr1=0
5909       if (nfgtasks.le.1) goto 30
5910       if (lprn) then
5911         write (iout,'(a)') 'Contact function values before RECEIVE:'
5912         do i=nnt,nct-2
5913           write (iout,'(2i3,50(1x,i2,f5.2))')
5914      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5915      &    j=1,num_cont_hb(i))
5916         enddo
5917       endif
5918       call flush(iout)
5919       do i=1,ntask_cont_from
5920         ncont_recv(i)=0
5921       enddo
5922       do i=1,ntask_cont_to
5923         ncont_sent(i)=0
5924       enddo
5925 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5926 c     & ntask_cont_to
5927 C Make the list of contacts to send to send to other procesors
5928 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5929 c      call flush(iout)
5930       do i=iturn3_start,iturn3_end
5931 c        write (iout,*) "make contact list turn3",i," num_cont",
5932 c     &    num_cont_hb(i)
5933         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5934       enddo
5935       do i=iturn4_start,iturn4_end
5936 c        write (iout,*) "make contact list turn4",i," num_cont",
5937 c     &   num_cont_hb(i)
5938         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5939       enddo
5940       do ii=1,nat_sent
5941         i=iat_sent(ii)
5942 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5943 c     &    num_cont_hb(i)
5944         do j=1,num_cont_hb(i)
5945         do k=1,4
5946           jjc=jcont_hb(j,i)
5947           iproc=iint_sent_local(k,jjc,ii)
5948 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5949           if (iproc.gt.0) then
5950             ncont_sent(iproc)=ncont_sent(iproc)+1
5951             nn=ncont_sent(iproc)
5952             zapas(1,nn,iproc)=i
5953             zapas(2,nn,iproc)=jjc
5954             zapas(3,nn,iproc)=facont_hb(j,i)
5955             zapas(4,nn,iproc)=ees0p(j,i)
5956             zapas(5,nn,iproc)=ees0m(j,i)
5957             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5958             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5959             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5960             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5961             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5962             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5963             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5964             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5965             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5966             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5967             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5968             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5969             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5970             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5971             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5972             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5973             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5974             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5975             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5976             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5977             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5978           endif
5979         enddo
5980         enddo
5981       enddo
5982       if (lprn) then
5983       write (iout,*)
5984      &  "Numbers of contacts to be sent to other processors",
5985      &  (ncont_sent(i),i=1,ntask_cont_to)
5986       write (iout,*) "Contacts sent"
5987       do ii=1,ntask_cont_to
5988         nn=ncont_sent(ii)
5989         iproc=itask_cont_to(ii)
5990         write (iout,*) nn," contacts to processor",iproc,
5991      &   " of CONT_TO_COMM group"
5992         do i=1,nn
5993           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5994         enddo
5995       enddo
5996       call flush(iout)
5997       endif
5998       CorrelType=477
5999       CorrelID=fg_rank+1
6000       CorrelType1=478
6001       CorrelID1=nfgtasks+fg_rank+1
6002       ireq=0
6003 C Receive the numbers of needed contacts from other processors
6004       do ii=1,ntask_cont_from
6005         iproc=itask_cont_from(ii)
6006         ireq=ireq+1
6007         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6008      &    FG_COMM,req(ireq),IERR)
6009       enddo
6010 c      write (iout,*) "IRECV ended"
6011 c      call flush(iout)
6012 C Send the number of contacts needed by other processors
6013       do ii=1,ntask_cont_to
6014         iproc=itask_cont_to(ii)
6015         ireq=ireq+1
6016         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6017      &    FG_COMM,req(ireq),IERR)
6018       enddo
6019 c      write (iout,*) "ISEND ended"
6020 c      write (iout,*) "number of requests (nn)",ireq
6021       call flush(iout)
6022       if (ireq.gt.0)
6023      &  call MPI_Waitall(ireq,req,status_array,ierr)
6024 c      write (iout,*)
6025 c     &  "Numbers of contacts to be received from other processors",
6026 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6027 c      call flush(iout)
6028 C Receive contacts
6029       ireq=0
6030       do ii=1,ntask_cont_from
6031         iproc=itask_cont_from(ii)
6032         nn=ncont_recv(ii)
6033 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6034 c     &   " of CONT_TO_COMM group"
6035         call flush(iout)
6036         if (nn.gt.0) then
6037           ireq=ireq+1
6038           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6039      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6040 c          write (iout,*) "ireq,req",ireq,req(ireq)
6041         endif
6042       enddo
6043 C Send the contacts to processors that need them
6044       do ii=1,ntask_cont_to
6045         iproc=itask_cont_to(ii)
6046         nn=ncont_sent(ii)
6047 c        write (iout,*) nn," contacts to processor",iproc,
6048 c     &   " of CONT_TO_COMM group"
6049         if (nn.gt.0) then
6050           ireq=ireq+1
6051           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6052      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6053 c          write (iout,*) "ireq,req",ireq,req(ireq)
6054 c          do i=1,nn
6055 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6056 c          enddo
6057         endif
6058       enddo
6059 c      write (iout,*) "number of requests (contacts)",ireq
6060 c      write (iout,*) "req",(req(i),i=1,4)
6061 c      call flush(iout)
6062       if (ireq.gt.0)
6063      & call MPI_Waitall(ireq,req,status_array,ierr)
6064       do iii=1,ntask_cont_from
6065         iproc=itask_cont_from(iii)
6066         nn=ncont_recv(iii)
6067         if (lprn) then
6068         write (iout,*) "Received",nn," contacts from processor",iproc,
6069      &   " of CONT_FROM_COMM group"
6070         call flush(iout)
6071         do i=1,nn
6072           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6073         enddo
6074         call flush(iout)
6075         endif
6076         do i=1,nn
6077           ii=zapas_recv(1,i,iii)
6078 c Flag the received contacts to prevent double-counting
6079           jj=-zapas_recv(2,i,iii)
6080 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6081 c          call flush(iout)
6082           nnn=num_cont_hb(ii)+1
6083           num_cont_hb(ii)=nnn
6084           jcont_hb(nnn,ii)=jj
6085           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6086           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6087           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6088           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6089           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6090           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6091           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6092           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6093           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6094           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6095           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6096           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6097           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6098           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6099           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6100           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6101           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6102           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6103           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6104           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6105           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6106           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6107           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6108           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6109         enddo
6110       enddo
6111       call flush(iout)
6112       if (lprn) then
6113         write (iout,'(a)') 'Contact function values after receive:'
6114         do i=nnt,nct-2
6115           write (iout,'(2i3,50(1x,i3,f5.2))')
6116      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6117      &    j=1,num_cont_hb(i))
6118         enddo
6119         call flush(iout)
6120       endif
6121    30 continue
6122 #endif
6123       if (lprn) then
6124         write (iout,'(a)') 'Contact function values:'
6125         do i=nnt,nct-2
6126           write (iout,'(2i3,50(1x,i3,f5.2))')
6127      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6128      &    j=1,num_cont_hb(i))
6129         enddo
6130       endif
6131       ecorr=0.0D0
6132 C Remove the loop below after debugging !!!
6133       do i=nnt,nct
6134         do j=1,3
6135           gradcorr(j,i)=0.0D0
6136           gradxorr(j,i)=0.0D0
6137         enddo
6138       enddo
6139 C Calculate the local-electrostatic correlation terms
6140       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6141         i1=i+1
6142         num_conti=num_cont_hb(i)
6143         num_conti1=num_cont_hb(i+1)
6144         do jj=1,num_conti
6145           j=jcont_hb(jj,i)
6146           jp=iabs(j)
6147           do kk=1,num_conti1
6148             j1=jcont_hb(kk,i1)
6149             jp1=iabs(j1)
6150 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6151 c     &         ' jj=',jj,' kk=',kk
6152             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6153      &          .or. j.lt.0 .and. j1.gt.0) .and.
6154      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6155 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6156 C The system gains extra energy.
6157               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6158               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6159      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6160               n_corr=n_corr+1
6161             else if (j1.eq.j) then
6162 C Contacts I-J and I-(J+1) occur simultaneously.
6163 C The system loses extra energy.
6164 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6165             endif
6166           enddo ! kk
6167           do kk=1,num_conti
6168             j1=jcont_hb(kk,i)
6169 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6170 c    &         ' jj=',jj,' kk=',kk
6171             if (j1.eq.j+1) then
6172 C Contacts I-J and (I+1)-J occur simultaneously.
6173 C The system loses extra energy.
6174 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6175             endif ! j1==j+1
6176           enddo ! kk
6177         enddo ! jj
6178       enddo ! i
6179       return
6180       end
6181 c------------------------------------------------------------------------------
6182       subroutine add_hb_contact(ii,jj,itask)
6183       implicit real*8 (a-h,o-z)
6184       include "DIMENSIONS"
6185       include "COMMON.IOUNITS"
6186       integer max_cont
6187       integer max_dim
6188       parameter (max_cont=maxconts)
6189       parameter (max_dim=26)
6190       include "COMMON.CONTACTS"
6191       double precision zapas(max_dim,maxconts,max_fg_procs),
6192      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6193       common /przechowalnia/ zapas
6194       integer i,j,ii,jj,iproc,itask(4),nn
6195 c      write (iout,*) "itask",itask
6196       do i=1,2
6197         iproc=itask(i)
6198         if (iproc.gt.0) then
6199           do j=1,num_cont_hb(ii)
6200             jjc=jcont_hb(j,ii)
6201 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6202             if (jjc.eq.jj) then
6203               ncont_sent(iproc)=ncont_sent(iproc)+1
6204               nn=ncont_sent(iproc)
6205               zapas(1,nn,iproc)=ii
6206               zapas(2,nn,iproc)=jjc
6207               zapas(3,nn,iproc)=facont_hb(j,ii)
6208               zapas(4,nn,iproc)=ees0p(j,ii)
6209               zapas(5,nn,iproc)=ees0m(j,ii)
6210               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6211               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6212               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6213               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6214               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6215               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6216               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6217               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6218               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6219               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6220               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6221               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6222               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6223               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6224               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6225               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6226               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6227               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6228               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6229               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6230               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6231               exit
6232             endif
6233           enddo
6234         endif
6235       enddo
6236       return
6237       end
6238 c------------------------------------------------------------------------------
6239       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6240      &  n_corr1)
6241 C This subroutine calculates multi-body contributions to hydrogen-bonding
6242       implicit real*8 (a-h,o-z)
6243       include 'DIMENSIONS'
6244       include 'COMMON.IOUNITS'
6245 #ifdef MPI
6246       include "mpif.h"
6247       parameter (max_cont=maxconts)
6248       parameter (max_dim=70)
6249       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6250       double precision zapas(max_dim,maxconts,max_fg_procs),
6251      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6252       common /przechowalnia/ zapas
6253       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6254      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6255 #endif
6256       include 'COMMON.SETUP'
6257       include 'COMMON.FFIELD'
6258       include 'COMMON.DERIV'
6259       include 'COMMON.LOCAL'
6260       include 'COMMON.INTERACT'
6261       include 'COMMON.CONTACTS'
6262       include 'COMMON.CHAIN'
6263       include 'COMMON.CONTROL'
6264       double precision gx(3),gx1(3)
6265       integer num_cont_hb_old(maxres)
6266       logical lprn,ldone
6267       double precision eello4,eello5,eelo6,eello_turn6
6268       external eello4,eello5,eello6,eello_turn6
6269 C Set lprn=.true. for debugging
6270       lprn=.false.
6271       eturn6=0.0d0
6272 #ifdef MPI
6273       do i=1,nres
6274         num_cont_hb_old(i)=num_cont_hb(i)
6275       enddo
6276       n_corr=0
6277       n_corr1=0
6278       if (nfgtasks.le.1) goto 30
6279       if (lprn) then
6280         write (iout,'(a)') 'Contact function values before RECEIVE:'
6281         do i=nnt,nct-2
6282           write (iout,'(2i3,50(1x,i2,f5.2))')
6283      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6284      &    j=1,num_cont_hb(i))
6285         enddo
6286       endif
6287       call flush(iout)
6288       do i=1,ntask_cont_from
6289         ncont_recv(i)=0
6290       enddo
6291       do i=1,ntask_cont_to
6292         ncont_sent(i)=0
6293       enddo
6294 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6295 c     & ntask_cont_to
6296 C Make the list of contacts to send to send to other procesors
6297       do i=iturn3_start,iturn3_end
6298 c        write (iout,*) "make contact list turn3",i," num_cont",
6299 c     &    num_cont_hb(i)
6300         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6301       enddo
6302       do i=iturn4_start,iturn4_end
6303 c        write (iout,*) "make contact list turn4",i," num_cont",
6304 c     &   num_cont_hb(i)
6305         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6306       enddo
6307       do ii=1,nat_sent
6308         i=iat_sent(ii)
6309 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6310 c     &    num_cont_hb(i)
6311         do j=1,num_cont_hb(i)
6312         do k=1,4
6313           jjc=jcont_hb(j,i)
6314           iproc=iint_sent_local(k,jjc,ii)
6315 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6316           if (iproc.ne.0) then
6317             ncont_sent(iproc)=ncont_sent(iproc)+1
6318             nn=ncont_sent(iproc)
6319             zapas(1,nn,iproc)=i
6320             zapas(2,nn,iproc)=jjc
6321             zapas(3,nn,iproc)=d_cont(j,i)
6322             ind=3
6323             do kk=1,3
6324               ind=ind+1
6325               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6326             enddo
6327             do kk=1,2
6328               do ll=1,2
6329                 ind=ind+1
6330                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6331               enddo
6332             enddo
6333             do jj=1,5
6334               do kk=1,3
6335                 do ll=1,2
6336                   do mm=1,2
6337                     ind=ind+1
6338                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6339                   enddo
6340                 enddo
6341               enddo
6342             enddo
6343           endif
6344         enddo
6345         enddo
6346       enddo
6347       if (lprn) then
6348       write (iout,*)
6349      &  "Numbers of contacts to be sent to other processors",
6350      &  (ncont_sent(i),i=1,ntask_cont_to)
6351       write (iout,*) "Contacts sent"
6352       do ii=1,ntask_cont_to
6353         nn=ncont_sent(ii)
6354         iproc=itask_cont_to(ii)
6355         write (iout,*) nn," contacts to processor",iproc,
6356      &   " of CONT_TO_COMM group"
6357         do i=1,nn
6358           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6359         enddo
6360       enddo
6361       call flush(iout)
6362       endif
6363       CorrelType=477
6364       CorrelID=fg_rank+1
6365       CorrelType1=478
6366       CorrelID1=nfgtasks+fg_rank+1
6367       ireq=0
6368 C Receive the numbers of needed contacts from other processors
6369       do ii=1,ntask_cont_from
6370         iproc=itask_cont_from(ii)
6371         ireq=ireq+1
6372         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6373      &    FG_COMM,req(ireq),IERR)
6374       enddo
6375 c      write (iout,*) "IRECV ended"
6376 c      call flush(iout)
6377 C Send the number of contacts needed by other processors
6378       do ii=1,ntask_cont_to
6379         iproc=itask_cont_to(ii)
6380         ireq=ireq+1
6381         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6382      &    FG_COMM,req(ireq),IERR)
6383       enddo
6384 c      write (iout,*) "ISEND ended"
6385 c      write (iout,*) "number of requests (nn)",ireq
6386       call flush(iout)
6387       if (ireq.gt.0)
6388      &  call MPI_Waitall(ireq,req,status_array,ierr)
6389 c      write (iout,*)
6390 c     &  "Numbers of contacts to be received from other processors",
6391 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6392 c      call flush(iout)
6393 C Receive contacts
6394       ireq=0
6395       do ii=1,ntask_cont_from
6396         iproc=itask_cont_from(ii)
6397         nn=ncont_recv(ii)
6398 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6399 c     &   " of CONT_TO_COMM group"
6400         call flush(iout)
6401         if (nn.gt.0) then
6402           ireq=ireq+1
6403           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6404      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6405 c          write (iout,*) "ireq,req",ireq,req(ireq)
6406         endif
6407       enddo
6408 C Send the contacts to processors that need them
6409       do ii=1,ntask_cont_to
6410         iproc=itask_cont_to(ii)
6411         nn=ncont_sent(ii)
6412 c        write (iout,*) nn," contacts to processor",iproc,
6413 c     &   " of CONT_TO_COMM group"
6414         if (nn.gt.0) then
6415           ireq=ireq+1
6416           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6417      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6418 c          write (iout,*) "ireq,req",ireq,req(ireq)
6419 c          do i=1,nn
6420 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6421 c          enddo
6422         endif
6423       enddo
6424 c      write (iout,*) "number of requests (contacts)",ireq
6425 c      write (iout,*) "req",(req(i),i=1,4)
6426 c      call flush(iout)
6427       if (ireq.gt.0)
6428      & call MPI_Waitall(ireq,req,status_array,ierr)
6429       do iii=1,ntask_cont_from
6430         iproc=itask_cont_from(iii)
6431         nn=ncont_recv(iii)
6432         if (lprn) then
6433         write (iout,*) "Received",nn," contacts from processor",iproc,
6434      &   " of CONT_FROM_COMM group"
6435         call flush(iout)
6436         do i=1,nn
6437           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6438         enddo
6439         call flush(iout)
6440         endif
6441         do i=1,nn
6442           ii=zapas_recv(1,i,iii)
6443 c Flag the received contacts to prevent double-counting
6444           jj=-zapas_recv(2,i,iii)
6445 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6446 c          call flush(iout)
6447           nnn=num_cont_hb(ii)+1
6448           num_cont_hb(ii)=nnn
6449           jcont_hb(nnn,ii)=jj
6450           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6451           ind=3
6452           do kk=1,3
6453             ind=ind+1
6454             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6455           enddo
6456           do kk=1,2
6457             do ll=1,2
6458               ind=ind+1
6459               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6460             enddo
6461           enddo
6462           do jj=1,5
6463             do kk=1,3
6464               do ll=1,2
6465                 do mm=1,2
6466                   ind=ind+1
6467                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6468                 enddo
6469               enddo
6470             enddo
6471           enddo
6472         enddo
6473       enddo
6474       call flush(iout)
6475       if (lprn) then
6476         write (iout,'(a)') 'Contact function values after receive:'
6477         do i=nnt,nct-2
6478           write (iout,'(2i3,50(1x,i3,5f6.3))')
6479      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6480      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6481         enddo
6482         call flush(iout)
6483       endif
6484    30 continue
6485 #endif
6486       if (lprn) then
6487         write (iout,'(a)') 'Contact function values:'
6488         do i=nnt,nct-2
6489           write (iout,'(2i3,50(1x,i2,5f6.3))')
6490      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6491      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6492         enddo
6493       endif
6494       ecorr=0.0D0
6495       ecorr5=0.0d0
6496       ecorr6=0.0d0
6497 C Remove the loop below after debugging !!!
6498       do i=nnt,nct
6499         do j=1,3
6500           gradcorr(j,i)=0.0D0
6501           gradxorr(j,i)=0.0D0
6502         enddo
6503       enddo
6504 C Calculate the dipole-dipole interaction energies
6505       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6506       do i=iatel_s,iatel_e+1
6507         num_conti=num_cont_hb(i)
6508         do jj=1,num_conti
6509           j=jcont_hb(jj,i)
6510 #ifdef MOMENT
6511           call dipole(i,j,jj)
6512 #endif
6513         enddo
6514       enddo
6515       endif
6516 C Calculate the local-electrostatic correlation terms
6517 c                write (iout,*) "gradcorr5 in eello5 before loop"
6518 c                do iii=1,nres
6519 c                  write (iout,'(i5,3f10.5)')
6520 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6521 c                enddo
6522       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6523 c        write (iout,*) "corr loop i",i
6524         i1=i+1
6525         num_conti=num_cont_hb(i)
6526         num_conti1=num_cont_hb(i+1)
6527         do jj=1,num_conti
6528           j=jcont_hb(jj,i)
6529           jp=iabs(j)
6530           do kk=1,num_conti1
6531             j1=jcont_hb(kk,i1)
6532             jp1=iabs(j1)
6533 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6534 c     &         ' jj=',jj,' kk=',kk
6535 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6536             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6537      &          .or. j.lt.0 .and. j1.gt.0) .and.
6538      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6539 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6540 C The system gains extra energy.
6541               n_corr=n_corr+1
6542               sqd1=dsqrt(d_cont(jj,i))
6543               sqd2=dsqrt(d_cont(kk,i1))
6544               sred_geom = sqd1*sqd2
6545               IF (sred_geom.lt.cutoff_corr) THEN
6546                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6547      &            ekont,fprimcont)
6548 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6549 cd     &         ' jj=',jj,' kk=',kk
6550                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6551                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6552                 do l=1,3
6553                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6554                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6555                 enddo
6556                 n_corr1=n_corr1+1
6557 cd               write (iout,*) 'sred_geom=',sred_geom,
6558 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6559 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6560 cd               write (iout,*) "g_contij",g_contij
6561 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6562 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6563                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6564                 if (wcorr4.gt.0.0d0)
6565      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6566                   if (energy_dec.and.wcorr4.gt.0.0d0)
6567      1                 write (iout,'(a6,4i5,0pf7.3)')
6568      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6569 c                write (iout,*) "gradcorr5 before eello5"
6570 c                do iii=1,nres
6571 c                  write (iout,'(i5,3f10.5)')
6572 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6573 c                enddo
6574                 if (wcorr5.gt.0.0d0)
6575      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6576 c                write (iout,*) "gradcorr5 after eello5"
6577 c                do iii=1,nres
6578 c                  write (iout,'(i5,3f10.5)')
6579 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6580 c                enddo
6581                   if (energy_dec.and.wcorr5.gt.0.0d0)
6582      1                 write (iout,'(a6,4i5,0pf7.3)')
6583      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6584 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6585 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6586                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6587      &               .or. wturn6.eq.0.0d0))then
6588 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6589                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6590                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6591      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6592 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6593 cd     &            'ecorr6=',ecorr6
6594 cd                write (iout,'(4e15.5)') sred_geom,
6595 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6596 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6597 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6598                 else if (wturn6.gt.0.0d0
6599      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6600 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6601                   eturn6=eturn6+eello_turn6(i,jj,kk)
6602                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6603      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6604 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6605                 endif
6606               ENDIF
6607 1111          continue
6608             endif
6609           enddo ! kk
6610         enddo ! jj
6611       enddo ! i
6612       do i=1,nres
6613         num_cont_hb(i)=num_cont_hb_old(i)
6614       enddo
6615 c                write (iout,*) "gradcorr5 in eello5"
6616 c                do iii=1,nres
6617 c                  write (iout,'(i5,3f10.5)')
6618 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6619 c                enddo
6620       return
6621       end
6622 c------------------------------------------------------------------------------
6623       subroutine add_hb_contact_eello(ii,jj,itask)
6624       implicit real*8 (a-h,o-z)
6625       include "DIMENSIONS"
6626       include "COMMON.IOUNITS"
6627       integer max_cont
6628       integer max_dim
6629       parameter (max_cont=maxconts)
6630       parameter (max_dim=70)
6631       include "COMMON.CONTACTS"
6632       double precision zapas(max_dim,maxconts,max_fg_procs),
6633      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6634       common /przechowalnia/ zapas
6635       integer i,j,ii,jj,iproc,itask(4),nn
6636 c      write (iout,*) "itask",itask
6637       do i=1,2
6638         iproc=itask(i)
6639         if (iproc.gt.0) then
6640           do j=1,num_cont_hb(ii)
6641             jjc=jcont_hb(j,ii)
6642 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6643             if (jjc.eq.jj) then
6644               ncont_sent(iproc)=ncont_sent(iproc)+1
6645               nn=ncont_sent(iproc)
6646               zapas(1,nn,iproc)=ii
6647               zapas(2,nn,iproc)=jjc
6648               zapas(3,nn,iproc)=d_cont(j,ii)
6649               ind=3
6650               do kk=1,3
6651                 ind=ind+1
6652                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6653               enddo
6654               do kk=1,2
6655                 do ll=1,2
6656                   ind=ind+1
6657                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6658                 enddo
6659               enddo
6660               do jj=1,5
6661                 do kk=1,3
6662                   do ll=1,2
6663                     do mm=1,2
6664                       ind=ind+1
6665                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6666                     enddo
6667                   enddo
6668                 enddo
6669               enddo
6670               exit
6671             endif
6672           enddo
6673         endif
6674       enddo
6675       return
6676       end
6677 c------------------------------------------------------------------------------
6678       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6679       implicit real*8 (a-h,o-z)
6680       include 'DIMENSIONS'
6681       include 'COMMON.IOUNITS'
6682       include 'COMMON.DERIV'
6683       include 'COMMON.INTERACT'
6684       include 'COMMON.CONTACTS'
6685       double precision gx(3),gx1(3)
6686       logical lprn
6687       lprn=.false.
6688       eij=facont_hb(jj,i)
6689       ekl=facont_hb(kk,k)
6690       ees0pij=ees0p(jj,i)
6691       ees0pkl=ees0p(kk,k)
6692       ees0mij=ees0m(jj,i)
6693       ees0mkl=ees0m(kk,k)
6694       ekont=eij*ekl
6695       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6696 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6697 C Following 4 lines for diagnostics.
6698 cd    ees0pkl=0.0D0
6699 cd    ees0pij=1.0D0
6700 cd    ees0mkl=0.0D0
6701 cd    ees0mij=1.0D0
6702 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6703 c     & 'Contacts ',i,j,
6704 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6705 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6706 c     & 'gradcorr_long'
6707 C Calculate the multi-body contribution to energy.
6708 c      ecorr=ecorr+ekont*ees
6709 C Calculate multi-body contributions to the gradient.
6710       coeffpees0pij=coeffp*ees0pij
6711       coeffmees0mij=coeffm*ees0mij
6712       coeffpees0pkl=coeffp*ees0pkl
6713       coeffmees0mkl=coeffm*ees0mkl
6714       do ll=1,3
6715 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6716         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6717      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6718      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6719         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6720      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6721      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6722 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6723         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6724      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6725      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6726         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6727      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6728      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6729         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6730      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6731      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6732         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6733         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6734         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6735      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6736      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6737         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6738         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6739 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6740       enddo
6741 c      write (iout,*)
6742 cgrad      do m=i+1,j-1
6743 cgrad        do ll=1,3
6744 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6745 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6746 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6747 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6748 cgrad        enddo
6749 cgrad      enddo
6750 cgrad      do m=k+1,l-1
6751 cgrad        do ll=1,3
6752 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6753 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6754 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6755 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6756 cgrad        enddo
6757 cgrad      enddo
6758 c      write (iout,*) "ehbcorr",ekont*ees
6759       ehbcorr=ekont*ees
6760       return
6761       end
6762 #ifdef MOMENT
6763 C---------------------------------------------------------------------------
6764       subroutine dipole(i,j,jj)
6765       implicit real*8 (a-h,o-z)
6766       include 'DIMENSIONS'
6767       include 'COMMON.IOUNITS'
6768       include 'COMMON.CHAIN'
6769       include 'COMMON.FFIELD'
6770       include 'COMMON.DERIV'
6771       include 'COMMON.INTERACT'
6772       include 'COMMON.CONTACTS'
6773       include 'COMMON.TORSION'
6774       include 'COMMON.VAR'
6775       include 'COMMON.GEO'
6776       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6777      &  auxmat(2,2)
6778       iti1 = itortyp(itype(i+1))
6779       if (j.lt.nres-1) then
6780         itj1 = itortyp(itype(j+1))
6781       else
6782         itj1=ntortyp+1
6783       endif
6784       do iii=1,2
6785         dipi(iii,1)=Ub2(iii,i)
6786         dipderi(iii)=Ub2der(iii,i)
6787         dipi(iii,2)=b1(iii,iti1)
6788         dipj(iii,1)=Ub2(iii,j)
6789         dipderj(iii)=Ub2der(iii,j)
6790         dipj(iii,2)=b1(iii,itj1)
6791       enddo
6792       kkk=0
6793       do iii=1,2
6794         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6795         do jjj=1,2
6796           kkk=kkk+1
6797           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6798         enddo
6799       enddo
6800       do kkk=1,5
6801         do lll=1,3
6802           mmm=0
6803           do iii=1,2
6804             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6805      &        auxvec(1))
6806             do jjj=1,2
6807               mmm=mmm+1
6808               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6809             enddo
6810           enddo
6811         enddo
6812       enddo
6813       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6814       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6815       do iii=1,2
6816         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6817       enddo
6818       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6819       do iii=1,2
6820         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6821       enddo
6822       return
6823       end
6824 #endif
6825 C---------------------------------------------------------------------------
6826       subroutine calc_eello(i,j,k,l,jj,kk)
6827 C
6828 C This subroutine computes matrices and vectors needed to calculate
6829 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6830 C
6831       implicit real*8 (a-h,o-z)
6832       include 'DIMENSIONS'
6833       include 'COMMON.IOUNITS'
6834       include 'COMMON.CHAIN'
6835       include 'COMMON.DERIV'
6836       include 'COMMON.INTERACT'
6837       include 'COMMON.CONTACTS'
6838       include 'COMMON.TORSION'
6839       include 'COMMON.VAR'
6840       include 'COMMON.GEO'
6841       include 'COMMON.FFIELD'
6842       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6843      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6844       logical lprn
6845       common /kutas/ lprn
6846 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6847 cd     & ' jj=',jj,' kk=',kk
6848 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6849 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6850 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6851       do iii=1,2
6852         do jjj=1,2
6853           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6854           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6855         enddo
6856       enddo
6857       call transpose2(aa1(1,1),aa1t(1,1))
6858       call transpose2(aa2(1,1),aa2t(1,1))
6859       do kkk=1,5
6860         do lll=1,3
6861           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6862      &      aa1tder(1,1,lll,kkk))
6863           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6864      &      aa2tder(1,1,lll,kkk))
6865         enddo
6866       enddo
6867       if (l.eq.j+1) then
6868 C parallel orientation of the two CA-CA-CA frames.
6869         if (i.gt.1) then
6870           iti=itortyp(itype(i))
6871         else
6872           iti=ntortyp+1
6873         endif
6874         itk1=itortyp(itype(k+1))
6875         itj=itortyp(itype(j))
6876         if (l.lt.nres-1) then
6877           itl1=itortyp(itype(l+1))
6878         else
6879           itl1=ntortyp+1
6880         endif
6881 C A1 kernel(j+1) A2T
6882 cd        do iii=1,2
6883 cd          write (iout,'(3f10.5,5x,3f10.5)')
6884 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6885 cd        enddo
6886         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6887      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6888      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6889 C Following matrices are needed only for 6-th order cumulants
6890         IF (wcorr6.gt.0.0d0) THEN
6891         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6892      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6893      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6894         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6895      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6896      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6897      &   ADtEAderx(1,1,1,1,1,1))
6898         lprn=.false.
6899         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6900      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6901      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6902      &   ADtEA1derx(1,1,1,1,1,1))
6903         ENDIF
6904 C End 6-th order cumulants
6905 cd        lprn=.false.
6906 cd        if (lprn) then
6907 cd        write (2,*) 'In calc_eello6'
6908 cd        do iii=1,2
6909 cd          write (2,*) 'iii=',iii
6910 cd          do kkk=1,5
6911 cd            write (2,*) 'kkk=',kkk
6912 cd            do jjj=1,2
6913 cd              write (2,'(3(2f10.5),5x)')
6914 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6915 cd            enddo
6916 cd          enddo
6917 cd        enddo
6918 cd        endif
6919         call transpose2(EUgder(1,1,k),auxmat(1,1))
6920         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6921         call transpose2(EUg(1,1,k),auxmat(1,1))
6922         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6923         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6924         do iii=1,2
6925           do kkk=1,5
6926             do lll=1,3
6927               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6928      &          EAEAderx(1,1,lll,kkk,iii,1))
6929             enddo
6930           enddo
6931         enddo
6932 C A1T kernel(i+1) A2
6933         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6934      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6935      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6936 C Following matrices are needed only for 6-th order cumulants
6937         IF (wcorr6.gt.0.0d0) THEN
6938         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6939      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6940      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6941         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6942      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6943      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6944      &   ADtEAderx(1,1,1,1,1,2))
6945         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6946      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6947      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6948      &   ADtEA1derx(1,1,1,1,1,2))
6949         ENDIF
6950 C End 6-th order cumulants
6951         call transpose2(EUgder(1,1,l),auxmat(1,1))
6952         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6953         call transpose2(EUg(1,1,l),auxmat(1,1))
6954         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6955         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6956         do iii=1,2
6957           do kkk=1,5
6958             do lll=1,3
6959               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6960      &          EAEAderx(1,1,lll,kkk,iii,2))
6961             enddo
6962           enddo
6963         enddo
6964 C AEAb1 and AEAb2
6965 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6966 C They are needed only when the fifth- or the sixth-order cumulants are
6967 C indluded.
6968         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6969         call transpose2(AEA(1,1,1),auxmat(1,1))
6970         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6971         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6972         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6973         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6974         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6975         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6976         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6977         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6978         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6979         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6980         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6981         call transpose2(AEA(1,1,2),auxmat(1,1))
6982         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6983         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6984         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6985         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6986         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6987         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6988         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6989         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6990         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6991         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6992         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6993 C Calculate the Cartesian derivatives of the vectors.
6994         do iii=1,2
6995           do kkk=1,5
6996             do lll=1,3
6997               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6998               call matvec2(auxmat(1,1),b1(1,iti),
6999      &          AEAb1derx(1,lll,kkk,iii,1,1))
7000               call matvec2(auxmat(1,1),Ub2(1,i),
7001      &          AEAb2derx(1,lll,kkk,iii,1,1))
7002               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7003      &          AEAb1derx(1,lll,kkk,iii,2,1))
7004               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7005      &          AEAb2derx(1,lll,kkk,iii,2,1))
7006               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7007               call matvec2(auxmat(1,1),b1(1,itj),
7008      &          AEAb1derx(1,lll,kkk,iii,1,2))
7009               call matvec2(auxmat(1,1),Ub2(1,j),
7010      &          AEAb2derx(1,lll,kkk,iii,1,2))
7011               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7012      &          AEAb1derx(1,lll,kkk,iii,2,2))
7013               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7014      &          AEAb2derx(1,lll,kkk,iii,2,2))
7015             enddo
7016           enddo
7017         enddo
7018         ENDIF
7019 C End vectors
7020       else
7021 C Antiparallel orientation of the two CA-CA-CA frames.
7022         if (i.gt.1) then
7023           iti=itortyp(itype(i))
7024         else
7025           iti=ntortyp+1
7026         endif
7027         itk1=itortyp(itype(k+1))
7028         itl=itortyp(itype(l))
7029         itj=itortyp(itype(j))
7030         if (j.lt.nres-1) then
7031           itj1=itortyp(itype(j+1))
7032         else
7033           itj1=ntortyp+1
7034         endif
7035 C A2 kernel(j-1)T A1T
7036         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7037      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7038      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7039 C Following matrices are needed only for 6-th order cumulants
7040         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7041      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7042         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7043      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7044      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7045         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7046      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7047      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7048      &   ADtEAderx(1,1,1,1,1,1))
7049         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7050      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7051      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7052      &   ADtEA1derx(1,1,1,1,1,1))
7053         ENDIF
7054 C End 6-th order cumulants
7055         call transpose2(EUgder(1,1,k),auxmat(1,1))
7056         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7057         call transpose2(EUg(1,1,k),auxmat(1,1))
7058         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7059         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7060         do iii=1,2
7061           do kkk=1,5
7062             do lll=1,3
7063               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7064      &          EAEAderx(1,1,lll,kkk,iii,1))
7065             enddo
7066           enddo
7067         enddo
7068 C A2T kernel(i+1)T A1
7069         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7070      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7071      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7072 C Following matrices are needed only for 6-th order cumulants
7073         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7074      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7075         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7076      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7077      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7078         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7079      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7080      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7081      &   ADtEAderx(1,1,1,1,1,2))
7082         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7083      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7084      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7085      &   ADtEA1derx(1,1,1,1,1,2))
7086         ENDIF
7087 C End 6-th order cumulants
7088         call transpose2(EUgder(1,1,j),auxmat(1,1))
7089         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7090         call transpose2(EUg(1,1,j),auxmat(1,1))
7091         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7092         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7093         do iii=1,2
7094           do kkk=1,5
7095             do lll=1,3
7096               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7097      &          EAEAderx(1,1,lll,kkk,iii,2))
7098             enddo
7099           enddo
7100         enddo
7101 C AEAb1 and AEAb2
7102 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7103 C They are needed only when the fifth- or the sixth-order cumulants are
7104 C indluded.
7105         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7106      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7107         call transpose2(AEA(1,1,1),auxmat(1,1))
7108         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7109         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7110         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7111         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7112         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7113         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7114         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7115         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7116         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7117         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7118         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7119         call transpose2(AEA(1,1,2),auxmat(1,1))
7120         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7121         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7122         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7123         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7124         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7125         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7126         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7127         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7128         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7129         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7130         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7131 C Calculate the Cartesian derivatives of the vectors.
7132         do iii=1,2
7133           do kkk=1,5
7134             do lll=1,3
7135               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7136               call matvec2(auxmat(1,1),b1(1,iti),
7137      &          AEAb1derx(1,lll,kkk,iii,1,1))
7138               call matvec2(auxmat(1,1),Ub2(1,i),
7139      &          AEAb2derx(1,lll,kkk,iii,1,1))
7140               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7141      &          AEAb1derx(1,lll,kkk,iii,2,1))
7142               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7143      &          AEAb2derx(1,lll,kkk,iii,2,1))
7144               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7145               call matvec2(auxmat(1,1),b1(1,itl),
7146      &          AEAb1derx(1,lll,kkk,iii,1,2))
7147               call matvec2(auxmat(1,1),Ub2(1,l),
7148      &          AEAb2derx(1,lll,kkk,iii,1,2))
7149               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7150      &          AEAb1derx(1,lll,kkk,iii,2,2))
7151               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7152      &          AEAb2derx(1,lll,kkk,iii,2,2))
7153             enddo
7154           enddo
7155         enddo
7156         ENDIF
7157 C End vectors
7158       endif
7159       return
7160       end
7161 C---------------------------------------------------------------------------
7162       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7163      &  KK,KKderg,AKA,AKAderg,AKAderx)
7164       implicit none
7165       integer nderg
7166       logical transp
7167       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7168      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7169      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7170       integer iii,kkk,lll
7171       integer jjj,mmm
7172       logical lprn
7173       common /kutas/ lprn
7174       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7175       do iii=1,nderg
7176         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7177      &    AKAderg(1,1,iii))
7178       enddo
7179 cd      if (lprn) write (2,*) 'In kernel'
7180       do kkk=1,5
7181 cd        if (lprn) write (2,*) 'kkk=',kkk
7182         do lll=1,3
7183           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7184      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7185 cd          if (lprn) then
7186 cd            write (2,*) 'lll=',lll
7187 cd            write (2,*) 'iii=1'
7188 cd            do jjj=1,2
7189 cd              write (2,'(3(2f10.5),5x)')
7190 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7191 cd            enddo
7192 cd          endif
7193           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7194      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7195 cd          if (lprn) then
7196 cd            write (2,*) 'lll=',lll
7197 cd            write (2,*) 'iii=2'
7198 cd            do jjj=1,2
7199 cd              write (2,'(3(2f10.5),5x)')
7200 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7201 cd            enddo
7202 cd          endif
7203         enddo
7204       enddo
7205       return
7206       end
7207 C---------------------------------------------------------------------------
7208       double precision function eello4(i,j,k,l,jj,kk)
7209       implicit real*8 (a-h,o-z)
7210       include 'DIMENSIONS'
7211       include 'COMMON.IOUNITS'
7212       include 'COMMON.CHAIN'
7213       include 'COMMON.DERIV'
7214       include 'COMMON.INTERACT'
7215       include 'COMMON.CONTACTS'
7216       include 'COMMON.TORSION'
7217       include 'COMMON.VAR'
7218       include 'COMMON.GEO'
7219       double precision pizda(2,2),ggg1(3),ggg2(3)
7220 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7221 cd        eello4=0.0d0
7222 cd        return
7223 cd      endif
7224 cd      print *,'eello4:',i,j,k,l,jj,kk
7225 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7226 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7227 cold      eij=facont_hb(jj,i)
7228 cold      ekl=facont_hb(kk,k)
7229 cold      ekont=eij*ekl
7230       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7231 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7232       gcorr_loc(k-1)=gcorr_loc(k-1)
7233      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7234       if (l.eq.j+1) then
7235         gcorr_loc(l-1)=gcorr_loc(l-1)
7236      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7237       else
7238         gcorr_loc(j-1)=gcorr_loc(j-1)
7239      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7240       endif
7241       do iii=1,2
7242         do kkk=1,5
7243           do lll=1,3
7244             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7245      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7246 cd            derx(lll,kkk,iii)=0.0d0
7247           enddo
7248         enddo
7249       enddo
7250 cd      gcorr_loc(l-1)=0.0d0
7251 cd      gcorr_loc(j-1)=0.0d0
7252 cd      gcorr_loc(k-1)=0.0d0
7253 cd      eel4=1.0d0
7254 cd      write (iout,*)'Contacts have occurred for peptide groups',
7255 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7256 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7257       if (j.lt.nres-1) then
7258         j1=j+1
7259         j2=j-1
7260       else
7261         j1=j-1
7262         j2=j-2
7263       endif
7264       if (l.lt.nres-1) then
7265         l1=l+1
7266         l2=l-1
7267       else
7268         l1=l-1
7269         l2=l-2
7270       endif
7271       do ll=1,3
7272 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7273 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7274         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7275         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7276 cgrad        ghalf=0.5d0*ggg1(ll)
7277         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7278         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7279         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7280         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7281         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7282         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7283 cgrad        ghalf=0.5d0*ggg2(ll)
7284         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7285         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7286         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7287         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7288         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7289         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7290       enddo
7291 cgrad      do m=i+1,j-1
7292 cgrad        do ll=1,3
7293 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7294 cgrad        enddo
7295 cgrad      enddo
7296 cgrad      do m=k+1,l-1
7297 cgrad        do ll=1,3
7298 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7299 cgrad        enddo
7300 cgrad      enddo
7301 cgrad      do m=i+2,j2
7302 cgrad        do ll=1,3
7303 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7304 cgrad        enddo
7305 cgrad      enddo
7306 cgrad      do m=k+2,l2
7307 cgrad        do ll=1,3
7308 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7309 cgrad        enddo
7310 cgrad      enddo
7311 cd      do iii=1,nres-3
7312 cd        write (2,*) iii,gcorr_loc(iii)
7313 cd      enddo
7314       eello4=ekont*eel4
7315 cd      write (2,*) 'ekont',ekont
7316 cd      write (iout,*) 'eello4',ekont*eel4
7317       return
7318       end
7319 C---------------------------------------------------------------------------
7320       double precision function eello5(i,j,k,l,jj,kk)
7321       implicit real*8 (a-h,o-z)
7322       include 'DIMENSIONS'
7323       include 'COMMON.IOUNITS'
7324       include 'COMMON.CHAIN'
7325       include 'COMMON.DERIV'
7326       include 'COMMON.INTERACT'
7327       include 'COMMON.CONTACTS'
7328       include 'COMMON.TORSION'
7329       include 'COMMON.VAR'
7330       include 'COMMON.GEO'
7331       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7332       double precision ggg1(3),ggg2(3)
7333 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7334 C                                                                              C
7335 C                            Parallel chains                                   C
7336 C                                                                              C
7337 C          o             o                   o             o                   C
7338 C         /l\           / \             \   / \           / \   /              C
7339 C        /   \         /   \             \ /   \         /   \ /               C
7340 C       j| o |l1       | o |              o| o |         | o |o                C
7341 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7342 C      \i/   \         /   \ /             /   \         /   \                 C
7343 C       o    k1             o                                                  C
7344 C         (I)          (II)                (III)          (IV)                 C
7345 C                                                                              C
7346 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7347 C                                                                              C
7348 C                            Antiparallel chains                               C
7349 C                                                                              C
7350 C          o             o                   o             o                   C
7351 C         /j\           / \             \   / \           / \   /              C
7352 C        /   \         /   \             \ /   \         /   \ /               C
7353 C      j1| o |l        | o |              o| o |         | o |o                C
7354 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7355 C      \i/   \         /   \ /             /   \         /   \                 C
7356 C       o     k1            o                                                  C
7357 C         (I)          (II)                (III)          (IV)                 C
7358 C                                                                              C
7359 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7360 C                                                                              C
7361 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7362 C                                                                              C
7363 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7364 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7365 cd        eello5=0.0d0
7366 cd        return
7367 cd      endif
7368 cd      write (iout,*)
7369 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7370 cd     &   ' and',k,l
7371       itk=itortyp(itype(k))
7372       itl=itortyp(itype(l))
7373       itj=itortyp(itype(j))
7374       eello5_1=0.0d0
7375       eello5_2=0.0d0
7376       eello5_3=0.0d0
7377       eello5_4=0.0d0
7378 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7379 cd     &   eel5_3_num,eel5_4_num)
7380       do iii=1,2
7381         do kkk=1,5
7382           do lll=1,3
7383             derx(lll,kkk,iii)=0.0d0
7384           enddo
7385         enddo
7386       enddo
7387 cd      eij=facont_hb(jj,i)
7388 cd      ekl=facont_hb(kk,k)
7389 cd      ekont=eij*ekl
7390 cd      write (iout,*)'Contacts have occurred for peptide groups',
7391 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7392 cd      goto 1111
7393 C Contribution from the graph I.
7394 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7395 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7396       call transpose2(EUg(1,1,k),auxmat(1,1))
7397       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7398       vv(1)=pizda(1,1)-pizda(2,2)
7399       vv(2)=pizda(1,2)+pizda(2,1)
7400       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7401      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7402 C Explicit gradient in virtual-dihedral angles.
7403       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7404      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7405      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7406       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7407       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7408       vv(1)=pizda(1,1)-pizda(2,2)
7409       vv(2)=pizda(1,2)+pizda(2,1)
7410       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7411      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7412      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7413       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7414       vv(1)=pizda(1,1)-pizda(2,2)
7415       vv(2)=pizda(1,2)+pizda(2,1)
7416       if (l.eq.j+1) then
7417         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7418      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7419      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7420       else
7421         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7422      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7423      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7424       endif
7425 C Cartesian gradient
7426       do iii=1,2
7427         do kkk=1,5
7428           do lll=1,3
7429             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7430      &        pizda(1,1))
7431             vv(1)=pizda(1,1)-pizda(2,2)
7432             vv(2)=pizda(1,2)+pizda(2,1)
7433             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7434      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7435      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7436           enddo
7437         enddo
7438       enddo
7439 c      goto 1112
7440 c1111  continue
7441 C Contribution from graph II
7442       call transpose2(EE(1,1,itk),auxmat(1,1))
7443       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7444       vv(1)=pizda(1,1)+pizda(2,2)
7445       vv(2)=pizda(2,1)-pizda(1,2)
7446       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7447      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7448 C Explicit gradient in virtual-dihedral angles.
7449       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7450      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7451       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7452       vv(1)=pizda(1,1)+pizda(2,2)
7453       vv(2)=pizda(2,1)-pizda(1,2)
7454       if (l.eq.j+1) then
7455         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7456      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7457      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7458       else
7459         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7460      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7461      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7462       endif
7463 C Cartesian gradient
7464       do iii=1,2
7465         do kkk=1,5
7466           do lll=1,3
7467             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7468      &        pizda(1,1))
7469             vv(1)=pizda(1,1)+pizda(2,2)
7470             vv(2)=pizda(2,1)-pizda(1,2)
7471             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7472      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7473      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7474           enddo
7475         enddo
7476       enddo
7477 cd      goto 1112
7478 cd1111  continue
7479       if (l.eq.j+1) then
7480 cd        goto 1110
7481 C Parallel orientation
7482 C Contribution from graph III
7483         call transpose2(EUg(1,1,l),auxmat(1,1))
7484         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7485         vv(1)=pizda(1,1)-pizda(2,2)
7486         vv(2)=pizda(1,2)+pizda(2,1)
7487         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7488      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7489 C Explicit gradient in virtual-dihedral angles.
7490         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7491      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7492      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7493         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7494         vv(1)=pizda(1,1)-pizda(2,2)
7495         vv(2)=pizda(1,2)+pizda(2,1)
7496         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7497      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7498      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7499         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7500         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7501         vv(1)=pizda(1,1)-pizda(2,2)
7502         vv(2)=pizda(1,2)+pizda(2,1)
7503         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7504      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7505      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7506 C Cartesian gradient
7507         do iii=1,2
7508           do kkk=1,5
7509             do lll=1,3
7510               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7511      &          pizda(1,1))
7512               vv(1)=pizda(1,1)-pizda(2,2)
7513               vv(2)=pizda(1,2)+pizda(2,1)
7514               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7515      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7516      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7517             enddo
7518           enddo
7519         enddo
7520 cd        goto 1112
7521 C Contribution from graph IV
7522 cd1110    continue
7523         call transpose2(EE(1,1,itl),auxmat(1,1))
7524         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7525         vv(1)=pizda(1,1)+pizda(2,2)
7526         vv(2)=pizda(2,1)-pizda(1,2)
7527         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7528      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7529 C Explicit gradient in virtual-dihedral angles.
7530         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7531      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7532         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7533         vv(1)=pizda(1,1)+pizda(2,2)
7534         vv(2)=pizda(2,1)-pizda(1,2)
7535         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7536      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7537      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7538 C Cartesian gradient
7539         do iii=1,2
7540           do kkk=1,5
7541             do lll=1,3
7542               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7543      &          pizda(1,1))
7544               vv(1)=pizda(1,1)+pizda(2,2)
7545               vv(2)=pizda(2,1)-pizda(1,2)
7546               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7547      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7548      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7549             enddo
7550           enddo
7551         enddo
7552       else
7553 C Antiparallel orientation
7554 C Contribution from graph III
7555 c        goto 1110
7556         call transpose2(EUg(1,1,j),auxmat(1,1))
7557         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7558         vv(1)=pizda(1,1)-pizda(2,2)
7559         vv(2)=pizda(1,2)+pizda(2,1)
7560         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7561      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7562 C Explicit gradient in virtual-dihedral angles.
7563         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7564      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7565      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7566         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7567         vv(1)=pizda(1,1)-pizda(2,2)
7568         vv(2)=pizda(1,2)+pizda(2,1)
7569         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7570      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7571      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7572         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7573         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7574         vv(1)=pizda(1,1)-pizda(2,2)
7575         vv(2)=pizda(1,2)+pizda(2,1)
7576         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7577      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7578      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7579 C Cartesian gradient
7580         do iii=1,2
7581           do kkk=1,5
7582             do lll=1,3
7583               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7584      &          pizda(1,1))
7585               vv(1)=pizda(1,1)-pizda(2,2)
7586               vv(2)=pizda(1,2)+pizda(2,1)
7587               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7588      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7589      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7590             enddo
7591           enddo
7592         enddo
7593 cd        goto 1112
7594 C Contribution from graph IV
7595 1110    continue
7596         call transpose2(EE(1,1,itj),auxmat(1,1))
7597         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7598         vv(1)=pizda(1,1)+pizda(2,2)
7599         vv(2)=pizda(2,1)-pizda(1,2)
7600         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7601      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7602 C Explicit gradient in virtual-dihedral angles.
7603         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7604      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7605         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7606         vv(1)=pizda(1,1)+pizda(2,2)
7607         vv(2)=pizda(2,1)-pizda(1,2)
7608         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7609      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7610      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7611 C Cartesian gradient
7612         do iii=1,2
7613           do kkk=1,5
7614             do lll=1,3
7615               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7616      &          pizda(1,1))
7617               vv(1)=pizda(1,1)+pizda(2,2)
7618               vv(2)=pizda(2,1)-pizda(1,2)
7619               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7620      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7621      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7622             enddo
7623           enddo
7624         enddo
7625       endif
7626 1112  continue
7627       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7628 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7629 cd        write (2,*) 'ijkl',i,j,k,l
7630 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7631 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7632 cd      endif
7633 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7634 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7635 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7636 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7637       if (j.lt.nres-1) then
7638         j1=j+1
7639         j2=j-1
7640       else
7641         j1=j-1
7642         j2=j-2
7643       endif
7644       if (l.lt.nres-1) then
7645         l1=l+1
7646         l2=l-1
7647       else
7648         l1=l-1
7649         l2=l-2
7650       endif
7651 cd      eij=1.0d0
7652 cd      ekl=1.0d0
7653 cd      ekont=1.0d0
7654 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7655 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7656 C        summed up outside the subrouine as for the other subroutines
7657 C        handling long-range interactions. The old code is commented out
7658 C        with "cgrad" to keep track of changes.
7659       do ll=1,3
7660 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7661 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7662         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7663         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7664 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7665 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7666 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7667 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7668 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7669 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7670 c     &   gradcorr5ij,
7671 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7672 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7673 cgrad        ghalf=0.5d0*ggg1(ll)
7674 cd        ghalf=0.0d0
7675         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7676         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7677         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7678         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7679         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7680         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7681 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7682 cgrad        ghalf=0.5d0*ggg2(ll)
7683 cd        ghalf=0.0d0
7684         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7685         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7686         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7687         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7688         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7689         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7690       enddo
7691 cd      goto 1112
7692 cgrad      do m=i+1,j-1
7693 cgrad        do ll=1,3
7694 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7695 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7696 cgrad        enddo
7697 cgrad      enddo
7698 cgrad      do m=k+1,l-1
7699 cgrad        do ll=1,3
7700 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7701 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7702 cgrad        enddo
7703 cgrad      enddo
7704 c1112  continue
7705 cgrad      do m=i+2,j2
7706 cgrad        do ll=1,3
7707 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7708 cgrad        enddo
7709 cgrad      enddo
7710 cgrad      do m=k+2,l2
7711 cgrad        do ll=1,3
7712 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7713 cgrad        enddo
7714 cgrad      enddo
7715 cd      do iii=1,nres-3
7716 cd        write (2,*) iii,g_corr5_loc(iii)
7717 cd      enddo
7718       eello5=ekont*eel5
7719 cd      write (2,*) 'ekont',ekont
7720 cd      write (iout,*) 'eello5',ekont*eel5
7721       return
7722       end
7723 c--------------------------------------------------------------------------
7724       double precision function eello6(i,j,k,l,jj,kk)
7725       implicit real*8 (a-h,o-z)
7726       include 'DIMENSIONS'
7727       include 'COMMON.IOUNITS'
7728       include 'COMMON.CHAIN'
7729       include 'COMMON.DERIV'
7730       include 'COMMON.INTERACT'
7731       include 'COMMON.CONTACTS'
7732       include 'COMMON.TORSION'
7733       include 'COMMON.VAR'
7734       include 'COMMON.GEO'
7735       include 'COMMON.FFIELD'
7736       double precision ggg1(3),ggg2(3)
7737 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7738 cd        eello6=0.0d0
7739 cd        return
7740 cd      endif
7741 cd      write (iout,*)
7742 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7743 cd     &   ' and',k,l
7744       eello6_1=0.0d0
7745       eello6_2=0.0d0
7746       eello6_3=0.0d0
7747       eello6_4=0.0d0
7748       eello6_5=0.0d0
7749       eello6_6=0.0d0
7750 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7751 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7752       do iii=1,2
7753         do kkk=1,5
7754           do lll=1,3
7755             derx(lll,kkk,iii)=0.0d0
7756           enddo
7757         enddo
7758       enddo
7759 cd      eij=facont_hb(jj,i)
7760 cd      ekl=facont_hb(kk,k)
7761 cd      ekont=eij*ekl
7762 cd      eij=1.0d0
7763 cd      ekl=1.0d0
7764 cd      ekont=1.0d0
7765       if (l.eq.j+1) then
7766         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7767         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7768         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7769         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7770         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7771         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7772       else
7773         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7774         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7775         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7776         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7777         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7778           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7779         else
7780           eello6_5=0.0d0
7781         endif
7782         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7783       endif
7784 C If turn contributions are considered, they will be handled separately.
7785       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7786 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7787 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7788 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7789 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7790 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7791 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7792 cd      goto 1112
7793       if (j.lt.nres-1) then
7794         j1=j+1
7795         j2=j-1
7796       else
7797         j1=j-1
7798         j2=j-2
7799       endif
7800       if (l.lt.nres-1) then
7801         l1=l+1
7802         l2=l-1
7803       else
7804         l1=l-1
7805         l2=l-2
7806       endif
7807       do ll=1,3
7808 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7809 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7810 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7811 cgrad        ghalf=0.5d0*ggg1(ll)
7812 cd        ghalf=0.0d0
7813         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7814         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7815         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7816         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7817         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7818         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7819         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7820         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7821 cgrad        ghalf=0.5d0*ggg2(ll)
7822 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7823 cd        ghalf=0.0d0
7824         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7825         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7826         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7827         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7828         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7829         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7830       enddo
7831 cd      goto 1112
7832 cgrad      do m=i+1,j-1
7833 cgrad        do ll=1,3
7834 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7835 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7836 cgrad        enddo
7837 cgrad      enddo
7838 cgrad      do m=k+1,l-1
7839 cgrad        do ll=1,3
7840 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7841 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7842 cgrad        enddo
7843 cgrad      enddo
7844 cgrad1112  continue
7845 cgrad      do m=i+2,j2
7846 cgrad        do ll=1,3
7847 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7848 cgrad        enddo
7849 cgrad      enddo
7850 cgrad      do m=k+2,l2
7851 cgrad        do ll=1,3
7852 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7853 cgrad        enddo
7854 cgrad      enddo
7855 cd      do iii=1,nres-3
7856 cd        write (2,*) iii,g_corr6_loc(iii)
7857 cd      enddo
7858       eello6=ekont*eel6
7859 cd      write (2,*) 'ekont',ekont
7860 cd      write (iout,*) 'eello6',ekont*eel6
7861       return
7862       end
7863 c--------------------------------------------------------------------------
7864       double precision function eello6_graph1(i,j,k,l,imat,swap)
7865       implicit real*8 (a-h,o-z)
7866       include 'DIMENSIONS'
7867       include 'COMMON.IOUNITS'
7868       include 'COMMON.CHAIN'
7869       include 'COMMON.DERIV'
7870       include 'COMMON.INTERACT'
7871       include 'COMMON.CONTACTS'
7872       include 'COMMON.TORSION'
7873       include 'COMMON.VAR'
7874       include 'COMMON.GEO'
7875       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7876       logical swap
7877       logical lprn
7878       common /kutas/ lprn
7879 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7880 C                                                                              C
7881 C      Parallel       Antiparallel                                             C
7882 C                                                                              C
7883 C          o             o                                                     C
7884 C         /l\           /j\                                                    C
7885 C        /   \         /   \                                                   C
7886 C       /| o |         | o |\                                                  C
7887 C     \ j|/k\|  /   \  |/k\|l /                                                C
7888 C      \ /   \ /     \ /   \ /                                                 C
7889 C       o     o       o     o                                                  C
7890 C       i             i                                                        C
7891 C                                                                              C
7892 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7893       itk=itortyp(itype(k))
7894       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7895       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7896       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7897       call transpose2(EUgC(1,1,k),auxmat(1,1))
7898       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7899       vv1(1)=pizda1(1,1)-pizda1(2,2)
7900       vv1(2)=pizda1(1,2)+pizda1(2,1)
7901       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7902       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7903       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7904       s5=scalar2(vv(1),Dtobr2(1,i))
7905 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7906       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7907       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7908      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7909      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7910      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7911      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7912      & +scalar2(vv(1),Dtobr2der(1,i)))
7913       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7914       vv1(1)=pizda1(1,1)-pizda1(2,2)
7915       vv1(2)=pizda1(1,2)+pizda1(2,1)
7916       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7917       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7918       if (l.eq.j+1) then
7919         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7920      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7921      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7922      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7923      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7924       else
7925         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7926      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7927      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7928      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7929      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7930       endif
7931       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7932       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7933       vv1(1)=pizda1(1,1)-pizda1(2,2)
7934       vv1(2)=pizda1(1,2)+pizda1(2,1)
7935       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7936      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7937      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7938      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7939       do iii=1,2
7940         if (swap) then
7941           ind=3-iii
7942         else
7943           ind=iii
7944         endif
7945         do kkk=1,5
7946           do lll=1,3
7947             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7948             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7949             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7950             call transpose2(EUgC(1,1,k),auxmat(1,1))
7951             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7952      &        pizda1(1,1))
7953             vv1(1)=pizda1(1,1)-pizda1(2,2)
7954             vv1(2)=pizda1(1,2)+pizda1(2,1)
7955             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7956             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7957      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7958             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7959      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7960             s5=scalar2(vv(1),Dtobr2(1,i))
7961             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7962           enddo
7963         enddo
7964       enddo
7965       return
7966       end
7967 c----------------------------------------------------------------------------
7968       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7969       implicit real*8 (a-h,o-z)
7970       include 'DIMENSIONS'
7971       include 'COMMON.IOUNITS'
7972       include 'COMMON.CHAIN'
7973       include 'COMMON.DERIV'
7974       include 'COMMON.INTERACT'
7975       include 'COMMON.CONTACTS'
7976       include 'COMMON.TORSION'
7977       include 'COMMON.VAR'
7978       include 'COMMON.GEO'
7979       logical swap
7980       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7981      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7982       logical lprn
7983       common /kutas/ lprn
7984 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7985 C                                                                              C
7986 C      Parallel       Antiparallel                                             C
7987 C                                                                              C
7988 C          o             o                                                     C
7989 C     \   /l\           /j\   /                                                C
7990 C      \ /   \         /   \ /                                                 C
7991 C       o| o |         | o |o                                                  C
7992 C     \ j|/k\|      \  |/k\|l                                                  C
7993 C      \ /   \       \ /   \                                                   C
7994 C       o             o                                                        C
7995 C       i             i                                                        C
7996 C                                                                              C
7997 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7998 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7999 C AL 7/4/01 s1 would occur in the sixth-order moment,
8000 C           but not in a cluster cumulant
8001 #ifdef MOMENT
8002       s1=dip(1,jj,i)*dip(1,kk,k)
8003 #endif
8004       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8005       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8006       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8007       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8008       call transpose2(EUg(1,1,k),auxmat(1,1))
8009       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8010       vv(1)=pizda(1,1)-pizda(2,2)
8011       vv(2)=pizda(1,2)+pizda(2,1)
8012       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8013 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8014 #ifdef MOMENT
8015       eello6_graph2=-(s1+s2+s3+s4)
8016 #else
8017       eello6_graph2=-(s2+s3+s4)
8018 #endif
8019 c      eello6_graph2=-s3
8020 C Derivatives in gamma(i-1)
8021       if (i.gt.1) then
8022 #ifdef MOMENT
8023         s1=dipderg(1,jj,i)*dip(1,kk,k)
8024 #endif
8025         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8026         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8027         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8028         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8029 #ifdef MOMENT
8030         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8031 #else
8032         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8033 #endif
8034 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8035       endif
8036 C Derivatives in gamma(k-1)
8037 #ifdef MOMENT
8038       s1=dip(1,jj,i)*dipderg(1,kk,k)
8039 #endif
8040       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8041       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8042       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8043       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8044       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8045       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8046       vv(1)=pizda(1,1)-pizda(2,2)
8047       vv(2)=pizda(1,2)+pizda(2,1)
8048       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8049 #ifdef MOMENT
8050       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8051 #else
8052       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8053 #endif
8054 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8055 C Derivatives in gamma(j-1) or gamma(l-1)
8056       if (j.gt.1) then
8057 #ifdef MOMENT
8058         s1=dipderg(3,jj,i)*dip(1,kk,k)
8059 #endif
8060         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8061         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8062         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8063         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8064         vv(1)=pizda(1,1)-pizda(2,2)
8065         vv(2)=pizda(1,2)+pizda(2,1)
8066         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8067 #ifdef MOMENT
8068         if (swap) then
8069           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8070         else
8071           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8072         endif
8073 #endif
8074         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8075 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8076       endif
8077 C Derivatives in gamma(l-1) or gamma(j-1)
8078       if (l.gt.1) then
8079 #ifdef MOMENT
8080         s1=dip(1,jj,i)*dipderg(3,kk,k)
8081 #endif
8082         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8083         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8084         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8085         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8086         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8087         vv(1)=pizda(1,1)-pizda(2,2)
8088         vv(2)=pizda(1,2)+pizda(2,1)
8089         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8090 #ifdef MOMENT
8091         if (swap) then
8092           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8093         else
8094           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8095         endif
8096 #endif
8097         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8098 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8099       endif
8100 C Cartesian derivatives.
8101       if (lprn) then
8102         write (2,*) 'In eello6_graph2'
8103         do iii=1,2
8104           write (2,*) 'iii=',iii
8105           do kkk=1,5
8106             write (2,*) 'kkk=',kkk
8107             do jjj=1,2
8108               write (2,'(3(2f10.5),5x)')
8109      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8110             enddo
8111           enddo
8112         enddo
8113       endif
8114       do iii=1,2
8115         do kkk=1,5
8116           do lll=1,3
8117 #ifdef MOMENT
8118             if (iii.eq.1) then
8119               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8120             else
8121               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8122             endif
8123 #endif
8124             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8125      &        auxvec(1))
8126             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8127             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8128      &        auxvec(1))
8129             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8130             call transpose2(EUg(1,1,k),auxmat(1,1))
8131             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8132      &        pizda(1,1))
8133             vv(1)=pizda(1,1)-pizda(2,2)
8134             vv(2)=pizda(1,2)+pizda(2,1)
8135             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8136 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8137 #ifdef MOMENT
8138             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8139 #else
8140             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8141 #endif
8142             if (swap) then
8143               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8144             else
8145               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8146             endif
8147           enddo
8148         enddo
8149       enddo
8150       return
8151       end
8152 c----------------------------------------------------------------------------
8153       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8154       implicit real*8 (a-h,o-z)
8155       include 'DIMENSIONS'
8156       include 'COMMON.IOUNITS'
8157       include 'COMMON.CHAIN'
8158       include 'COMMON.DERIV'
8159       include 'COMMON.INTERACT'
8160       include 'COMMON.CONTACTS'
8161       include 'COMMON.TORSION'
8162       include 'COMMON.VAR'
8163       include 'COMMON.GEO'
8164       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8165       logical swap
8166 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8167 C                                                                              C
8168 C      Parallel       Antiparallel                                             C
8169 C                                                                              C
8170 C          o             o                                                     C
8171 C         /l\   /   \   /j\                                                    C
8172 C        /   \ /     \ /   \                                                   C
8173 C       /| o |o       o| o |\                                                  C
8174 C       j|/k\|  /      |/k\|l /                                                C
8175 C        /   \ /       /   \ /                                                 C
8176 C       /     o       /     o                                                  C
8177 C       i             i                                                        C
8178 C                                                                              C
8179 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8180 C
8181 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8182 C           energy moment and not to the cluster cumulant.
8183       iti=itortyp(itype(i))
8184       if (j.lt.nres-1) then
8185         itj1=itortyp(itype(j+1))
8186       else
8187         itj1=ntortyp+1
8188       endif
8189       itk=itortyp(itype(k))
8190       itk1=itortyp(itype(k+1))
8191       if (l.lt.nres-1) then
8192         itl1=itortyp(itype(l+1))
8193       else
8194         itl1=ntortyp+1
8195       endif
8196 #ifdef MOMENT
8197       s1=dip(4,jj,i)*dip(4,kk,k)
8198 #endif
8199       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8200       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8201       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8202       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8203       call transpose2(EE(1,1,itk),auxmat(1,1))
8204       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8205       vv(1)=pizda(1,1)+pizda(2,2)
8206       vv(2)=pizda(2,1)-pizda(1,2)
8207       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8208 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8209 cd     & "sum",-(s2+s3+s4)
8210 #ifdef MOMENT
8211       eello6_graph3=-(s1+s2+s3+s4)
8212 #else
8213       eello6_graph3=-(s2+s3+s4)
8214 #endif
8215 c      eello6_graph3=-s4
8216 C Derivatives in gamma(k-1)
8217       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8218       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8219       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8220       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8221 C Derivatives in gamma(l-1)
8222       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8223       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8224       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8225       vv(1)=pizda(1,1)+pizda(2,2)
8226       vv(2)=pizda(2,1)-pizda(1,2)
8227       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8228       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8229 C Cartesian derivatives.
8230       do iii=1,2
8231         do kkk=1,5
8232           do lll=1,3
8233 #ifdef MOMENT
8234             if (iii.eq.1) then
8235               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8236             else
8237               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8238             endif
8239 #endif
8240             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8241      &        auxvec(1))
8242             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8243             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8244      &        auxvec(1))
8245             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8246             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8247      &        pizda(1,1))
8248             vv(1)=pizda(1,1)+pizda(2,2)
8249             vv(2)=pizda(2,1)-pizda(1,2)
8250             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8251 #ifdef MOMENT
8252             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8253 #else
8254             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8255 #endif
8256             if (swap) then
8257               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8258             else
8259               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8260             endif
8261 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8262           enddo
8263         enddo
8264       enddo
8265       return
8266       end
8267 c----------------------------------------------------------------------------
8268       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8269       implicit real*8 (a-h,o-z)
8270       include 'DIMENSIONS'
8271       include 'COMMON.IOUNITS'
8272       include 'COMMON.CHAIN'
8273       include 'COMMON.DERIV'
8274       include 'COMMON.INTERACT'
8275       include 'COMMON.CONTACTS'
8276       include 'COMMON.TORSION'
8277       include 'COMMON.VAR'
8278       include 'COMMON.GEO'
8279       include 'COMMON.FFIELD'
8280       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8281      & auxvec1(2),auxmat1(2,2)
8282       logical swap
8283 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8284 C                                                                              C
8285 C      Parallel       Antiparallel                                             C
8286 C                                                                              C
8287 C          o             o                                                     C
8288 C         /l\   /   \   /j\                                                    C
8289 C        /   \ /     \ /   \                                                   C
8290 C       /| o |o       o| o |\                                                  C
8291 C     \ j|/k\|      \  |/k\|l                                                  C
8292 C      \ /   \       \ /   \                                                   C
8293 C       o     \       o     \                                                  C
8294 C       i             i                                                        C
8295 C                                                                              C
8296 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8297 C
8298 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8299 C           energy moment and not to the cluster cumulant.
8300 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8301       iti=itortyp(itype(i))
8302       itj=itortyp(itype(j))
8303       if (j.lt.nres-1) then
8304         itj1=itortyp(itype(j+1))
8305       else
8306         itj1=ntortyp+1
8307       endif
8308       itk=itortyp(itype(k))
8309       if (k.lt.nres-1) then
8310         itk1=itortyp(itype(k+1))
8311       else
8312         itk1=ntortyp+1
8313       endif
8314       itl=itortyp(itype(l))
8315       if (l.lt.nres-1) then
8316         itl1=itortyp(itype(l+1))
8317       else
8318         itl1=ntortyp+1
8319       endif
8320 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8321 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8322 cd     & ' itl',itl,' itl1',itl1
8323 #ifdef MOMENT
8324       if (imat.eq.1) then
8325         s1=dip(3,jj,i)*dip(3,kk,k)
8326       else
8327         s1=dip(2,jj,j)*dip(2,kk,l)
8328       endif
8329 #endif
8330       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8331       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8332       if (j.eq.l+1) then
8333         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8334         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8335       else
8336         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8337         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8338       endif
8339       call transpose2(EUg(1,1,k),auxmat(1,1))
8340       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8341       vv(1)=pizda(1,1)-pizda(2,2)
8342       vv(2)=pizda(2,1)+pizda(1,2)
8343       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8344 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8345 #ifdef MOMENT
8346       eello6_graph4=-(s1+s2+s3+s4)
8347 #else
8348       eello6_graph4=-(s2+s3+s4)
8349 #endif
8350 C Derivatives in gamma(i-1)
8351       if (i.gt.1) then
8352 #ifdef MOMENT
8353         if (imat.eq.1) then
8354           s1=dipderg(2,jj,i)*dip(3,kk,k)
8355         else
8356           s1=dipderg(4,jj,j)*dip(2,kk,l)
8357         endif
8358 #endif
8359         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8360         if (j.eq.l+1) then
8361           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8362           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8363         else
8364           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8365           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8366         endif
8367         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8368         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8369 cd          write (2,*) 'turn6 derivatives'
8370 #ifdef MOMENT
8371           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8372 #else
8373           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8374 #endif
8375         else
8376 #ifdef MOMENT
8377           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8378 #else
8379           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8380 #endif
8381         endif
8382       endif
8383 C Derivatives in gamma(k-1)
8384 #ifdef MOMENT
8385       if (imat.eq.1) then
8386         s1=dip(3,jj,i)*dipderg(2,kk,k)
8387       else
8388         s1=dip(2,jj,j)*dipderg(4,kk,l)
8389       endif
8390 #endif
8391       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8392       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8393       if (j.eq.l+1) then
8394         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8395         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8396       else
8397         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8398         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8399       endif
8400       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8401       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8402       vv(1)=pizda(1,1)-pizda(2,2)
8403       vv(2)=pizda(2,1)+pizda(1,2)
8404       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8405       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8406 #ifdef MOMENT
8407         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8408 #else
8409         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8410 #endif
8411       else
8412 #ifdef MOMENT
8413         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8414 #else
8415         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8416 #endif
8417       endif
8418 C Derivatives in gamma(j-1) or gamma(l-1)
8419       if (l.eq.j+1 .and. l.gt.1) then
8420         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8421         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8422         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8423         vv(1)=pizda(1,1)-pizda(2,2)
8424         vv(2)=pizda(2,1)+pizda(1,2)
8425         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8426         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8427       else if (j.gt.1) then
8428         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8429         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8430         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8431         vv(1)=pizda(1,1)-pizda(2,2)
8432         vv(2)=pizda(2,1)+pizda(1,2)
8433         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8434         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8435           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8436         else
8437           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8438         endif
8439       endif
8440 C Cartesian derivatives.
8441       do iii=1,2
8442         do kkk=1,5
8443           do lll=1,3
8444 #ifdef MOMENT
8445             if (iii.eq.1) then
8446               if (imat.eq.1) then
8447                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8448               else
8449                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8450               endif
8451             else
8452               if (imat.eq.1) then
8453                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8454               else
8455                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8456               endif
8457             endif
8458 #endif
8459             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8460      &        auxvec(1))
8461             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8462             if (j.eq.l+1) then
8463               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8464      &          b1(1,itj1),auxvec(1))
8465               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8466             else
8467               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8468      &          b1(1,itl1),auxvec(1))
8469               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8470             endif
8471             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8472      &        pizda(1,1))
8473             vv(1)=pizda(1,1)-pizda(2,2)
8474             vv(2)=pizda(2,1)+pizda(1,2)
8475             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8476             if (swap) then
8477               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8478 #ifdef MOMENT
8479                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8480      &             -(s1+s2+s4)
8481 #else
8482                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8483      &             -(s2+s4)
8484 #endif
8485                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8486               else
8487 #ifdef MOMENT
8488                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8489 #else
8490                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8491 #endif
8492                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8493               endif
8494             else
8495 #ifdef MOMENT
8496               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8497 #else
8498               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8499 #endif
8500               if (l.eq.j+1) then
8501                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8502               else
8503                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8504               endif
8505             endif
8506           enddo
8507         enddo
8508       enddo
8509       return
8510       end
8511 c----------------------------------------------------------------------------
8512       double precision function eello_turn6(i,jj,kk)
8513       implicit real*8 (a-h,o-z)
8514       include 'DIMENSIONS'
8515       include 'COMMON.IOUNITS'
8516       include 'COMMON.CHAIN'
8517       include 'COMMON.DERIV'
8518       include 'COMMON.INTERACT'
8519       include 'COMMON.CONTACTS'
8520       include 'COMMON.TORSION'
8521       include 'COMMON.VAR'
8522       include 'COMMON.GEO'
8523       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8524      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8525      &  ggg1(3),ggg2(3)
8526       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8527      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8528 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8529 C           the respective energy moment and not to the cluster cumulant.
8530       s1=0.0d0
8531       s8=0.0d0
8532       s13=0.0d0
8533 c
8534       eello_turn6=0.0d0
8535       j=i+4
8536       k=i+1
8537       l=i+3
8538       iti=itortyp(itype(i))
8539       itk=itortyp(itype(k))
8540       itk1=itortyp(itype(k+1))
8541       itl=itortyp(itype(l))
8542       itj=itortyp(itype(j))
8543 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8544 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8545 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8546 cd        eello6=0.0d0
8547 cd        return
8548 cd      endif
8549 cd      write (iout,*)
8550 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8551 cd     &   ' and',k,l
8552 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8553       do iii=1,2
8554         do kkk=1,5
8555           do lll=1,3
8556             derx_turn(lll,kkk,iii)=0.0d0
8557           enddo
8558         enddo
8559       enddo
8560 cd      eij=1.0d0
8561 cd      ekl=1.0d0
8562 cd      ekont=1.0d0
8563       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8564 cd      eello6_5=0.0d0
8565 cd      write (2,*) 'eello6_5',eello6_5
8566 #ifdef MOMENT
8567       call transpose2(AEA(1,1,1),auxmat(1,1))
8568       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8569       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8570       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8571 #endif
8572       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8573       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8574       s2 = scalar2(b1(1,itk),vtemp1(1))
8575 #ifdef MOMENT
8576       call transpose2(AEA(1,1,2),atemp(1,1))
8577       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8578       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8579       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8580 #endif
8581       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8582       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8583       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8584 #ifdef MOMENT
8585       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8586       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8587       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8588       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8589       ss13 = scalar2(b1(1,itk),vtemp4(1))
8590       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8591 #endif
8592 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8593 c      s1=0.0d0
8594 c      s2=0.0d0
8595 c      s8=0.0d0
8596 c      s12=0.0d0
8597 c      s13=0.0d0
8598       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8599 C Derivatives in gamma(i+2)
8600       s1d =0.0d0
8601       s8d =0.0d0
8602 #ifdef MOMENT
8603       call transpose2(AEA(1,1,1),auxmatd(1,1))
8604       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8605       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8606       call transpose2(AEAderg(1,1,2),atempd(1,1))
8607       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8608       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8609 #endif
8610       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8611       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8612       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8613 c      s1d=0.0d0
8614 c      s2d=0.0d0
8615 c      s8d=0.0d0
8616 c      s12d=0.0d0
8617 c      s13d=0.0d0
8618       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8619 C Derivatives in gamma(i+3)
8620 #ifdef MOMENT
8621       call transpose2(AEA(1,1,1),auxmatd(1,1))
8622       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8623       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8624       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8625 #endif
8626       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8627       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8628       s2d = scalar2(b1(1,itk),vtemp1d(1))
8629 #ifdef MOMENT
8630       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8631       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8632 #endif
8633       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8634 #ifdef MOMENT
8635       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8636       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8637       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8638 #endif
8639 c      s1d=0.0d0
8640 c      s2d=0.0d0
8641 c      s8d=0.0d0
8642 c      s12d=0.0d0
8643 c      s13d=0.0d0
8644 #ifdef MOMENT
8645       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8646      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8647 #else
8648       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8649      &               -0.5d0*ekont*(s2d+s12d)
8650 #endif
8651 C Derivatives in gamma(i+4)
8652       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8653       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8654       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8655 #ifdef MOMENT
8656       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8657       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8658       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8659 #endif
8660 c      s1d=0.0d0
8661 c      s2d=0.0d0
8662 c      s8d=0.0d0
8663 C      s12d=0.0d0
8664 c      s13d=0.0d0
8665 #ifdef MOMENT
8666       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8667 #else
8668       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8669 #endif
8670 C Derivatives in gamma(i+5)
8671 #ifdef MOMENT
8672       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8673       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8674       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8675 #endif
8676       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8677       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8678       s2d = scalar2(b1(1,itk),vtemp1d(1))
8679 #ifdef MOMENT
8680       call transpose2(AEA(1,1,2),atempd(1,1))
8681       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8682       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8683 #endif
8684       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8685       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8686 #ifdef MOMENT
8687       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8688       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8689       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8690 #endif
8691 c      s1d=0.0d0
8692 c      s2d=0.0d0
8693 c      s8d=0.0d0
8694 c      s12d=0.0d0
8695 c      s13d=0.0d0
8696 #ifdef MOMENT
8697       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8698      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8699 #else
8700       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8701      &               -0.5d0*ekont*(s2d+s12d)
8702 #endif
8703 C Cartesian derivatives
8704       do iii=1,2
8705         do kkk=1,5
8706           do lll=1,3
8707 #ifdef MOMENT
8708             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8709             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8710             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8711 #endif
8712             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8713             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8714      &          vtemp1d(1))
8715             s2d = scalar2(b1(1,itk),vtemp1d(1))
8716 #ifdef MOMENT
8717             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8718             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8719             s8d = -(atempd(1,1)+atempd(2,2))*
8720      &           scalar2(cc(1,1,itl),vtemp2(1))
8721 #endif
8722             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8723      &           auxmatd(1,1))
8724             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8725             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8726 c      s1d=0.0d0
8727 c      s2d=0.0d0
8728 c      s8d=0.0d0
8729 c      s12d=0.0d0
8730 c      s13d=0.0d0
8731 #ifdef MOMENT
8732             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8733      &        - 0.5d0*(s1d+s2d)
8734 #else
8735             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8736      &        - 0.5d0*s2d
8737 #endif
8738 #ifdef MOMENT
8739             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8740      &        - 0.5d0*(s8d+s12d)
8741 #else
8742             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8743      &        - 0.5d0*s12d
8744 #endif
8745           enddo
8746         enddo
8747       enddo
8748 #ifdef MOMENT
8749       do kkk=1,5
8750         do lll=1,3
8751           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8752      &      achuj_tempd(1,1))
8753           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8754           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8755           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8756           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8757           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8758      &      vtemp4d(1))
8759           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8760           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8761           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8762         enddo
8763       enddo
8764 #endif
8765 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8766 cd     &  16*eel_turn6_num
8767 cd      goto 1112
8768       if (j.lt.nres-1) then
8769         j1=j+1
8770         j2=j-1
8771       else
8772         j1=j-1
8773         j2=j-2
8774       endif
8775       if (l.lt.nres-1) then
8776         l1=l+1
8777         l2=l-1
8778       else
8779         l1=l-1
8780         l2=l-2
8781       endif
8782       do ll=1,3
8783 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8784 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8785 cgrad        ghalf=0.5d0*ggg1(ll)
8786 cd        ghalf=0.0d0
8787         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8788         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8789         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8790      &    +ekont*derx_turn(ll,2,1)
8791         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8792         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8793      &    +ekont*derx_turn(ll,4,1)
8794         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8795         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8796         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8797 cgrad        ghalf=0.5d0*ggg2(ll)
8798 cd        ghalf=0.0d0
8799         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8800      &    +ekont*derx_turn(ll,2,2)
8801         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8802         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8803      &    +ekont*derx_turn(ll,4,2)
8804         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8805         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8806         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8807       enddo
8808 cd      goto 1112
8809 cgrad      do m=i+1,j-1
8810 cgrad        do ll=1,3
8811 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8812 cgrad        enddo
8813 cgrad      enddo
8814 cgrad      do m=k+1,l-1
8815 cgrad        do ll=1,3
8816 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8817 cgrad        enddo
8818 cgrad      enddo
8819 cgrad1112  continue
8820 cgrad      do m=i+2,j2
8821 cgrad        do ll=1,3
8822 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8823 cgrad        enddo
8824 cgrad      enddo
8825 cgrad      do m=k+2,l2
8826 cgrad        do ll=1,3
8827 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8828 cgrad        enddo
8829 cgrad      enddo
8830 cd      do iii=1,nres-3
8831 cd        write (2,*) iii,g_corr6_loc(iii)
8832 cd      enddo
8833       eello_turn6=ekont*eel_turn6
8834 cd      write (2,*) 'ekont',ekont
8835 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8836       return
8837       end
8838
8839 C-----------------------------------------------------------------------------
8840       double precision function scalar(u,v)
8841 !DIR$ INLINEALWAYS scalar
8842 #ifndef OSF
8843 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8844 #endif
8845       implicit none
8846       double precision u(3),v(3)
8847 cd      double precision sc
8848 cd      integer i
8849 cd      sc=0.0d0
8850 cd      do i=1,3
8851 cd        sc=sc+u(i)*v(i)
8852 cd      enddo
8853 cd      scalar=sc
8854
8855       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8856       return
8857       end
8858 crc-------------------------------------------------
8859       SUBROUTINE MATVEC2(A1,V1,V2)
8860 !DIR$ INLINEALWAYS MATVEC2
8861 #ifndef OSF
8862 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8863 #endif
8864       implicit real*8 (a-h,o-z)
8865       include 'DIMENSIONS'
8866       DIMENSION A1(2,2),V1(2),V2(2)
8867 c      DO 1 I=1,2
8868 c        VI=0.0
8869 c        DO 3 K=1,2
8870 c    3     VI=VI+A1(I,K)*V1(K)
8871 c        Vaux(I)=VI
8872 c    1 CONTINUE
8873
8874       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8875       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8876
8877       v2(1)=vaux1
8878       v2(2)=vaux2
8879       END
8880 C---------------------------------------
8881       SUBROUTINE MATMAT2(A1,A2,A3)
8882 #ifndef OSF
8883 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8884 #endif
8885       implicit real*8 (a-h,o-z)
8886       include 'DIMENSIONS'
8887       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8888 c      DIMENSION AI3(2,2)
8889 c        DO  J=1,2
8890 c          A3IJ=0.0
8891 c          DO K=1,2
8892 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8893 c          enddo
8894 c          A3(I,J)=A3IJ
8895 c       enddo
8896 c      enddo
8897
8898       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8899       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8900       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8901       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8902
8903       A3(1,1)=AI3_11
8904       A3(2,1)=AI3_21
8905       A3(1,2)=AI3_12
8906       A3(2,2)=AI3_22
8907       END
8908
8909 c-------------------------------------------------------------------------
8910       double precision function scalar2(u,v)
8911 !DIR$ INLINEALWAYS scalar2
8912       implicit none
8913       double precision u(2),v(2)
8914       double precision sc
8915       integer i
8916       scalar2=u(1)*v(1)+u(2)*v(2)
8917       return
8918       end
8919
8920 C-----------------------------------------------------------------------------
8921
8922       subroutine transpose2(a,at)
8923 !DIR$ INLINEALWAYS transpose2
8924 #ifndef OSF
8925 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8926 #endif
8927       implicit none
8928       double precision a(2,2),at(2,2)
8929       at(1,1)=a(1,1)
8930       at(1,2)=a(2,1)
8931       at(2,1)=a(1,2)
8932       at(2,2)=a(2,2)
8933       return
8934       end
8935 c--------------------------------------------------------------------------
8936       subroutine transpose(n,a,at)
8937       implicit none
8938       integer n,i,j
8939       double precision a(n,n),at(n,n)
8940       do i=1,n
8941         do j=1,n
8942           at(j,i)=a(i,j)
8943         enddo
8944       enddo
8945       return
8946       end
8947 C---------------------------------------------------------------------------
8948       subroutine prodmat3(a1,a2,kk,transp,prod)
8949 !DIR$ INLINEALWAYS prodmat3
8950 #ifndef OSF
8951 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8952 #endif
8953       implicit none
8954       integer i,j
8955       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8956       logical transp
8957 crc      double precision auxmat(2,2),prod_(2,2)
8958
8959       if (transp) then
8960 crc        call transpose2(kk(1,1),auxmat(1,1))
8961 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8962 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8963
8964            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8965      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8966            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8967      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8968            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8969      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8970            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8971      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8972
8973       else
8974 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8975 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8976
8977            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8978      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8979            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8980      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8981            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8982      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8983            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8984      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8985
8986       endif
8987 c      call transpose2(a2(1,1),a2t(1,1))
8988
8989 crc      print *,transp
8990 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8991 crc      print *,((prod(i,j),i=1,2),j=1,2)
8992
8993       return
8994       end
8995