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 #undef 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 #undef 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 C        write(iout,*) i,"iti1",iti1," iti2",iti2," iti3",iti3,itype(i+3)
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.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4550      &(itype(i).eq.ntyp1)) cycle
4551         dethetai=0.0d0
4552         dephii=0.0d0
4553         dephii1=0.0d0
4554         theti2=0.5d0*theta(i)
4555         ityp2=ithetyp(itype(i-1))
4556         do k=1,nntheterm
4557           coskt(k)=dcos(k*theti2)
4558           sinkt(k)=dsin(k*theti2)
4559         enddo
4560 C        if (i.gt.3) then
4561         if (i.gt.3 .and. itype(imax0(i-3,1)).ne.ntyp1) then
4562 #ifdef OSF
4563           phii=phi(i)
4564           if (phii.ne.phii) phii=150.0
4565 #else
4566           phii=phi(i)
4567 #endif
4568           ityp1=ithetyp(itype(i-2))
4569           do k=1,nsingle
4570             cosph1(k)=dcos(k*phii)
4571             sinph1(k)=dsin(k*phii)
4572           enddo
4573         else
4574           phii=0.0d0
4575           ityp1=ithetyp(itype(i-2))
4576           do k=1,nsingle
4577             cosph1(k)=0.0d0
4578             sinph1(k)=0.0d0
4579           enddo
4580         endif
4581         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4582 #ifdef OSF
4583           phii1=phi(i+1)
4584           if (phii1.ne.phii1) phii1=150.0
4585           phii1=pinorm(phii1)
4586 #else
4587           phii1=phi(i+1)
4588 #endif
4589           ityp3=ithetyp(itype(i))
4590           do k=1,nsingle
4591             cosph2(k)=dcos(k*phii1)
4592             sinph2(k)=dsin(k*phii1)
4593           enddo
4594         else
4595           phii1=0.0d0
4596           ityp3=ithetyp(itype(i))
4597           do k=1,nsingle
4598             cosph2(k)=0.0d0
4599             sinph2(k)=0.0d0
4600           enddo
4601         endif
4602         ethetai=aa0thet(ityp1,ityp2,ityp3)
4603         do k=1,ndouble
4604           do l=1,k-1
4605             ccl=cosph1(l)*cosph2(k-l)
4606             ssl=sinph1(l)*sinph2(k-l)
4607             scl=sinph1(l)*cosph2(k-l)
4608             csl=cosph1(l)*sinph2(k-l)
4609             cosph1ph2(l,k)=ccl-ssl
4610             cosph1ph2(k,l)=ccl+ssl
4611             sinph1ph2(l,k)=scl+csl
4612             sinph1ph2(k,l)=scl-csl
4613           enddo
4614         enddo
4615         if (lprn) then
4616         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4617      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4618         write (iout,*) "coskt and sinkt"
4619         do k=1,nntheterm
4620           write (iout,*) k,coskt(k),sinkt(k)
4621         enddo
4622         endif
4623         do k=1,ntheterm
4624           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4625           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4626      &      *coskt(k)
4627           if (lprn)
4628      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4629      &     " ethetai",ethetai
4630         enddo
4631         if (lprn) then
4632         write (iout,*) "cosph and sinph"
4633         do k=1,nsingle
4634           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4635         enddo
4636         write (iout,*) "cosph1ph2 and sinph2ph2"
4637         do k=2,ndouble
4638           do l=1,k-1
4639             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4640      &         sinph1ph2(l,k),sinph1ph2(k,l)
4641           enddo
4642         enddo
4643         write(iout,*) "ethetai",ethetai
4644         endif
4645         do m=1,ntheterm2
4646           do k=1,nsingle
4647             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4648      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4649      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4650      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4651             ethetai=ethetai+sinkt(m)*aux
4652             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4653             dephii=dephii+k*sinkt(m)*(
4654      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4655      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4656             dephii1=dephii1+k*sinkt(m)*(
4657      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4658      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4659             if (lprn)
4660      &      write (iout,*) "m",m," k",k," bbthet",
4661      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4662      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4663      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4664      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4665           enddo
4666         enddo
4667         if (lprn)
4668      &  write(iout,*) "ethetai",ethetai
4669         do m=1,ntheterm3
4670           do k=2,ndouble
4671             do l=1,k-1
4672               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4673      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4674      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4675      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4676               ethetai=ethetai+sinkt(m)*aux
4677               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4678               dephii=dephii+l*sinkt(m)*(
4679      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4680      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4681      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4682      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4683               dephii1=dephii1+(k-l)*sinkt(m)*(
4684      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4685      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4686      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4687      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4688               if (lprn) then
4689               write (iout,*) "m",m," k",k," l",l," ffthet",
4690      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4691      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4692      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4693      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4694               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4695      &            cosph1ph2(k,l)*sinkt(m),
4696      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4697               endif
4698             enddo
4699           enddo
4700         enddo
4701 10      continue
4702         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4703      &   i,theta(i)*rad2deg,phii*rad2deg,
4704      &   phii1*rad2deg,ethetai
4705         etheta=etheta+ethetai
4706         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4707      &      'ebend',i,ethetai
4708         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4709         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4710         gloc(nphi+i-2,icg)=wang*dethetai
4711       enddo
4712       return
4713       end
4714 #endif
4715 #ifdef CRYST_SC
4716 c-----------------------------------------------------------------------------
4717       subroutine esc(escloc)
4718 C Calculate the local energy of a side chain and its derivatives in the
4719 C corresponding virtual-bond valence angles THETA and the spherical angles
4720 C ALPHA and OMEGA.
4721       implicit real*8 (a-h,o-z)
4722       include 'DIMENSIONS'
4723       include 'COMMON.GEO'
4724       include 'COMMON.LOCAL'
4725       include 'COMMON.VAR'
4726       include 'COMMON.INTERACT'
4727       include 'COMMON.DERIV'
4728       include 'COMMON.CHAIN'
4729       include 'COMMON.IOUNITS'
4730       include 'COMMON.NAMES'
4731       include 'COMMON.FFIELD'
4732       include 'COMMON.CONTROL'
4733       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4734      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4735       common /sccalc/ time11,time12,time112,theti,it,nlobit
4736       delta=0.02d0*pi
4737       escloc=0.0D0
4738 c     write (iout,'(a)') 'ESC'
4739       do i=loc_start,loc_end
4740         it=itype(i)
4741         if (it.eq.21) cycle
4742         if (it.eq.10) goto 1
4743         nlobit=nlob(it)
4744 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4745 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4746         theti=theta(i+1)-pipol
4747         x(1)=dtan(theti)
4748         x(2)=alph(i)
4749         x(3)=omeg(i)
4750
4751         if (x(2).gt.pi-delta) then
4752           xtemp(1)=x(1)
4753           xtemp(2)=pi-delta
4754           xtemp(3)=x(3)
4755           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4756           xtemp(2)=pi
4757           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4758           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4759      &        escloci,dersc(2))
4760           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4761      &        ddersc0(1),dersc(1))
4762           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4763      &        ddersc0(3),dersc(3))
4764           xtemp(2)=pi-delta
4765           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4766           xtemp(2)=pi
4767           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4768           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4769      &            dersc0(2),esclocbi,dersc02)
4770           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4771      &            dersc12,dersc01)
4772           call splinthet(x(2),0.5d0*delta,ss,ssd)
4773           dersc0(1)=dersc01
4774           dersc0(2)=dersc02
4775           dersc0(3)=0.0d0
4776           do k=1,3
4777             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4778           enddo
4779           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4780 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4781 c    &             esclocbi,ss,ssd
4782           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4783 c         escloci=esclocbi
4784 c         write (iout,*) escloci
4785         else if (x(2).lt.delta) then
4786           xtemp(1)=x(1)
4787           xtemp(2)=delta
4788           xtemp(3)=x(3)
4789           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4790           xtemp(2)=0.0d0
4791           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4792           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4793      &        escloci,dersc(2))
4794           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4795      &        ddersc0(1),dersc(1))
4796           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4797      &        ddersc0(3),dersc(3))
4798           xtemp(2)=delta
4799           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4800           xtemp(2)=0.0d0
4801           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4802           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4803      &            dersc0(2),esclocbi,dersc02)
4804           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4805      &            dersc12,dersc01)
4806           dersc0(1)=dersc01
4807           dersc0(2)=dersc02
4808           dersc0(3)=0.0d0
4809           call splinthet(x(2),0.5d0*delta,ss,ssd)
4810           do k=1,3
4811             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4812           enddo
4813           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4814 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4815 c    &             esclocbi,ss,ssd
4816           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4817 c         write (iout,*) escloci
4818         else
4819           call enesc(x,escloci,dersc,ddummy,.false.)
4820         endif
4821
4822         escloc=escloc+escloci
4823         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4824      &     'escloc',i,escloci
4825 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4826
4827         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4828      &   wscloc*dersc(1)
4829         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4830         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4831     1   continue
4832       enddo
4833       return
4834       end
4835 C---------------------------------------------------------------------------
4836       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4837       implicit real*8 (a-h,o-z)
4838       include 'DIMENSIONS'
4839       include 'COMMON.GEO'
4840       include 'COMMON.LOCAL'
4841       include 'COMMON.IOUNITS'
4842       common /sccalc/ time11,time12,time112,theti,it,nlobit
4843       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4844       double precision contr(maxlob,-1:1)
4845       logical mixed
4846 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4847         escloc_i=0.0D0
4848         do j=1,3
4849           dersc(j)=0.0D0
4850           if (mixed) ddersc(j)=0.0d0
4851         enddo
4852         x3=x(3)
4853
4854 C Because of periodicity of the dependence of the SC energy in omega we have
4855 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4856 C To avoid underflows, first compute & store the exponents.
4857
4858         do iii=-1,1
4859
4860           x(3)=x3+iii*dwapi
4861
4862           do j=1,nlobit
4863             do k=1,3
4864               z(k)=x(k)-censc(k,j,it)
4865             enddo
4866             do k=1,3
4867               Axk=0.0D0
4868               do l=1,3
4869                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4870               enddo
4871               Ax(k,j,iii)=Axk
4872             enddo
4873             expfac=0.0D0
4874             do k=1,3
4875               expfac=expfac+Ax(k,j,iii)*z(k)
4876             enddo
4877             contr(j,iii)=expfac
4878           enddo ! j
4879
4880         enddo ! iii
4881
4882         x(3)=x3
4883 C As in the case of ebend, we want to avoid underflows in exponentiation and
4884 C subsequent NaNs and INFs in energy calculation.
4885 C Find the largest exponent
4886         emin=contr(1,-1)
4887         do iii=-1,1
4888           do j=1,nlobit
4889             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4890           enddo
4891         enddo
4892         emin=0.5D0*emin
4893 cd      print *,'it=',it,' emin=',emin
4894
4895 C Compute the contribution to SC energy and derivatives
4896         do iii=-1,1
4897
4898           do j=1,nlobit
4899 #ifdef OSF
4900             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4901             if(adexp.ne.adexp) adexp=1.0
4902             expfac=dexp(adexp)
4903 #else
4904             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4905 #endif
4906 cd          print *,'j=',j,' expfac=',expfac
4907             escloc_i=escloc_i+expfac
4908             do k=1,3
4909               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4910             enddo
4911             if (mixed) then
4912               do k=1,3,2
4913                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4914      &            +gaussc(k,2,j,it))*expfac
4915               enddo
4916             endif
4917           enddo
4918
4919         enddo ! iii
4920
4921         dersc(1)=dersc(1)/cos(theti)**2
4922         ddersc(1)=ddersc(1)/cos(theti)**2
4923         ddersc(3)=ddersc(3)
4924
4925         escloci=-(dlog(escloc_i)-emin)
4926         do j=1,3
4927           dersc(j)=dersc(j)/escloc_i
4928         enddo
4929         if (mixed) then
4930           do j=1,3,2
4931             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4932           enddo
4933         endif
4934       return
4935       end
4936 C------------------------------------------------------------------------------
4937       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4938       implicit real*8 (a-h,o-z)
4939       include 'DIMENSIONS'
4940       include 'COMMON.GEO'
4941       include 'COMMON.LOCAL'
4942       include 'COMMON.IOUNITS'
4943       common /sccalc/ time11,time12,time112,theti,it,nlobit
4944       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4945       double precision contr(maxlob)
4946       logical mixed
4947
4948       escloc_i=0.0D0
4949
4950       do j=1,3
4951         dersc(j)=0.0D0
4952       enddo
4953
4954       do j=1,nlobit
4955         do k=1,2
4956           z(k)=x(k)-censc(k,j,it)
4957         enddo
4958         z(3)=dwapi
4959         do k=1,3
4960           Axk=0.0D0
4961           do l=1,3
4962             Axk=Axk+gaussc(l,k,j,it)*z(l)
4963           enddo
4964           Ax(k,j)=Axk
4965         enddo
4966         expfac=0.0D0
4967         do k=1,3
4968           expfac=expfac+Ax(k,j)*z(k)
4969         enddo
4970         contr(j)=expfac
4971       enddo ! j
4972
4973 C As in the case of ebend, we want to avoid underflows in exponentiation and
4974 C subsequent NaNs and INFs in energy calculation.
4975 C Find the largest exponent
4976       emin=contr(1)
4977       do j=1,nlobit
4978         if (emin.gt.contr(j)) emin=contr(j)
4979       enddo
4980       emin=0.5D0*emin
4981
4982 C Compute the contribution to SC energy and derivatives
4983
4984       dersc12=0.0d0
4985       do j=1,nlobit
4986         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4987         escloc_i=escloc_i+expfac
4988         do k=1,2
4989           dersc(k)=dersc(k)+Ax(k,j)*expfac
4990         enddo
4991         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4992      &            +gaussc(1,2,j,it))*expfac
4993         dersc(3)=0.0d0
4994       enddo
4995
4996       dersc(1)=dersc(1)/cos(theti)**2
4997       dersc12=dersc12/cos(theti)**2
4998       escloci=-(dlog(escloc_i)-emin)
4999       do j=1,2
5000         dersc(j)=dersc(j)/escloc_i
5001       enddo
5002       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5003       return
5004       end
5005 #else
5006 c----------------------------------------------------------------------------------
5007       subroutine esc(escloc)
5008 C Calculate the local energy of a side chain and its derivatives in the
5009 C corresponding virtual-bond valence angles THETA and the spherical angles
5010 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5011 C added by Urszula Kozlowska. 07/11/2007
5012 C
5013       implicit real*8 (a-h,o-z)
5014       include 'DIMENSIONS'
5015       include 'COMMON.GEO'
5016       include 'COMMON.LOCAL'
5017       include 'COMMON.VAR'
5018       include 'COMMON.SCROT'
5019       include 'COMMON.INTERACT'
5020       include 'COMMON.DERIV'
5021       include 'COMMON.CHAIN'
5022       include 'COMMON.IOUNITS'
5023       include 'COMMON.NAMES'
5024       include 'COMMON.FFIELD'
5025       include 'COMMON.CONTROL'
5026       include 'COMMON.VECTORS'
5027       double precision x_prime(3),y_prime(3),z_prime(3)
5028      &    , sumene,dsc_i,dp2_i,x(65),
5029      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5030      &    de_dxx,de_dyy,de_dzz,de_dt
5031       double precision s1_t,s1_6_t,s2_t,s2_6_t
5032       double precision
5033      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5034      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5035      & dt_dCi(3),dt_dCi1(3)
5036       common /sccalc/ time11,time12,time112,theti,it,nlobit
5037       delta=0.02d0*pi
5038       escloc=0.0D0
5039       do i=loc_start,loc_end
5040         if (itype(i).eq.21) cycle
5041         costtab(i+1) =dcos(theta(i+1))
5042         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5043         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5044         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5045         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5046         cosfac=dsqrt(cosfac2)
5047         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5048         sinfac=dsqrt(sinfac2)
5049         it=itype(i)
5050         if (it.eq.10) goto 1
5051 c
5052 C  Compute the axes of tghe local cartesian coordinates system; store in
5053 c   x_prime, y_prime and z_prime
5054 c
5055         do j=1,3
5056           x_prime(j) = 0.00
5057           y_prime(j) = 0.00
5058           z_prime(j) = 0.00
5059         enddo
5060 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5061 C     &   dc_norm(3,i+nres)
5062         do j = 1,3
5063           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5064           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5065         enddo
5066         do j = 1,3
5067           z_prime(j) = -uz(j,i-1)
5068         enddo
5069 c       write (2,*) "i",i
5070 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5071 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5072 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5073 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5074 c      & " xy",scalar(x_prime(1),y_prime(1)),
5075 c      & " xz",scalar(x_prime(1),z_prime(1)),
5076 c      & " yy",scalar(y_prime(1),y_prime(1)),
5077 c      & " yz",scalar(y_prime(1),z_prime(1)),
5078 c      & " zz",scalar(z_prime(1),z_prime(1))
5079 c
5080 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5081 C to local coordinate system. Store in xx, yy, zz.
5082 c
5083         xx=0.0d0
5084         yy=0.0d0
5085         zz=0.0d0
5086         do j = 1,3
5087           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5088           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5089           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5090         enddo
5091
5092         xxtab(i)=xx
5093         yytab(i)=yy
5094         zztab(i)=zz
5095 C
5096 C Compute the energy of the ith side cbain
5097 C
5098 c        write (2,*) "xx",xx," yy",yy," zz",zz
5099         it=itype(i)
5100         do j = 1,65
5101           x(j) = sc_parmin(j,it)
5102         enddo
5103 #ifdef CHECK_COORD
5104 Cc diagnostics - remove later
5105         xx1 = dcos(alph(2))
5106         yy1 = dsin(alph(2))*dcos(omeg(2))
5107         zz1 = -dsin(alph(2))*dsin(omeg(2))
5108         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5109      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5110      &    xx1,yy1,zz1
5111 C,"  --- ", xx_w,yy_w,zz_w
5112 c end diagnostics
5113 #endif
5114         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5115      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5116      &   + x(10)*yy*zz
5117         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5118      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5119      & + x(20)*yy*zz
5120         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5121      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5122      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5123      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5124      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5125      &  +x(40)*xx*yy*zz
5126         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5127      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5128      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5129      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5130      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5131      &  +x(60)*xx*yy*zz
5132         dsc_i   = 0.743d0+x(61)
5133         dp2_i   = 1.9d0+x(62)
5134         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5135      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5136         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5137      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5138         s1=(1+x(63))/(0.1d0 + dscp1)
5139         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5140         s2=(1+x(65))/(0.1d0 + dscp2)
5141         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5142         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5143      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5144 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5145 c     &   sumene4,
5146 c     &   dscp1,dscp2,sumene
5147 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5148         escloc = escloc + sumene
5149 c        write (2,*) "i",i," escloc",sumene,escloc
5150 #ifdef DEBUG
5151 C
5152 C This section to check the numerical derivatives of the energy of ith side
5153 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5154 C #define DEBUG in the code to turn it on.
5155 C
5156         write (2,*) "sumene               =",sumene
5157         aincr=1.0d-7
5158         xxsave=xx
5159         xx=xx+aincr
5160         write (2,*) xx,yy,zz
5161         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5162         de_dxx_num=(sumenep-sumene)/aincr
5163         xx=xxsave
5164         write (2,*) "xx+ sumene from enesc=",sumenep
5165         yysave=yy
5166         yy=yy+aincr
5167         write (2,*) xx,yy,zz
5168         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5169         de_dyy_num=(sumenep-sumene)/aincr
5170         yy=yysave
5171         write (2,*) "yy+ sumene from enesc=",sumenep
5172         zzsave=zz
5173         zz=zz+aincr
5174         write (2,*) xx,yy,zz
5175         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5176         de_dzz_num=(sumenep-sumene)/aincr
5177         zz=zzsave
5178         write (2,*) "zz+ sumene from enesc=",sumenep
5179         costsave=cost2tab(i+1)
5180         sintsave=sint2tab(i+1)
5181         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5182         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5183         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5184         de_dt_num=(sumenep-sumene)/aincr
5185         write (2,*) " t+ sumene from enesc=",sumenep
5186         cost2tab(i+1)=costsave
5187         sint2tab(i+1)=sintsave
5188 C End of diagnostics section.
5189 #endif
5190 C
5191 C Compute the gradient of esc
5192 C
5193         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5194         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5195         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5196         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5197         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5198         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5199         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5200         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5201         pom1=(sumene3*sint2tab(i+1)+sumene1)
5202      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5203         pom2=(sumene4*cost2tab(i+1)+sumene2)
5204      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5205         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5206         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5207      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5208      &  +x(40)*yy*zz
5209         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5210         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5211      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5212      &  +x(60)*yy*zz
5213         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5214      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5215      &        +(pom1+pom2)*pom_dx
5216 #ifdef DEBUG
5217         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5218 #endif
5219 C
5220         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5221         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5222      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5223      &  +x(40)*xx*zz
5224         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5225         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5226      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5227      &  +x(59)*zz**2 +x(60)*xx*zz
5228         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5229      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5230      &        +(pom1-pom2)*pom_dy
5231 #ifdef DEBUG
5232         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5233 #endif
5234 C
5235         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5236      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5237      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5238      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5239      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5240      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5241      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5242      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5243 #ifdef DEBUG
5244         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5245 #endif
5246 C
5247         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5248      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5249      &  +pom1*pom_dt1+pom2*pom_dt2
5250 #ifdef DEBUG
5251         write(2,*), "de_dt = ", de_dt,de_dt_num
5252 #endif
5253 c
5254 C
5255        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5256        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5257        cosfac2xx=cosfac2*xx
5258        sinfac2yy=sinfac2*yy
5259        do k = 1,3
5260          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5261      &      vbld_inv(i+1)
5262          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5263      &      vbld_inv(i)
5264          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5265          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5266 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5267 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5268 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5269 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5270          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5271          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5272          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5273          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5274          dZZ_Ci1(k)=0.0d0
5275          dZZ_Ci(k)=0.0d0
5276          do j=1,3
5277            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5278            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5279          enddo
5280
5281          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5282          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5283          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5284 c
5285          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5286          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5287        enddo
5288
5289        do k=1,3
5290          dXX_Ctab(k,i)=dXX_Ci(k)
5291          dXX_C1tab(k,i)=dXX_Ci1(k)
5292          dYY_Ctab(k,i)=dYY_Ci(k)
5293          dYY_C1tab(k,i)=dYY_Ci1(k)
5294          dZZ_Ctab(k,i)=dZZ_Ci(k)
5295          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5296          dXX_XYZtab(k,i)=dXX_XYZ(k)
5297          dYY_XYZtab(k,i)=dYY_XYZ(k)
5298          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5299        enddo
5300
5301        do k = 1,3
5302 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5303 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5304 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5305 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5306 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5307 c     &    dt_dci(k)
5308 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5309 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5310          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5311      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5312          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5313      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5314          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5315      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5316        enddo
5317 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5318 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5319
5320 C to check gradient call subroutine check_grad
5321
5322     1 continue
5323       enddo
5324       return
5325       end
5326 c------------------------------------------------------------------------------
5327       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5328       implicit none
5329       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5330      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5331       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5332      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5333      &   + x(10)*yy*zz
5334       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5335      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5336      & + x(20)*yy*zz
5337       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5338      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5339      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5340      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5341      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5342      &  +x(40)*xx*yy*zz
5343       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5344      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5345      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5346      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5347      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5348      &  +x(60)*xx*yy*zz
5349       dsc_i   = 0.743d0+x(61)
5350       dp2_i   = 1.9d0+x(62)
5351       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5352      &          *(xx*cost2+yy*sint2))
5353       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5354      &          *(xx*cost2-yy*sint2))
5355       s1=(1+x(63))/(0.1d0 + dscp1)
5356       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5357       s2=(1+x(65))/(0.1d0 + dscp2)
5358       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5359       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5360      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5361       enesc=sumene
5362       return
5363       end
5364 #endif
5365 c------------------------------------------------------------------------------
5366       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5367 C
5368 C This procedure calculates two-body contact function g(rij) and its derivative:
5369 C
5370 C           eps0ij                                     !       x < -1
5371 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5372 C            0                                         !       x > 1
5373 C
5374 C where x=(rij-r0ij)/delta
5375 C
5376 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5377 C
5378       implicit none
5379       double precision rij,r0ij,eps0ij,fcont,fprimcont
5380       double precision x,x2,x4,delta
5381 c     delta=0.02D0*r0ij
5382 c      delta=0.2D0*r0ij
5383       x=(rij-r0ij)/delta
5384       if (x.lt.-1.0D0) then
5385         fcont=eps0ij
5386         fprimcont=0.0D0
5387       else if (x.le.1.0D0) then
5388         x2=x*x
5389         x4=x2*x2
5390         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5391         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5392       else
5393         fcont=0.0D0
5394         fprimcont=0.0D0
5395       endif
5396       return
5397       end
5398 c------------------------------------------------------------------------------
5399       subroutine splinthet(theti,delta,ss,ssder)
5400       implicit real*8 (a-h,o-z)
5401       include 'DIMENSIONS'
5402       include 'COMMON.VAR'
5403       include 'COMMON.GEO'
5404       thetup=pi-delta
5405       thetlow=delta
5406       if (theti.gt.pipol) then
5407         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5408       else
5409         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5410         ssder=-ssder
5411       endif
5412       return
5413       end
5414 c------------------------------------------------------------------------------
5415       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5416       implicit none
5417       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5418       double precision ksi,ksi2,ksi3,a1,a2,a3
5419       a1=fprim0*delta/(f1-f0)
5420       a2=3.0d0-2.0d0*a1
5421       a3=a1-2.0d0
5422       ksi=(x-x0)/delta
5423       ksi2=ksi*ksi
5424       ksi3=ksi2*ksi
5425       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5426       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5427       return
5428       end
5429 c------------------------------------------------------------------------------
5430       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5431       implicit none
5432       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5433       double precision ksi,ksi2,ksi3,a1,a2,a3
5434       ksi=(x-x0)/delta
5435       ksi2=ksi*ksi
5436       ksi3=ksi2*ksi
5437       a1=fprim0x*delta
5438       a2=3*(f1x-f0x)-2*fprim0x*delta
5439       a3=fprim0x*delta-2*(f1x-f0x)
5440       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5441       return
5442       end
5443 C-----------------------------------------------------------------------------
5444 #ifdef CRYST_TOR
5445 C-----------------------------------------------------------------------------
5446       subroutine etor(etors,edihcnstr)
5447       implicit real*8 (a-h,o-z)
5448       include 'DIMENSIONS'
5449       include 'COMMON.VAR'
5450       include 'COMMON.GEO'
5451       include 'COMMON.LOCAL'
5452       include 'COMMON.TORSION'
5453       include 'COMMON.INTERACT'
5454       include 'COMMON.DERIV'
5455       include 'COMMON.CHAIN'
5456       include 'COMMON.NAMES'
5457       include 'COMMON.IOUNITS'
5458       include 'COMMON.FFIELD'
5459       include 'COMMON.TORCNSTR'
5460       include 'COMMON.CONTROL'
5461       logical lprn
5462 C Set lprn=.true. for debugging
5463       lprn=.false.
5464 c      lprn=.true.
5465       etors=0.0D0
5466       do i=iphi_start,iphi_end
5467       etors_ii=0.0D0
5468         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5469      &      .or. itype(i).eq.21) cycle
5470         itori=itortyp(itype(i-2))
5471         itori1=itortyp(itype(i-1))
5472         phii=phi(i)
5473         gloci=0.0D0
5474 C Proline-Proline pair is a special case...
5475         if (itori.eq.3 .and. itori1.eq.3) then
5476           if (phii.gt.-dwapi3) then
5477             cosphi=dcos(3*phii)
5478             fac=1.0D0/(1.0D0-cosphi)
5479             etorsi=v1(1,3,3)*fac
5480             etorsi=etorsi+etorsi
5481             etors=etors+etorsi-v1(1,3,3)
5482             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5483             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5484           endif
5485           do j=1,3
5486             v1ij=v1(j+1,itori,itori1)
5487             v2ij=v2(j+1,itori,itori1)
5488             cosphi=dcos(j*phii)
5489             sinphi=dsin(j*phii)
5490             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5491             if (energy_dec) etors_ii=etors_ii+
5492      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5493             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5494           enddo
5495         else
5496           do j=1,nterm_old
5497             v1ij=v1(j,itori,itori1)
5498             v2ij=v2(j,itori,itori1)
5499             cosphi=dcos(j*phii)
5500             sinphi=dsin(j*phii)
5501             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5502             if (energy_dec) etors_ii=etors_ii+
5503      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5504             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5505           enddo
5506         endif
5507         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5508              'etor',i,etors_ii
5509         if (lprn)
5510      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5511      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5512      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5513         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5514 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5515       enddo
5516 ! 6/20/98 - dihedral angle constraints
5517       edihcnstr=0.0d0
5518       do i=1,ndih_constr
5519         itori=idih_constr(i)
5520         phii=phi(itori)
5521         difi=phii-phi0(i)
5522         if (difi.gt.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         else if (difi.lt.-drange(i)) then
5527           difi=difi+drange(i)
5528           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5529           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5530         endif
5531 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5532 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5533       enddo
5534 !      write (iout,*) 'edihcnstr',edihcnstr
5535       return
5536       end
5537 c------------------------------------------------------------------------------
5538       subroutine etor_d(etors_d)
5539       etors_d=0.0d0
5540       return
5541       end
5542 c----------------------------------------------------------------------------
5543 #else
5544       subroutine etor(etors,edihcnstr)
5545       implicit real*8 (a-h,o-z)
5546       include 'DIMENSIONS'
5547       include 'COMMON.VAR'
5548       include 'COMMON.GEO'
5549       include 'COMMON.LOCAL'
5550       include 'COMMON.TORSION'
5551       include 'COMMON.INTERACT'
5552       include 'COMMON.DERIV'
5553       include 'COMMON.CHAIN'
5554       include 'COMMON.NAMES'
5555       include 'COMMON.IOUNITS'
5556       include 'COMMON.FFIELD'
5557       include 'COMMON.TORCNSTR'
5558       include 'COMMON.CONTROL'
5559       logical lprn
5560 C Set lprn=.true. for debugging
5561       lprn=.false.
5562 c     lprn=.true.
5563       etors=0.0D0
5564       do i=iphi_start,iphi_end
5565         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5566      &       .or. itype(i).eq.21
5567      &       .or. itype(i-3).eq.ntyp1) cycle
5568       etors_ii=0.0D0
5569         itori=itortyp(itype(i-2))
5570         itori1=itortyp(itype(i-1))
5571         phii=phi(i)
5572         gloci=0.0D0
5573 C Regular cosine and sine terms
5574         do j=1,nterm(itori,itori1)
5575           v1ij=v1(j,itori,itori1)
5576           v2ij=v2(j,itori,itori1)
5577           cosphi=dcos(j*phii)
5578           sinphi=dsin(j*phii)
5579           etors=etors+v1ij*cosphi+v2ij*sinphi
5580           if (energy_dec) etors_ii=etors_ii+
5581      &                v1ij*cosphi+v2ij*sinphi
5582           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5583         enddo
5584 C Lorentz terms
5585 C                         v1
5586 C  E = SUM ----------------------------------- - v1
5587 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5588 C
5589         cosphi=dcos(0.5d0*phii)
5590         sinphi=dsin(0.5d0*phii)
5591         do j=1,nlor(itori,itori1)
5592           vl1ij=vlor1(j,itori,itori1)
5593           vl2ij=vlor2(j,itori,itori1)
5594           vl3ij=vlor3(j,itori,itori1)
5595           pom=vl2ij*cosphi+vl3ij*sinphi
5596           pom1=1.0d0/(pom*pom+1.0d0)
5597           etors=etors+vl1ij*pom1
5598           if (energy_dec) etors_ii=etors_ii+
5599      &                vl1ij*pom1
5600           pom=-pom*pom1*pom1
5601           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5602         enddo
5603 C Subtract the constant term
5604         etors=etors-v0(itori,itori1)
5605           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5606      &         'etor',i,etors_ii-v0(itori,itori1)
5607         if (lprn)
5608      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5609      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5610      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5611         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5612 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5613       enddo
5614 ! 6/20/98 - dihedral angle constraints
5615       edihcnstr=0.0d0
5616 c      do i=1,ndih_constr
5617       do i=idihconstr_start,idihconstr_end
5618         itori=idih_constr(i)
5619         phii=phi(itori)
5620         difi=pinorm(phii-phi0(i))
5621         if (difi.gt.drange(i)) then
5622           difi=difi-drange(i)
5623           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5624           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5625         else if (difi.lt.-drange(i)) then
5626           difi=difi+drange(i)
5627           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5628           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5629         else
5630           difi=0.0
5631         endif
5632 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5633 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5634 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5635       enddo
5636 cd       write (iout,*) 'edihcnstr',edihcnstr
5637       return
5638       end
5639 c----------------------------------------------------------------------------
5640       subroutine etor_d(etors_d)
5641 C 6/23/01 Compute double torsional energy
5642       implicit real*8 (a-h,o-z)
5643       include 'DIMENSIONS'
5644       include 'COMMON.VAR'
5645       include 'COMMON.GEO'
5646       include 'COMMON.LOCAL'
5647       include 'COMMON.TORSION'
5648       include 'COMMON.INTERACT'
5649       include 'COMMON.DERIV'
5650       include 'COMMON.CHAIN'
5651       include 'COMMON.NAMES'
5652       include 'COMMON.IOUNITS'
5653       include 'COMMON.FFIELD'
5654       include 'COMMON.TORCNSTR'
5655       include 'COMMON.CONTROL'
5656       logical lprn
5657 C Set lprn=.true. for debugging
5658       lprn=.false.
5659 c     lprn=.true.
5660       etors_d=0.0D0
5661 C      write(iout,*) "a tu??"
5662       do i=iphid_start,iphid_end
5663         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5664      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21
5665      &       .or. itype(i-3).eq.ntyp1) cycle
5666         etors_d_ii=0.0D0
5667         itori=itortyp(itype(i-2))
5668         itori1=itortyp(itype(i-1))
5669         itori2=itortyp(itype(i))
5670         phii=phi(i)
5671         phii1=phi(i+1)
5672         gloci1=0.0D0
5673         gloci2=0.0D0
5674 C Regular cosine and sine terms
5675         do j=1,ntermd_1(itori,itori1,itori2)
5676           v1cij=v1c(1,j,itori,itori1,itori2)
5677           v1sij=v1s(1,j,itori,itori1,itori2)
5678           v2cij=v1c(2,j,itori,itori1,itori2)
5679           v2sij=v1s(2,j,itori,itori1,itori2)
5680           cosphi1=dcos(j*phii)
5681           sinphi1=dsin(j*phii)
5682           cosphi2=dcos(j*phii1)
5683           sinphi2=dsin(j*phii1)
5684           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5685      &     v2cij*cosphi2+v2sij*sinphi2
5686           if (energy_dec) etors_d_ii=etors_d_ii+
5687      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5688           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5689           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5690         enddo
5691         do k=2,ntermd_2(itori,itori1,itori2)
5692           do l=1,k-1
5693             v1cdij = v2c(k,l,itori,itori1,itori2)
5694             v2cdij = v2c(l,k,itori,itori1,itori2)
5695             v1sdij = v2s(k,l,itori,itori1,itori2)
5696             v2sdij = v2s(l,k,itori,itori1,itori2)
5697             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5698             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5699             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5700             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5701             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5702      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5703             if (energy_dec) etors_d_ii=etors_d_ii+
5704      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5705      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5706             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5707      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5708             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5709      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5710           enddo
5711         enddo
5712           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5713      &         'etor_d',i,etors_d_ii
5714         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5715         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5716       enddo
5717       return
5718       end
5719 #endif
5720 c------------------------------------------------------------------------------
5721       subroutine eback_sc_corr(esccor)
5722 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5723 c        conformational states; temporarily implemented as differences
5724 c        between UNRES torsional potentials (dependent on three types of
5725 c        residues) and the torsional potentials dependent on all 20 types
5726 c        of residues computed from AM1  energy surfaces of terminally-blocked
5727 c        amino-acid residues.
5728       implicit real*8 (a-h,o-z)
5729       include 'DIMENSIONS'
5730       include 'COMMON.VAR'
5731       include 'COMMON.GEO'
5732       include 'COMMON.LOCAL'
5733       include 'COMMON.TORSION'
5734       include 'COMMON.SCCOR'
5735       include 'COMMON.INTERACT'
5736       include 'COMMON.DERIV'
5737       include 'COMMON.CHAIN'
5738       include 'COMMON.NAMES'
5739       include 'COMMON.IOUNITS'
5740       include 'COMMON.FFIELD'
5741       include 'COMMON.CONTROL'
5742       logical lprn
5743 C Set lprn=.true. for debugging
5744       lprn=.false.
5745 c      lprn=.true.
5746 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5747       esccor=0.0D0
5748       do i=itau_start,itau_end
5749         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5750         esccor_ii=0.0D0
5751         isccori=isccortyp(itype(i-2))
5752         isccori1=isccortyp(itype(i-1))
5753 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5754         phii=phi(i)
5755         do intertyp=1,3 !intertyp
5756 cc Added 09 May 2012 (Adasko)
5757 cc  Intertyp means interaction type of backbone mainchain correlation:
5758 c   1 = SC...Ca...Ca...Ca
5759 c   2 = Ca...Ca...Ca...SC
5760 c   3 = SC...Ca...Ca...SCi
5761         gloci=0.0D0
5762         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5763      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5764      &      (itype(i-1).eq.ntyp1)))
5765      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5766      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5767      &     .or.(itype(i).eq.ntyp1)))
5768      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5769      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5770      &      (itype(i-3).eq.ntyp1)))) cycle
5771         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5772         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5773      & cycle
5774        do j=1,nterm_sccor(isccori,isccori1)
5775           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5776           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5777           cosphi=dcos(j*tauangle(intertyp,i))
5778           sinphi=dsin(j*tauangle(intertyp,i))
5779           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5780           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5781         enddo
5782 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5783         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5784         if (lprn)
5785      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5786      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5787      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5788      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5789         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5790        enddo !intertyp
5791       enddo
5792
5793       return
5794       end
5795 c----------------------------------------------------------------------------
5796       subroutine multibody(ecorr)
5797 C This subroutine calculates multi-body contributions to energy following
5798 C the idea of Skolnick et al. If side chains I and J make a contact and
5799 C at the same time side chains I+1 and J+1 make a contact, an extra
5800 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5801       implicit real*8 (a-h,o-z)
5802       include 'DIMENSIONS'
5803       include 'COMMON.IOUNITS'
5804       include 'COMMON.DERIV'
5805       include 'COMMON.INTERACT'
5806       include 'COMMON.CONTACTS'
5807       double precision gx(3),gx1(3)
5808       logical lprn
5809
5810 C Set lprn=.true. for debugging
5811       lprn=.false.
5812
5813       if (lprn) then
5814         write (iout,'(a)') 'Contact function values:'
5815         do i=nnt,nct-2
5816           write (iout,'(i2,20(1x,i2,f10.5))')
5817      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5818         enddo
5819       endif
5820       ecorr=0.0D0
5821       do i=nnt,nct
5822         do j=1,3
5823           gradcorr(j,i)=0.0D0
5824           gradxorr(j,i)=0.0D0
5825         enddo
5826       enddo
5827       do i=nnt,nct-2
5828
5829         DO ISHIFT = 3,4
5830
5831         i1=i+ishift
5832         num_conti=num_cont(i)
5833         num_conti1=num_cont(i1)
5834         do jj=1,num_conti
5835           j=jcont(jj,i)
5836           do kk=1,num_conti1
5837             j1=jcont(kk,i1)
5838             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5839 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5840 cd   &                   ' ishift=',ishift
5841 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5842 C The system gains extra energy.
5843               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5844             endif   ! j1==j+-ishift
5845           enddo     ! kk
5846         enddo       ! jj
5847
5848         ENDDO ! ISHIFT
5849
5850       enddo         ! i
5851       return
5852       end
5853 c------------------------------------------------------------------------------
5854       double precision function esccorr(i,j,k,l,jj,kk)
5855       implicit real*8 (a-h,o-z)
5856       include 'DIMENSIONS'
5857       include 'COMMON.IOUNITS'
5858       include 'COMMON.DERIV'
5859       include 'COMMON.INTERACT'
5860       include 'COMMON.CONTACTS'
5861       double precision gx(3),gx1(3)
5862       logical lprn
5863       lprn=.false.
5864       eij=facont(jj,i)
5865       ekl=facont(kk,k)
5866 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5867 C Calculate the multi-body contribution to energy.
5868 C Calculate multi-body contributions to the gradient.
5869 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5870 cd   & k,l,(gacont(m,kk,k),m=1,3)
5871       do m=1,3
5872         gx(m) =ekl*gacont(m,jj,i)
5873         gx1(m)=eij*gacont(m,kk,k)
5874         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5875         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5876         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5877         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5878       enddo
5879       do m=i,j-1
5880         do ll=1,3
5881           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5882         enddo
5883       enddo
5884       do m=k,l-1
5885         do ll=1,3
5886           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5887         enddo
5888       enddo
5889       esccorr=-eij*ekl
5890       return
5891       end
5892 c------------------------------------------------------------------------------
5893       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5894 C This subroutine calculates multi-body contributions to hydrogen-bonding
5895       implicit real*8 (a-h,o-z)
5896       include 'DIMENSIONS'
5897       include 'COMMON.IOUNITS'
5898 #ifdef MPI
5899       include "mpif.h"
5900       parameter (max_cont=maxconts)
5901       parameter (max_dim=26)
5902       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5903       double precision zapas(max_dim,maxconts,max_fg_procs),
5904      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5905       common /przechowalnia/ zapas
5906       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5907      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5908 #endif
5909       include 'COMMON.SETUP'
5910       include 'COMMON.FFIELD'
5911       include 'COMMON.DERIV'
5912       include 'COMMON.INTERACT'
5913       include 'COMMON.CONTACTS'
5914       include 'COMMON.CONTROL'
5915       include 'COMMON.LOCAL'
5916       double precision gx(3),gx1(3),time00
5917       logical lprn,ldone
5918
5919 C Set lprn=.true. for debugging
5920       lprn=.false.
5921 #ifdef MPI
5922       n_corr=0
5923       n_corr1=0
5924       if (nfgtasks.le.1) goto 30
5925       if (lprn) then
5926         write (iout,'(a)') 'Contact function values before RECEIVE:'
5927         do i=nnt,nct-2
5928           write (iout,'(2i3,50(1x,i2,f5.2))')
5929      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5930      &    j=1,num_cont_hb(i))
5931         enddo
5932       endif
5933       call flush(iout)
5934       do i=1,ntask_cont_from
5935         ncont_recv(i)=0
5936       enddo
5937       do i=1,ntask_cont_to
5938         ncont_sent(i)=0
5939       enddo
5940 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5941 c     & ntask_cont_to
5942 C Make the list of contacts to send to send to other procesors
5943 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5944 c      call flush(iout)
5945       do i=iturn3_start,iturn3_end
5946 c        write (iout,*) "make contact list turn3",i," num_cont",
5947 c     &    num_cont_hb(i)
5948         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5949       enddo
5950       do i=iturn4_start,iturn4_end
5951 c        write (iout,*) "make contact list turn4",i," num_cont",
5952 c     &   num_cont_hb(i)
5953         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5954       enddo
5955       do ii=1,nat_sent
5956         i=iat_sent(ii)
5957 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5958 c     &    num_cont_hb(i)
5959         do j=1,num_cont_hb(i)
5960         do k=1,4
5961           jjc=jcont_hb(j,i)
5962           iproc=iint_sent_local(k,jjc,ii)
5963 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5964           if (iproc.gt.0) then
5965             ncont_sent(iproc)=ncont_sent(iproc)+1
5966             nn=ncont_sent(iproc)
5967             zapas(1,nn,iproc)=i
5968             zapas(2,nn,iproc)=jjc
5969             zapas(3,nn,iproc)=facont_hb(j,i)
5970             zapas(4,nn,iproc)=ees0p(j,i)
5971             zapas(5,nn,iproc)=ees0m(j,i)
5972             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5973             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5974             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5975             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5976             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5977             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5978             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5979             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5980             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5981             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5982             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5983             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5984             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5985             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5986             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5987             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5988             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5989             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5990             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5991             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5992             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5993           endif
5994         enddo
5995         enddo
5996       enddo
5997       if (lprn) then
5998       write (iout,*)
5999      &  "Numbers of contacts to be sent to other processors",
6000      &  (ncont_sent(i),i=1,ntask_cont_to)
6001       write (iout,*) "Contacts sent"
6002       do ii=1,ntask_cont_to
6003         nn=ncont_sent(ii)
6004         iproc=itask_cont_to(ii)
6005         write (iout,*) nn," contacts to processor",iproc,
6006      &   " of CONT_TO_COMM group"
6007         do i=1,nn
6008           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6009         enddo
6010       enddo
6011       call flush(iout)
6012       endif
6013       CorrelType=477
6014       CorrelID=fg_rank+1
6015       CorrelType1=478
6016       CorrelID1=nfgtasks+fg_rank+1
6017       ireq=0
6018 C Receive the numbers of needed contacts from other processors
6019       do ii=1,ntask_cont_from
6020         iproc=itask_cont_from(ii)
6021         ireq=ireq+1
6022         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6023      &    FG_COMM,req(ireq),IERR)
6024       enddo
6025 c      write (iout,*) "IRECV ended"
6026 c      call flush(iout)
6027 C Send the number of contacts needed by other processors
6028       do ii=1,ntask_cont_to
6029         iproc=itask_cont_to(ii)
6030         ireq=ireq+1
6031         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6032      &    FG_COMM,req(ireq),IERR)
6033       enddo
6034 c      write (iout,*) "ISEND ended"
6035 c      write (iout,*) "number of requests (nn)",ireq
6036       call flush(iout)
6037       if (ireq.gt.0)
6038      &  call MPI_Waitall(ireq,req,status_array,ierr)
6039 c      write (iout,*)
6040 c     &  "Numbers of contacts to be received from other processors",
6041 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6042 c      call flush(iout)
6043 C Receive contacts
6044       ireq=0
6045       do ii=1,ntask_cont_from
6046         iproc=itask_cont_from(ii)
6047         nn=ncont_recv(ii)
6048 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6049 c     &   " of CONT_TO_COMM group"
6050         call flush(iout)
6051         if (nn.gt.0) then
6052           ireq=ireq+1
6053           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6054      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6055 c          write (iout,*) "ireq,req",ireq,req(ireq)
6056         endif
6057       enddo
6058 C Send the contacts to processors that need them
6059       do ii=1,ntask_cont_to
6060         iproc=itask_cont_to(ii)
6061         nn=ncont_sent(ii)
6062 c        write (iout,*) nn," contacts to processor",iproc,
6063 c     &   " of CONT_TO_COMM group"
6064         if (nn.gt.0) then
6065           ireq=ireq+1
6066           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6067      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6068 c          write (iout,*) "ireq,req",ireq,req(ireq)
6069 c          do i=1,nn
6070 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6071 c          enddo
6072         endif
6073       enddo
6074 c      write (iout,*) "number of requests (contacts)",ireq
6075 c      write (iout,*) "req",(req(i),i=1,4)
6076 c      call flush(iout)
6077       if (ireq.gt.0)
6078      & call MPI_Waitall(ireq,req,status_array,ierr)
6079       do iii=1,ntask_cont_from
6080         iproc=itask_cont_from(iii)
6081         nn=ncont_recv(iii)
6082         if (lprn) then
6083         write (iout,*) "Received",nn," contacts from processor",iproc,
6084      &   " of CONT_FROM_COMM group"
6085         call flush(iout)
6086         do i=1,nn
6087           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6088         enddo
6089         call flush(iout)
6090         endif
6091         do i=1,nn
6092           ii=zapas_recv(1,i,iii)
6093 c Flag the received contacts to prevent double-counting
6094           jj=-zapas_recv(2,i,iii)
6095 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6096 c          call flush(iout)
6097           nnn=num_cont_hb(ii)+1
6098           num_cont_hb(ii)=nnn
6099           jcont_hb(nnn,ii)=jj
6100           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6101           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6102           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6103           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6104           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6105           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6106           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6107           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6108           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6109           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6110           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6111           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6112           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6113           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6114           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6115           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6116           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6117           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6118           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6119           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6120           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6121           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6122           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6123           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6124         enddo
6125       enddo
6126       call flush(iout)
6127       if (lprn) then
6128         write (iout,'(a)') 'Contact function values after receive:'
6129         do i=nnt,nct-2
6130           write (iout,'(2i3,50(1x,i3,f5.2))')
6131      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6132      &    j=1,num_cont_hb(i))
6133         enddo
6134         call flush(iout)
6135       endif
6136    30 continue
6137 #endif
6138       if (lprn) then
6139         write (iout,'(a)') 'Contact function values:'
6140         do i=nnt,nct-2
6141           write (iout,'(2i3,50(1x,i3,f5.2))')
6142      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6143      &    j=1,num_cont_hb(i))
6144         enddo
6145       endif
6146       ecorr=0.0D0
6147 C Remove the loop below after debugging !!!
6148       do i=nnt,nct
6149         do j=1,3
6150           gradcorr(j,i)=0.0D0
6151           gradxorr(j,i)=0.0D0
6152         enddo
6153       enddo
6154 C Calculate the local-electrostatic correlation terms
6155       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6156         i1=i+1
6157         num_conti=num_cont_hb(i)
6158         num_conti1=num_cont_hb(i+1)
6159         do jj=1,num_conti
6160           j=jcont_hb(jj,i)
6161           jp=iabs(j)
6162           do kk=1,num_conti1
6163             j1=jcont_hb(kk,i1)
6164             jp1=iabs(j1)
6165 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6166 c     &         ' jj=',jj,' kk=',kk
6167             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6168      &          .or. j.lt.0 .and. j1.gt.0) .and.
6169      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6170 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6171 C The system gains extra energy.
6172               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6173               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6174      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6175               n_corr=n_corr+1
6176             else if (j1.eq.j) then
6177 C Contacts I-J and I-(J+1) occur simultaneously.
6178 C The system loses extra energy.
6179 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6180             endif
6181           enddo ! kk
6182           do kk=1,num_conti
6183             j1=jcont_hb(kk,i)
6184 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6185 c    &         ' jj=',jj,' kk=',kk
6186             if (j1.eq.j+1) then
6187 C Contacts I-J and (I+1)-J occur simultaneously.
6188 C The system loses extra energy.
6189 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6190             endif ! j1==j+1
6191           enddo ! kk
6192         enddo ! jj
6193       enddo ! i
6194       return
6195       end
6196 c------------------------------------------------------------------------------
6197       subroutine add_hb_contact(ii,jj,itask)
6198       implicit real*8 (a-h,o-z)
6199       include "DIMENSIONS"
6200       include "COMMON.IOUNITS"
6201       integer max_cont
6202       integer max_dim
6203       parameter (max_cont=maxconts)
6204       parameter (max_dim=26)
6205       include "COMMON.CONTACTS"
6206       double precision zapas(max_dim,maxconts,max_fg_procs),
6207      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6208       common /przechowalnia/ zapas
6209       integer i,j,ii,jj,iproc,itask(4),nn
6210 c      write (iout,*) "itask",itask
6211       do i=1,2
6212         iproc=itask(i)
6213         if (iproc.gt.0) then
6214           do j=1,num_cont_hb(ii)
6215             jjc=jcont_hb(j,ii)
6216 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6217             if (jjc.eq.jj) then
6218               ncont_sent(iproc)=ncont_sent(iproc)+1
6219               nn=ncont_sent(iproc)
6220               zapas(1,nn,iproc)=ii
6221               zapas(2,nn,iproc)=jjc
6222               zapas(3,nn,iproc)=facont_hb(j,ii)
6223               zapas(4,nn,iproc)=ees0p(j,ii)
6224               zapas(5,nn,iproc)=ees0m(j,ii)
6225               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6226               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6227               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6228               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6229               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6230               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6231               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6232               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6233               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6234               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6235               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6236               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6237               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6238               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6239               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6240               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6241               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6242               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6243               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6244               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6245               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6246               exit
6247             endif
6248           enddo
6249         endif
6250       enddo
6251       return
6252       end
6253 c------------------------------------------------------------------------------
6254       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6255      &  n_corr1)
6256 C This subroutine calculates multi-body contributions to hydrogen-bonding
6257       implicit real*8 (a-h,o-z)
6258       include 'DIMENSIONS'
6259       include 'COMMON.IOUNITS'
6260 #ifdef MPI
6261       include "mpif.h"
6262       parameter (max_cont=maxconts)
6263       parameter (max_dim=70)
6264       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6265       double precision zapas(max_dim,maxconts,max_fg_procs),
6266      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6267       common /przechowalnia/ zapas
6268       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6269      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6270 #endif
6271       include 'COMMON.SETUP'
6272       include 'COMMON.FFIELD'
6273       include 'COMMON.DERIV'
6274       include 'COMMON.LOCAL'
6275       include 'COMMON.INTERACT'
6276       include 'COMMON.CONTACTS'
6277       include 'COMMON.CHAIN'
6278       include 'COMMON.CONTROL'
6279       double precision gx(3),gx1(3)
6280       integer num_cont_hb_old(maxres)
6281       logical lprn,ldone
6282       double precision eello4,eello5,eelo6,eello_turn6
6283       external eello4,eello5,eello6,eello_turn6
6284 C Set lprn=.true. for debugging
6285       lprn=.false.
6286       eturn6=0.0d0
6287 #ifdef MPI
6288       do i=1,nres
6289         num_cont_hb_old(i)=num_cont_hb(i)
6290       enddo
6291       n_corr=0
6292       n_corr1=0
6293       if (nfgtasks.le.1) goto 30
6294       if (lprn) then
6295         write (iout,'(a)') 'Contact function values before RECEIVE:'
6296         do i=nnt,nct-2
6297           write (iout,'(2i3,50(1x,i2,f5.2))')
6298      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6299      &    j=1,num_cont_hb(i))
6300         enddo
6301       endif
6302       call flush(iout)
6303       do i=1,ntask_cont_from
6304         ncont_recv(i)=0
6305       enddo
6306       do i=1,ntask_cont_to
6307         ncont_sent(i)=0
6308       enddo
6309 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6310 c     & ntask_cont_to
6311 C Make the list of contacts to send to send to other procesors
6312       do i=iturn3_start,iturn3_end
6313 c        write (iout,*) "make contact list turn3",i," num_cont",
6314 c     &    num_cont_hb(i)
6315         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6316       enddo
6317       do i=iturn4_start,iturn4_end
6318 c        write (iout,*) "make contact list turn4",i," num_cont",
6319 c     &   num_cont_hb(i)
6320         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6321       enddo
6322       do ii=1,nat_sent
6323         i=iat_sent(ii)
6324 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6325 c     &    num_cont_hb(i)
6326         do j=1,num_cont_hb(i)
6327         do k=1,4
6328           jjc=jcont_hb(j,i)
6329           iproc=iint_sent_local(k,jjc,ii)
6330 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6331           if (iproc.ne.0) then
6332             ncont_sent(iproc)=ncont_sent(iproc)+1
6333             nn=ncont_sent(iproc)
6334             zapas(1,nn,iproc)=i
6335             zapas(2,nn,iproc)=jjc
6336             zapas(3,nn,iproc)=d_cont(j,i)
6337             ind=3
6338             do kk=1,3
6339               ind=ind+1
6340               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6341             enddo
6342             do kk=1,2
6343               do ll=1,2
6344                 ind=ind+1
6345                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6346               enddo
6347             enddo
6348             do jj=1,5
6349               do kk=1,3
6350                 do ll=1,2
6351                   do mm=1,2
6352                     ind=ind+1
6353                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6354                   enddo
6355                 enddo
6356               enddo
6357             enddo
6358           endif
6359         enddo
6360         enddo
6361       enddo
6362       if (lprn) then
6363       write (iout,*)
6364      &  "Numbers of contacts to be sent to other processors",
6365      &  (ncont_sent(i),i=1,ntask_cont_to)
6366       write (iout,*) "Contacts sent"
6367       do ii=1,ntask_cont_to
6368         nn=ncont_sent(ii)
6369         iproc=itask_cont_to(ii)
6370         write (iout,*) nn," contacts to processor",iproc,
6371      &   " of CONT_TO_COMM group"
6372         do i=1,nn
6373           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6374         enddo
6375       enddo
6376       call flush(iout)
6377       endif
6378       CorrelType=477
6379       CorrelID=fg_rank+1
6380       CorrelType1=478
6381       CorrelID1=nfgtasks+fg_rank+1
6382       ireq=0
6383 C Receive the numbers of needed contacts from other processors
6384       do ii=1,ntask_cont_from
6385         iproc=itask_cont_from(ii)
6386         ireq=ireq+1
6387         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6388      &    FG_COMM,req(ireq),IERR)
6389       enddo
6390 c      write (iout,*) "IRECV ended"
6391 c      call flush(iout)
6392 C Send the number of contacts needed by other processors
6393       do ii=1,ntask_cont_to
6394         iproc=itask_cont_to(ii)
6395         ireq=ireq+1
6396         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6397      &    FG_COMM,req(ireq),IERR)
6398       enddo
6399 c      write (iout,*) "ISEND ended"
6400 c      write (iout,*) "number of requests (nn)",ireq
6401       call flush(iout)
6402       if (ireq.gt.0)
6403      &  call MPI_Waitall(ireq,req,status_array,ierr)
6404 c      write (iout,*)
6405 c     &  "Numbers of contacts to be received from other processors",
6406 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6407 c      call flush(iout)
6408 C Receive contacts
6409       ireq=0
6410       do ii=1,ntask_cont_from
6411         iproc=itask_cont_from(ii)
6412         nn=ncont_recv(ii)
6413 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6414 c     &   " of CONT_TO_COMM group"
6415         call flush(iout)
6416         if (nn.gt.0) then
6417           ireq=ireq+1
6418           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6419      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6420 c          write (iout,*) "ireq,req",ireq,req(ireq)
6421         endif
6422       enddo
6423 C Send the contacts to processors that need them
6424       do ii=1,ntask_cont_to
6425         iproc=itask_cont_to(ii)
6426         nn=ncont_sent(ii)
6427 c        write (iout,*) nn," contacts to processor",iproc,
6428 c     &   " of CONT_TO_COMM group"
6429         if (nn.gt.0) then
6430           ireq=ireq+1
6431           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6432      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6433 c          write (iout,*) "ireq,req",ireq,req(ireq)
6434 c          do i=1,nn
6435 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6436 c          enddo
6437         endif
6438       enddo
6439 c      write (iout,*) "number of requests (contacts)",ireq
6440 c      write (iout,*) "req",(req(i),i=1,4)
6441 c      call flush(iout)
6442       if (ireq.gt.0)
6443      & call MPI_Waitall(ireq,req,status_array,ierr)
6444       do iii=1,ntask_cont_from
6445         iproc=itask_cont_from(iii)
6446         nn=ncont_recv(iii)
6447         if (lprn) then
6448         write (iout,*) "Received",nn," contacts from processor",iproc,
6449      &   " of CONT_FROM_COMM group"
6450         call flush(iout)
6451         do i=1,nn
6452           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6453         enddo
6454         call flush(iout)
6455         endif
6456         do i=1,nn
6457           ii=zapas_recv(1,i,iii)
6458 c Flag the received contacts to prevent double-counting
6459           jj=-zapas_recv(2,i,iii)
6460 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6461 c          call flush(iout)
6462           nnn=num_cont_hb(ii)+1
6463           num_cont_hb(ii)=nnn
6464           jcont_hb(nnn,ii)=jj
6465           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6466           ind=3
6467           do kk=1,3
6468             ind=ind+1
6469             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6470           enddo
6471           do kk=1,2
6472             do ll=1,2
6473               ind=ind+1
6474               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6475             enddo
6476           enddo
6477           do jj=1,5
6478             do kk=1,3
6479               do ll=1,2
6480                 do mm=1,2
6481                   ind=ind+1
6482                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6483                 enddo
6484               enddo
6485             enddo
6486           enddo
6487         enddo
6488       enddo
6489       call flush(iout)
6490       if (lprn) then
6491         write (iout,'(a)') 'Contact function values after receive:'
6492         do i=nnt,nct-2
6493           write (iout,'(2i3,50(1x,i3,5f6.3))')
6494      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6495      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6496         enddo
6497         call flush(iout)
6498       endif
6499    30 continue
6500 #endif
6501       if (lprn) then
6502         write (iout,'(a)') 'Contact function values:'
6503         do i=nnt,nct-2
6504           write (iout,'(2i3,50(1x,i2,5f6.3))')
6505      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6506      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6507         enddo
6508       endif
6509       ecorr=0.0D0
6510       ecorr5=0.0d0
6511       ecorr6=0.0d0
6512 C Remove the loop below after debugging !!!
6513       do i=nnt,nct
6514         do j=1,3
6515           gradcorr(j,i)=0.0D0
6516           gradxorr(j,i)=0.0D0
6517         enddo
6518       enddo
6519 C Calculate the dipole-dipole interaction energies
6520       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6521       do i=iatel_s,iatel_e+1
6522         num_conti=num_cont_hb(i)
6523         do jj=1,num_conti
6524           j=jcont_hb(jj,i)
6525 #ifdef MOMENT
6526           call dipole(i,j,jj)
6527 #endif
6528         enddo
6529       enddo
6530       endif
6531 C Calculate the local-electrostatic correlation terms
6532 c                write (iout,*) "gradcorr5 in eello5 before loop"
6533 c                do iii=1,nres
6534 c                  write (iout,'(i5,3f10.5)')
6535 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6536 c                enddo
6537       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6538 c        write (iout,*) "corr loop i",i
6539         i1=i+1
6540         num_conti=num_cont_hb(i)
6541         num_conti1=num_cont_hb(i+1)
6542         do jj=1,num_conti
6543           j=jcont_hb(jj,i)
6544           jp=iabs(j)
6545           do kk=1,num_conti1
6546             j1=jcont_hb(kk,i1)
6547             jp1=iabs(j1)
6548 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6549 c     &         ' jj=',jj,' kk=',kk
6550 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6551             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6552      &          .or. j.lt.0 .and. j1.gt.0) .and.
6553      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6554 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6555 C The system gains extra energy.
6556               n_corr=n_corr+1
6557               sqd1=dsqrt(d_cont(jj,i))
6558               sqd2=dsqrt(d_cont(kk,i1))
6559               sred_geom = sqd1*sqd2
6560               IF (sred_geom.lt.cutoff_corr) THEN
6561                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6562      &            ekont,fprimcont)
6563 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6564 cd     &         ' jj=',jj,' kk=',kk
6565                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6566                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6567                 do l=1,3
6568                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6569                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6570                 enddo
6571                 n_corr1=n_corr1+1
6572 cd               write (iout,*) 'sred_geom=',sred_geom,
6573 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6574 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6575 cd               write (iout,*) "g_contij",g_contij
6576 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6577 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6578                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6579                 if (wcorr4.gt.0.0d0)
6580      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6581                   if (energy_dec.and.wcorr4.gt.0.0d0)
6582      1                 write (iout,'(a6,4i5,0pf7.3)')
6583      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6584 c                write (iout,*) "gradcorr5 before eello5"
6585 c                do iii=1,nres
6586 c                  write (iout,'(i5,3f10.5)')
6587 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6588 c                enddo
6589                 if (wcorr5.gt.0.0d0)
6590      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6591 c                write (iout,*) "gradcorr5 after eello5"
6592 c                do iii=1,nres
6593 c                  write (iout,'(i5,3f10.5)')
6594 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6595 c                enddo
6596                   if (energy_dec.and.wcorr5.gt.0.0d0)
6597      1                 write (iout,'(a6,4i5,0pf7.3)')
6598      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6599 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6600 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6601                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6602      &               .or. wturn6.eq.0.0d0))then
6603 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6604                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6605                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6606      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6607 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6608 cd     &            'ecorr6=',ecorr6
6609 cd                write (iout,'(4e15.5)') sred_geom,
6610 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6611 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6612 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6613                 else if (wturn6.gt.0.0d0
6614      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6615 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6616                   eturn6=eturn6+eello_turn6(i,jj,kk)
6617                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6618      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6619 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6620                 endif
6621               ENDIF
6622 1111          continue
6623             endif
6624           enddo ! kk
6625         enddo ! jj
6626       enddo ! i
6627       do i=1,nres
6628         num_cont_hb(i)=num_cont_hb_old(i)
6629       enddo
6630 c                write (iout,*) "gradcorr5 in eello5"
6631 c                do iii=1,nres
6632 c                  write (iout,'(i5,3f10.5)')
6633 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6634 c                enddo
6635       return
6636       end
6637 c------------------------------------------------------------------------------
6638       subroutine add_hb_contact_eello(ii,jj,itask)
6639       implicit real*8 (a-h,o-z)
6640       include "DIMENSIONS"
6641       include "COMMON.IOUNITS"
6642       integer max_cont
6643       integer max_dim
6644       parameter (max_cont=maxconts)
6645       parameter (max_dim=70)
6646       include "COMMON.CONTACTS"
6647       double precision zapas(max_dim,maxconts,max_fg_procs),
6648      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6649       common /przechowalnia/ zapas
6650       integer i,j,ii,jj,iproc,itask(4),nn
6651 c      write (iout,*) "itask",itask
6652       do i=1,2
6653         iproc=itask(i)
6654         if (iproc.gt.0) then
6655           do j=1,num_cont_hb(ii)
6656             jjc=jcont_hb(j,ii)
6657 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6658             if (jjc.eq.jj) then
6659               ncont_sent(iproc)=ncont_sent(iproc)+1
6660               nn=ncont_sent(iproc)
6661               zapas(1,nn,iproc)=ii
6662               zapas(2,nn,iproc)=jjc
6663               zapas(3,nn,iproc)=d_cont(j,ii)
6664               ind=3
6665               do kk=1,3
6666                 ind=ind+1
6667                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6668               enddo
6669               do kk=1,2
6670                 do ll=1,2
6671                   ind=ind+1
6672                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6673                 enddo
6674               enddo
6675               do jj=1,5
6676                 do kk=1,3
6677                   do ll=1,2
6678                     do mm=1,2
6679                       ind=ind+1
6680                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6681                     enddo
6682                   enddo
6683                 enddo
6684               enddo
6685               exit
6686             endif
6687           enddo
6688         endif
6689       enddo
6690       return
6691       end
6692 c------------------------------------------------------------------------------
6693       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6694       implicit real*8 (a-h,o-z)
6695       include 'DIMENSIONS'
6696       include 'COMMON.IOUNITS'
6697       include 'COMMON.DERIV'
6698       include 'COMMON.INTERACT'
6699       include 'COMMON.CONTACTS'
6700       double precision gx(3),gx1(3)
6701       logical lprn
6702       lprn=.false.
6703       eij=facont_hb(jj,i)
6704       ekl=facont_hb(kk,k)
6705       ees0pij=ees0p(jj,i)
6706       ees0pkl=ees0p(kk,k)
6707       ees0mij=ees0m(jj,i)
6708       ees0mkl=ees0m(kk,k)
6709       ekont=eij*ekl
6710       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6711 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6712 C Following 4 lines for diagnostics.
6713 cd    ees0pkl=0.0D0
6714 cd    ees0pij=1.0D0
6715 cd    ees0mkl=0.0D0
6716 cd    ees0mij=1.0D0
6717 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6718 c     & 'Contacts ',i,j,
6719 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6720 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6721 c     & 'gradcorr_long'
6722 C Calculate the multi-body contribution to energy.
6723 c      ecorr=ecorr+ekont*ees
6724 C Calculate multi-body contributions to the gradient.
6725       coeffpees0pij=coeffp*ees0pij
6726       coeffmees0mij=coeffm*ees0mij
6727       coeffpees0pkl=coeffp*ees0pkl
6728       coeffmees0mkl=coeffm*ees0mkl
6729       do ll=1,3
6730 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6731         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6732      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6733      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6734         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6735      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6736      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6737 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6738         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6739      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6740      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6741         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6742      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6743      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6744         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6745      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6746      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6747         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6748         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6749         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6750      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6751      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6752         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6753         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6754 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6755       enddo
6756 c      write (iout,*)
6757 cgrad      do m=i+1,j-1
6758 cgrad        do ll=1,3
6759 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6760 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6761 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6762 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6763 cgrad        enddo
6764 cgrad      enddo
6765 cgrad      do m=k+1,l-1
6766 cgrad        do ll=1,3
6767 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6768 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6769 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6770 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6771 cgrad        enddo
6772 cgrad      enddo
6773 c      write (iout,*) "ehbcorr",ekont*ees
6774       ehbcorr=ekont*ees
6775       return
6776       end
6777 #ifdef MOMENT
6778 C---------------------------------------------------------------------------
6779       subroutine dipole(i,j,jj)
6780       implicit real*8 (a-h,o-z)
6781       include 'DIMENSIONS'
6782       include 'COMMON.IOUNITS'
6783       include 'COMMON.CHAIN'
6784       include 'COMMON.FFIELD'
6785       include 'COMMON.DERIV'
6786       include 'COMMON.INTERACT'
6787       include 'COMMON.CONTACTS'
6788       include 'COMMON.TORSION'
6789       include 'COMMON.VAR'
6790       include 'COMMON.GEO'
6791       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6792      &  auxmat(2,2)
6793       iti1 = itortyp(itype(i+1))
6794       if (j.lt.nres-1) then
6795         itj1 = itortyp(itype(j+1))
6796       else
6797         itj1=ntortyp+1
6798       endif
6799       do iii=1,2
6800         dipi(iii,1)=Ub2(iii,i)
6801         dipderi(iii)=Ub2der(iii,i)
6802         dipi(iii,2)=b1(iii,iti1)
6803         dipj(iii,1)=Ub2(iii,j)
6804         dipderj(iii)=Ub2der(iii,j)
6805         dipj(iii,2)=b1(iii,itj1)
6806       enddo
6807       kkk=0
6808       do iii=1,2
6809         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6810         do jjj=1,2
6811           kkk=kkk+1
6812           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6813         enddo
6814       enddo
6815       do kkk=1,5
6816         do lll=1,3
6817           mmm=0
6818           do iii=1,2
6819             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6820      &        auxvec(1))
6821             do jjj=1,2
6822               mmm=mmm+1
6823               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6824             enddo
6825           enddo
6826         enddo
6827       enddo
6828       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6829       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6830       do iii=1,2
6831         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6832       enddo
6833       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6834       do iii=1,2
6835         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6836       enddo
6837       return
6838       end
6839 #endif
6840 C---------------------------------------------------------------------------
6841       subroutine calc_eello(i,j,k,l,jj,kk)
6842 C
6843 C This subroutine computes matrices and vectors needed to calculate
6844 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6845 C
6846       implicit real*8 (a-h,o-z)
6847       include 'DIMENSIONS'
6848       include 'COMMON.IOUNITS'
6849       include 'COMMON.CHAIN'
6850       include 'COMMON.DERIV'
6851       include 'COMMON.INTERACT'
6852       include 'COMMON.CONTACTS'
6853       include 'COMMON.TORSION'
6854       include 'COMMON.VAR'
6855       include 'COMMON.GEO'
6856       include 'COMMON.FFIELD'
6857       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6858      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6859       logical lprn
6860       common /kutas/ lprn
6861 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6862 cd     & ' jj=',jj,' kk=',kk
6863 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6864 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6865 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6866       do iii=1,2
6867         do jjj=1,2
6868           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6869           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6870         enddo
6871       enddo
6872       call transpose2(aa1(1,1),aa1t(1,1))
6873       call transpose2(aa2(1,1),aa2t(1,1))
6874       do kkk=1,5
6875         do lll=1,3
6876           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6877      &      aa1tder(1,1,lll,kkk))
6878           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6879      &      aa2tder(1,1,lll,kkk))
6880         enddo
6881       enddo
6882       if (l.eq.j+1) then
6883 C parallel orientation of the two CA-CA-CA frames.
6884         if (i.gt.1) then
6885           iti=itortyp(itype(i))
6886         else
6887           iti=ntortyp+1
6888         endif
6889         itk1=itortyp(itype(k+1))
6890         itj=itortyp(itype(j))
6891         if (l.lt.nres-1) then
6892           itl1=itortyp(itype(l+1))
6893         else
6894           itl1=ntortyp+1
6895         endif
6896 C A1 kernel(j+1) A2T
6897 cd        do iii=1,2
6898 cd          write (iout,'(3f10.5,5x,3f10.5)')
6899 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6900 cd        enddo
6901         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6902      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6903      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6904 C Following matrices are needed only for 6-th order cumulants
6905         IF (wcorr6.gt.0.0d0) THEN
6906         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6907      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6908      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6909         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6910      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6911      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6912      &   ADtEAderx(1,1,1,1,1,1))
6913         lprn=.false.
6914         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6915      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6916      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6917      &   ADtEA1derx(1,1,1,1,1,1))
6918         ENDIF
6919 C End 6-th order cumulants
6920 cd        lprn=.false.
6921 cd        if (lprn) then
6922 cd        write (2,*) 'In calc_eello6'
6923 cd        do iii=1,2
6924 cd          write (2,*) 'iii=',iii
6925 cd          do kkk=1,5
6926 cd            write (2,*) 'kkk=',kkk
6927 cd            do jjj=1,2
6928 cd              write (2,'(3(2f10.5),5x)')
6929 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6930 cd            enddo
6931 cd          enddo
6932 cd        enddo
6933 cd        endif
6934         call transpose2(EUgder(1,1,k),auxmat(1,1))
6935         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6936         call transpose2(EUg(1,1,k),auxmat(1,1))
6937         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6938         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6939         do iii=1,2
6940           do kkk=1,5
6941             do lll=1,3
6942               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6943      &          EAEAderx(1,1,lll,kkk,iii,1))
6944             enddo
6945           enddo
6946         enddo
6947 C A1T kernel(i+1) A2
6948         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6949      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6950      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6951 C Following matrices are needed only for 6-th order cumulants
6952         IF (wcorr6.gt.0.0d0) THEN
6953         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6954      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6955      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6956         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6957      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6958      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6959      &   ADtEAderx(1,1,1,1,1,2))
6960         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6961      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6962      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6963      &   ADtEA1derx(1,1,1,1,1,2))
6964         ENDIF
6965 C End 6-th order cumulants
6966         call transpose2(EUgder(1,1,l),auxmat(1,1))
6967         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6968         call transpose2(EUg(1,1,l),auxmat(1,1))
6969         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6970         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6971         do iii=1,2
6972           do kkk=1,5
6973             do lll=1,3
6974               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6975      &          EAEAderx(1,1,lll,kkk,iii,2))
6976             enddo
6977           enddo
6978         enddo
6979 C AEAb1 and AEAb2
6980 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6981 C They are needed only when the fifth- or the sixth-order cumulants are
6982 C indluded.
6983         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6984         call transpose2(AEA(1,1,1),auxmat(1,1))
6985         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6986         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6987         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6988         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6989         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6990         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6991         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6992         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6993         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6994         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6995         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6996         call transpose2(AEA(1,1,2),auxmat(1,1))
6997         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6998         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6999         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7000         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7001         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7002         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7003         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7004         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7005         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7006         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7007         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7008 C Calculate the Cartesian derivatives of the vectors.
7009         do iii=1,2
7010           do kkk=1,5
7011             do lll=1,3
7012               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7013               call matvec2(auxmat(1,1),b1(1,iti),
7014      &          AEAb1derx(1,lll,kkk,iii,1,1))
7015               call matvec2(auxmat(1,1),Ub2(1,i),
7016      &          AEAb2derx(1,lll,kkk,iii,1,1))
7017               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7018      &          AEAb1derx(1,lll,kkk,iii,2,1))
7019               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7020      &          AEAb2derx(1,lll,kkk,iii,2,1))
7021               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7022               call matvec2(auxmat(1,1),b1(1,itj),
7023      &          AEAb1derx(1,lll,kkk,iii,1,2))
7024               call matvec2(auxmat(1,1),Ub2(1,j),
7025      &          AEAb2derx(1,lll,kkk,iii,1,2))
7026               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7027      &          AEAb1derx(1,lll,kkk,iii,2,2))
7028               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7029      &          AEAb2derx(1,lll,kkk,iii,2,2))
7030             enddo
7031           enddo
7032         enddo
7033         ENDIF
7034 C End vectors
7035       else
7036 C Antiparallel orientation of the two CA-CA-CA frames.
7037         if (i.gt.1) then
7038           iti=itortyp(itype(i))
7039         else
7040           iti=ntortyp+1
7041         endif
7042         itk1=itortyp(itype(k+1))
7043         itl=itortyp(itype(l))
7044         itj=itortyp(itype(j))
7045         if (j.lt.nres-1) then
7046           itj1=itortyp(itype(j+1))
7047         else
7048           itj1=ntortyp+1
7049         endif
7050 C A2 kernel(j-1)T A1T
7051         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7052      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7053      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7054 C Following matrices are needed only for 6-th order cumulants
7055         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7056      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7057         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7058      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7059      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7060         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7061      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7062      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7063      &   ADtEAderx(1,1,1,1,1,1))
7064         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7065      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7066      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7067      &   ADtEA1derx(1,1,1,1,1,1))
7068         ENDIF
7069 C End 6-th order cumulants
7070         call transpose2(EUgder(1,1,k),auxmat(1,1))
7071         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7072         call transpose2(EUg(1,1,k),auxmat(1,1))
7073         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7074         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7075         do iii=1,2
7076           do kkk=1,5
7077             do lll=1,3
7078               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7079      &          EAEAderx(1,1,lll,kkk,iii,1))
7080             enddo
7081           enddo
7082         enddo
7083 C A2T kernel(i+1)T A1
7084         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7085      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7086      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7087 C Following matrices are needed only for 6-th order cumulants
7088         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7089      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7090         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7091      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7092      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7093         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7094      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7095      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7096      &   ADtEAderx(1,1,1,1,1,2))
7097         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7098      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7099      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7100      &   ADtEA1derx(1,1,1,1,1,2))
7101         ENDIF
7102 C End 6-th order cumulants
7103         call transpose2(EUgder(1,1,j),auxmat(1,1))
7104         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7105         call transpose2(EUg(1,1,j),auxmat(1,1))
7106         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7107         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7108         do iii=1,2
7109           do kkk=1,5
7110             do lll=1,3
7111               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7112      &          EAEAderx(1,1,lll,kkk,iii,2))
7113             enddo
7114           enddo
7115         enddo
7116 C AEAb1 and AEAb2
7117 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7118 C They are needed only when the fifth- or the sixth-order cumulants are
7119 C indluded.
7120         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7121      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7122         call transpose2(AEA(1,1,1),auxmat(1,1))
7123         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7124         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7125         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7126         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7127         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7128         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7129         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7130         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7131         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7132         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7133         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7134         call transpose2(AEA(1,1,2),auxmat(1,1))
7135         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7136         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7137         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7138         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7139         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7140         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7141         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7142         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7143         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7144         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7145         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7146 C Calculate the Cartesian derivatives of the vectors.
7147         do iii=1,2
7148           do kkk=1,5
7149             do lll=1,3
7150               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7151               call matvec2(auxmat(1,1),b1(1,iti),
7152      &          AEAb1derx(1,lll,kkk,iii,1,1))
7153               call matvec2(auxmat(1,1),Ub2(1,i),
7154      &          AEAb2derx(1,lll,kkk,iii,1,1))
7155               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7156      &          AEAb1derx(1,lll,kkk,iii,2,1))
7157               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7158      &          AEAb2derx(1,lll,kkk,iii,2,1))
7159               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7160               call matvec2(auxmat(1,1),b1(1,itl),
7161      &          AEAb1derx(1,lll,kkk,iii,1,2))
7162               call matvec2(auxmat(1,1),Ub2(1,l),
7163      &          AEAb2derx(1,lll,kkk,iii,1,2))
7164               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7165      &          AEAb1derx(1,lll,kkk,iii,2,2))
7166               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7167      &          AEAb2derx(1,lll,kkk,iii,2,2))
7168             enddo
7169           enddo
7170         enddo
7171         ENDIF
7172 C End vectors
7173       endif
7174       return
7175       end
7176 C---------------------------------------------------------------------------
7177       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7178      &  KK,KKderg,AKA,AKAderg,AKAderx)
7179       implicit none
7180       integer nderg
7181       logical transp
7182       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7183      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7184      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7185       integer iii,kkk,lll
7186       integer jjj,mmm
7187       logical lprn
7188       common /kutas/ lprn
7189       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7190       do iii=1,nderg
7191         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7192      &    AKAderg(1,1,iii))
7193       enddo
7194 cd      if (lprn) write (2,*) 'In kernel'
7195       do kkk=1,5
7196 cd        if (lprn) write (2,*) 'kkk=',kkk
7197         do lll=1,3
7198           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7199      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7200 cd          if (lprn) then
7201 cd            write (2,*) 'lll=',lll
7202 cd            write (2,*) 'iii=1'
7203 cd            do jjj=1,2
7204 cd              write (2,'(3(2f10.5),5x)')
7205 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7206 cd            enddo
7207 cd          endif
7208           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7209      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7210 cd          if (lprn) then
7211 cd            write (2,*) 'lll=',lll
7212 cd            write (2,*) 'iii=2'
7213 cd            do jjj=1,2
7214 cd              write (2,'(3(2f10.5),5x)')
7215 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7216 cd            enddo
7217 cd          endif
7218         enddo
7219       enddo
7220       return
7221       end
7222 C---------------------------------------------------------------------------
7223       double precision function eello4(i,j,k,l,jj,kk)
7224       implicit real*8 (a-h,o-z)
7225       include 'DIMENSIONS'
7226       include 'COMMON.IOUNITS'
7227       include 'COMMON.CHAIN'
7228       include 'COMMON.DERIV'
7229       include 'COMMON.INTERACT'
7230       include 'COMMON.CONTACTS'
7231       include 'COMMON.TORSION'
7232       include 'COMMON.VAR'
7233       include 'COMMON.GEO'
7234       double precision pizda(2,2),ggg1(3),ggg2(3)
7235 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7236 cd        eello4=0.0d0
7237 cd        return
7238 cd      endif
7239 cd      print *,'eello4:',i,j,k,l,jj,kk
7240 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7241 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7242 cold      eij=facont_hb(jj,i)
7243 cold      ekl=facont_hb(kk,k)
7244 cold      ekont=eij*ekl
7245       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7246 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7247       gcorr_loc(k-1)=gcorr_loc(k-1)
7248      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7249       if (l.eq.j+1) then
7250         gcorr_loc(l-1)=gcorr_loc(l-1)
7251      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7252       else
7253         gcorr_loc(j-1)=gcorr_loc(j-1)
7254      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7255       endif
7256       do iii=1,2
7257         do kkk=1,5
7258           do lll=1,3
7259             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7260      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7261 cd            derx(lll,kkk,iii)=0.0d0
7262           enddo
7263         enddo
7264       enddo
7265 cd      gcorr_loc(l-1)=0.0d0
7266 cd      gcorr_loc(j-1)=0.0d0
7267 cd      gcorr_loc(k-1)=0.0d0
7268 cd      eel4=1.0d0
7269 cd      write (iout,*)'Contacts have occurred for peptide groups',
7270 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7271 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7272       if (j.lt.nres-1) then
7273         j1=j+1
7274         j2=j-1
7275       else
7276         j1=j-1
7277         j2=j-2
7278       endif
7279       if (l.lt.nres-1) then
7280         l1=l+1
7281         l2=l-1
7282       else
7283         l1=l-1
7284         l2=l-2
7285       endif
7286       do ll=1,3
7287 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7288 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7289         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7290         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7291 cgrad        ghalf=0.5d0*ggg1(ll)
7292         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7293         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7294         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7295         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7296         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7297         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7298 cgrad        ghalf=0.5d0*ggg2(ll)
7299         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7300         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7301         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7302         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7303         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7304         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7305       enddo
7306 cgrad      do m=i+1,j-1
7307 cgrad        do ll=1,3
7308 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7309 cgrad        enddo
7310 cgrad      enddo
7311 cgrad      do m=k+1,l-1
7312 cgrad        do ll=1,3
7313 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7314 cgrad        enddo
7315 cgrad      enddo
7316 cgrad      do m=i+2,j2
7317 cgrad        do ll=1,3
7318 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7319 cgrad        enddo
7320 cgrad      enddo
7321 cgrad      do m=k+2,l2
7322 cgrad        do ll=1,3
7323 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7324 cgrad        enddo
7325 cgrad      enddo
7326 cd      do iii=1,nres-3
7327 cd        write (2,*) iii,gcorr_loc(iii)
7328 cd      enddo
7329       eello4=ekont*eel4
7330 cd      write (2,*) 'ekont',ekont
7331 cd      write (iout,*) 'eello4',ekont*eel4
7332       return
7333       end
7334 C---------------------------------------------------------------------------
7335       double precision function eello5(i,j,k,l,jj,kk)
7336       implicit real*8 (a-h,o-z)
7337       include 'DIMENSIONS'
7338       include 'COMMON.IOUNITS'
7339       include 'COMMON.CHAIN'
7340       include 'COMMON.DERIV'
7341       include 'COMMON.INTERACT'
7342       include 'COMMON.CONTACTS'
7343       include 'COMMON.TORSION'
7344       include 'COMMON.VAR'
7345       include 'COMMON.GEO'
7346       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7347       double precision ggg1(3),ggg2(3)
7348 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7349 C                                                                              C
7350 C                            Parallel chains                                   C
7351 C                                                                              C
7352 C          o             o                   o             o                   C
7353 C         /l\           / \             \   / \           / \   /              C
7354 C        /   \         /   \             \ /   \         /   \ /               C
7355 C       j| o |l1       | o |              o| o |         | o |o                C
7356 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7357 C      \i/   \         /   \ /             /   \         /   \                 C
7358 C       o    k1             o                                                  C
7359 C         (I)          (II)                (III)          (IV)                 C
7360 C                                                                              C
7361 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7362 C                                                                              C
7363 C                            Antiparallel chains                               C
7364 C                                                                              C
7365 C          o             o                   o             o                   C
7366 C         /j\           / \             \   / \           / \   /              C
7367 C        /   \         /   \             \ /   \         /   \ /               C
7368 C      j1| o |l        | o |              o| o |         | o |o                C
7369 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7370 C      \i/   \         /   \ /             /   \         /   \                 C
7371 C       o     k1            o                                                  C
7372 C         (I)          (II)                (III)          (IV)                 C
7373 C                                                                              C
7374 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7375 C                                                                              C
7376 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7377 C                                                                              C
7378 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7379 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7380 cd        eello5=0.0d0
7381 cd        return
7382 cd      endif
7383 cd      write (iout,*)
7384 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7385 cd     &   ' and',k,l
7386       itk=itortyp(itype(k))
7387       itl=itortyp(itype(l))
7388       itj=itortyp(itype(j))
7389       eello5_1=0.0d0
7390       eello5_2=0.0d0
7391       eello5_3=0.0d0
7392       eello5_4=0.0d0
7393 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7394 cd     &   eel5_3_num,eel5_4_num)
7395       do iii=1,2
7396         do kkk=1,5
7397           do lll=1,3
7398             derx(lll,kkk,iii)=0.0d0
7399           enddo
7400         enddo
7401       enddo
7402 cd      eij=facont_hb(jj,i)
7403 cd      ekl=facont_hb(kk,k)
7404 cd      ekont=eij*ekl
7405 cd      write (iout,*)'Contacts have occurred for peptide groups',
7406 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7407 cd      goto 1111
7408 C Contribution from the graph I.
7409 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7410 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7411       call transpose2(EUg(1,1,k),auxmat(1,1))
7412       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7413       vv(1)=pizda(1,1)-pizda(2,2)
7414       vv(2)=pizda(1,2)+pizda(2,1)
7415       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7416      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7417 C Explicit gradient in virtual-dihedral angles.
7418       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7419      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7420      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7421       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7422       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7423       vv(1)=pizda(1,1)-pizda(2,2)
7424       vv(2)=pizda(1,2)+pizda(2,1)
7425       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7426      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7427      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7428       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7429       vv(1)=pizda(1,1)-pizda(2,2)
7430       vv(2)=pizda(1,2)+pizda(2,1)
7431       if (l.eq.j+1) then
7432         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7433      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7434      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7435       else
7436         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7437      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7438      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7439       endif
7440 C Cartesian gradient
7441       do iii=1,2
7442         do kkk=1,5
7443           do lll=1,3
7444             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7445      &        pizda(1,1))
7446             vv(1)=pizda(1,1)-pizda(2,2)
7447             vv(2)=pizda(1,2)+pizda(2,1)
7448             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7449      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7450      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7451           enddo
7452         enddo
7453       enddo
7454 c      goto 1112
7455 c1111  continue
7456 C Contribution from graph II
7457       call transpose2(EE(1,1,itk),auxmat(1,1))
7458       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7459       vv(1)=pizda(1,1)+pizda(2,2)
7460       vv(2)=pizda(2,1)-pizda(1,2)
7461       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7462      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7463 C Explicit gradient in virtual-dihedral angles.
7464       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7465      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7466       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7467       vv(1)=pizda(1,1)+pizda(2,2)
7468       vv(2)=pizda(2,1)-pizda(1,2)
7469       if (l.eq.j+1) then
7470         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7471      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7472      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7473       else
7474         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7475      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7476      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7477       endif
7478 C Cartesian gradient
7479       do iii=1,2
7480         do kkk=1,5
7481           do lll=1,3
7482             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7483      &        pizda(1,1))
7484             vv(1)=pizda(1,1)+pizda(2,2)
7485             vv(2)=pizda(2,1)-pizda(1,2)
7486             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7487      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7488      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7489           enddo
7490         enddo
7491       enddo
7492 cd      goto 1112
7493 cd1111  continue
7494       if (l.eq.j+1) then
7495 cd        goto 1110
7496 C Parallel orientation
7497 C Contribution from graph III
7498         call transpose2(EUg(1,1,l),auxmat(1,1))
7499         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7500         vv(1)=pizda(1,1)-pizda(2,2)
7501         vv(2)=pizda(1,2)+pizda(2,1)
7502         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7503      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7504 C Explicit gradient in virtual-dihedral angles.
7505         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7506      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7507      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7508         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7509         vv(1)=pizda(1,1)-pizda(2,2)
7510         vv(2)=pizda(1,2)+pizda(2,1)
7511         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7512      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7513      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7514         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7515         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7516         vv(1)=pizda(1,1)-pizda(2,2)
7517         vv(2)=pizda(1,2)+pizda(2,1)
7518         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7519      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7520      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7521 C Cartesian gradient
7522         do iii=1,2
7523           do kkk=1,5
7524             do lll=1,3
7525               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7526      &          pizda(1,1))
7527               vv(1)=pizda(1,1)-pizda(2,2)
7528               vv(2)=pizda(1,2)+pizda(2,1)
7529               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7530      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7531      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7532             enddo
7533           enddo
7534         enddo
7535 cd        goto 1112
7536 C Contribution from graph IV
7537 cd1110    continue
7538         call transpose2(EE(1,1,itl),auxmat(1,1))
7539         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7540         vv(1)=pizda(1,1)+pizda(2,2)
7541         vv(2)=pizda(2,1)-pizda(1,2)
7542         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7543      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7544 C Explicit gradient in virtual-dihedral angles.
7545         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7546      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7547         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7548         vv(1)=pizda(1,1)+pizda(2,2)
7549         vv(2)=pizda(2,1)-pizda(1,2)
7550         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7551      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7552      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7553 C Cartesian gradient
7554         do iii=1,2
7555           do kkk=1,5
7556             do lll=1,3
7557               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7558      &          pizda(1,1))
7559               vv(1)=pizda(1,1)+pizda(2,2)
7560               vv(2)=pizda(2,1)-pizda(1,2)
7561               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7562      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7563      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7564             enddo
7565           enddo
7566         enddo
7567       else
7568 C Antiparallel orientation
7569 C Contribution from graph III
7570 c        goto 1110
7571         call transpose2(EUg(1,1,j),auxmat(1,1))
7572         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7573         vv(1)=pizda(1,1)-pizda(2,2)
7574         vv(2)=pizda(1,2)+pizda(2,1)
7575         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7576      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7577 C Explicit gradient in virtual-dihedral angles.
7578         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7579      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7580      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7581         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7582         vv(1)=pizda(1,1)-pizda(2,2)
7583         vv(2)=pizda(1,2)+pizda(2,1)
7584         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7585      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7586      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7587         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7588         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7589         vv(1)=pizda(1,1)-pizda(2,2)
7590         vv(2)=pizda(1,2)+pizda(2,1)
7591         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7592      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7593      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7594 C Cartesian gradient
7595         do iii=1,2
7596           do kkk=1,5
7597             do lll=1,3
7598               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7599      &          pizda(1,1))
7600               vv(1)=pizda(1,1)-pizda(2,2)
7601               vv(2)=pizda(1,2)+pizda(2,1)
7602               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7603      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7604      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7605             enddo
7606           enddo
7607         enddo
7608 cd        goto 1112
7609 C Contribution from graph IV
7610 1110    continue
7611         call transpose2(EE(1,1,itj),auxmat(1,1))
7612         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7613         vv(1)=pizda(1,1)+pizda(2,2)
7614         vv(2)=pizda(2,1)-pizda(1,2)
7615         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7616      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7617 C Explicit gradient in virtual-dihedral angles.
7618         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7619      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7620         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7621         vv(1)=pizda(1,1)+pizda(2,2)
7622         vv(2)=pizda(2,1)-pizda(1,2)
7623         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7624      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7625      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7626 C Cartesian gradient
7627         do iii=1,2
7628           do kkk=1,5
7629             do lll=1,3
7630               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7631      &          pizda(1,1))
7632               vv(1)=pizda(1,1)+pizda(2,2)
7633               vv(2)=pizda(2,1)-pizda(1,2)
7634               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7635      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7636      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7637             enddo
7638           enddo
7639         enddo
7640       endif
7641 1112  continue
7642       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7643 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7644 cd        write (2,*) 'ijkl',i,j,k,l
7645 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7646 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7647 cd      endif
7648 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7649 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7650 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7651 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7652       if (j.lt.nres-1) then
7653         j1=j+1
7654         j2=j-1
7655       else
7656         j1=j-1
7657         j2=j-2
7658       endif
7659       if (l.lt.nres-1) then
7660         l1=l+1
7661         l2=l-1
7662       else
7663         l1=l-1
7664         l2=l-2
7665       endif
7666 cd      eij=1.0d0
7667 cd      ekl=1.0d0
7668 cd      ekont=1.0d0
7669 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7670 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7671 C        summed up outside the subrouine as for the other subroutines
7672 C        handling long-range interactions. The old code is commented out
7673 C        with "cgrad" to keep track of changes.
7674       do ll=1,3
7675 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7676 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7677         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7678         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7679 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7680 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7681 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7682 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7683 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7684 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7685 c     &   gradcorr5ij,
7686 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7687 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7688 cgrad        ghalf=0.5d0*ggg1(ll)
7689 cd        ghalf=0.0d0
7690         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7691         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7692         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7693         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7694         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7695         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7696 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7697 cgrad        ghalf=0.5d0*ggg2(ll)
7698 cd        ghalf=0.0d0
7699         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7700         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7701         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7702         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7703         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7704         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7705       enddo
7706 cd      goto 1112
7707 cgrad      do m=i+1,j-1
7708 cgrad        do ll=1,3
7709 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7710 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7711 cgrad        enddo
7712 cgrad      enddo
7713 cgrad      do m=k+1,l-1
7714 cgrad        do ll=1,3
7715 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7716 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7717 cgrad        enddo
7718 cgrad      enddo
7719 c1112  continue
7720 cgrad      do m=i+2,j2
7721 cgrad        do ll=1,3
7722 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7723 cgrad        enddo
7724 cgrad      enddo
7725 cgrad      do m=k+2,l2
7726 cgrad        do ll=1,3
7727 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7728 cgrad        enddo
7729 cgrad      enddo
7730 cd      do iii=1,nres-3
7731 cd        write (2,*) iii,g_corr5_loc(iii)
7732 cd      enddo
7733       eello5=ekont*eel5
7734 cd      write (2,*) 'ekont',ekont
7735 cd      write (iout,*) 'eello5',ekont*eel5
7736       return
7737       end
7738 c--------------------------------------------------------------------------
7739       double precision function eello6(i,j,k,l,jj,kk)
7740       implicit real*8 (a-h,o-z)
7741       include 'DIMENSIONS'
7742       include 'COMMON.IOUNITS'
7743       include 'COMMON.CHAIN'
7744       include 'COMMON.DERIV'
7745       include 'COMMON.INTERACT'
7746       include 'COMMON.CONTACTS'
7747       include 'COMMON.TORSION'
7748       include 'COMMON.VAR'
7749       include 'COMMON.GEO'
7750       include 'COMMON.FFIELD'
7751       double precision ggg1(3),ggg2(3)
7752 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7753 cd        eello6=0.0d0
7754 cd        return
7755 cd      endif
7756 cd      write (iout,*)
7757 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7758 cd     &   ' and',k,l
7759       eello6_1=0.0d0
7760       eello6_2=0.0d0
7761       eello6_3=0.0d0
7762       eello6_4=0.0d0
7763       eello6_5=0.0d0
7764       eello6_6=0.0d0
7765 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7766 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7767       do iii=1,2
7768         do kkk=1,5
7769           do lll=1,3
7770             derx(lll,kkk,iii)=0.0d0
7771           enddo
7772         enddo
7773       enddo
7774 cd      eij=facont_hb(jj,i)
7775 cd      ekl=facont_hb(kk,k)
7776 cd      ekont=eij*ekl
7777 cd      eij=1.0d0
7778 cd      ekl=1.0d0
7779 cd      ekont=1.0d0
7780       if (l.eq.j+1) then
7781         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7782         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7783         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7784         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7785         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7786         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7787       else
7788         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7789         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7790         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7791         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7792         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7793           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7794         else
7795           eello6_5=0.0d0
7796         endif
7797         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7798       endif
7799 C If turn contributions are considered, they will be handled separately.
7800       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7801 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7802 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7803 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7804 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7805 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7806 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7807 cd      goto 1112
7808       if (j.lt.nres-1) then
7809         j1=j+1
7810         j2=j-1
7811       else
7812         j1=j-1
7813         j2=j-2
7814       endif
7815       if (l.lt.nres-1) then
7816         l1=l+1
7817         l2=l-1
7818       else
7819         l1=l-1
7820         l2=l-2
7821       endif
7822       do ll=1,3
7823 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7824 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7825 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7826 cgrad        ghalf=0.5d0*ggg1(ll)
7827 cd        ghalf=0.0d0
7828         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7829         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7830         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7831         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7832         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7833         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7834         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7835         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7836 cgrad        ghalf=0.5d0*ggg2(ll)
7837 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7838 cd        ghalf=0.0d0
7839         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7840         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7841         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7842         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7843         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7844         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7845       enddo
7846 cd      goto 1112
7847 cgrad      do m=i+1,j-1
7848 cgrad        do ll=1,3
7849 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7850 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7851 cgrad        enddo
7852 cgrad      enddo
7853 cgrad      do m=k+1,l-1
7854 cgrad        do ll=1,3
7855 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7856 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7857 cgrad        enddo
7858 cgrad      enddo
7859 cgrad1112  continue
7860 cgrad      do m=i+2,j2
7861 cgrad        do ll=1,3
7862 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7863 cgrad        enddo
7864 cgrad      enddo
7865 cgrad      do m=k+2,l2
7866 cgrad        do ll=1,3
7867 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7868 cgrad        enddo
7869 cgrad      enddo
7870 cd      do iii=1,nres-3
7871 cd        write (2,*) iii,g_corr6_loc(iii)
7872 cd      enddo
7873       eello6=ekont*eel6
7874 cd      write (2,*) 'ekont',ekont
7875 cd      write (iout,*) 'eello6',ekont*eel6
7876       return
7877       end
7878 c--------------------------------------------------------------------------
7879       double precision function eello6_graph1(i,j,k,l,imat,swap)
7880       implicit real*8 (a-h,o-z)
7881       include 'DIMENSIONS'
7882       include 'COMMON.IOUNITS'
7883       include 'COMMON.CHAIN'
7884       include 'COMMON.DERIV'
7885       include 'COMMON.INTERACT'
7886       include 'COMMON.CONTACTS'
7887       include 'COMMON.TORSION'
7888       include 'COMMON.VAR'
7889       include 'COMMON.GEO'
7890       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7891       logical swap
7892       logical lprn
7893       common /kutas/ lprn
7894 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7895 C                                                                              C
7896 C      Parallel       Antiparallel                                             C
7897 C                                                                              C
7898 C          o             o                                                     C
7899 C         /l\           /j\                                                    C
7900 C        /   \         /   \                                                   C
7901 C       /| o |         | o |\                                                  C
7902 C     \ j|/k\|  /   \  |/k\|l /                                                C
7903 C      \ /   \ /     \ /   \ /                                                 C
7904 C       o     o       o     o                                                  C
7905 C       i             i                                                        C
7906 C                                                                              C
7907 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7908       itk=itortyp(itype(k))
7909       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7910       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7911       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7912       call transpose2(EUgC(1,1,k),auxmat(1,1))
7913       call matmat2(AEA(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       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7917       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7918       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7919       s5=scalar2(vv(1),Dtobr2(1,i))
7920 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7921       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7922       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7923      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7924      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7925      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7926      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7927      & +scalar2(vv(1),Dtobr2der(1,i)))
7928       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7929       vv1(1)=pizda1(1,1)-pizda1(2,2)
7930       vv1(2)=pizda1(1,2)+pizda1(2,1)
7931       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7932       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7933       if (l.eq.j+1) then
7934         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7935      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7936      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7937      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7938      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7939       else
7940         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7941      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7942      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7943      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7944      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7945       endif
7946       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7947       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7948       vv1(1)=pizda1(1,1)-pizda1(2,2)
7949       vv1(2)=pizda1(1,2)+pizda1(2,1)
7950       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7951      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7952      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7953      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7954       do iii=1,2
7955         if (swap) then
7956           ind=3-iii
7957         else
7958           ind=iii
7959         endif
7960         do kkk=1,5
7961           do lll=1,3
7962             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7963             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7964             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7965             call transpose2(EUgC(1,1,k),auxmat(1,1))
7966             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7967      &        pizda1(1,1))
7968             vv1(1)=pizda1(1,1)-pizda1(2,2)
7969             vv1(2)=pizda1(1,2)+pizda1(2,1)
7970             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7971             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7972      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7973             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7974      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7975             s5=scalar2(vv(1),Dtobr2(1,i))
7976             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7977           enddo
7978         enddo
7979       enddo
7980       return
7981       end
7982 c----------------------------------------------------------------------------
7983       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7984       implicit real*8 (a-h,o-z)
7985       include 'DIMENSIONS'
7986       include 'COMMON.IOUNITS'
7987       include 'COMMON.CHAIN'
7988       include 'COMMON.DERIV'
7989       include 'COMMON.INTERACT'
7990       include 'COMMON.CONTACTS'
7991       include 'COMMON.TORSION'
7992       include 'COMMON.VAR'
7993       include 'COMMON.GEO'
7994       logical swap
7995       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7996      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7997       logical lprn
7998       common /kutas/ lprn
7999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8000 C                                                                              C
8001 C      Parallel       Antiparallel                                             C
8002 C                                                                              C
8003 C          o             o                                                     C
8004 C     \   /l\           /j\   /                                                C
8005 C      \ /   \         /   \ /                                                 C
8006 C       o| o |         | o |o                                                  C
8007 C     \ j|/k\|      \  |/k\|l                                                  C
8008 C      \ /   \       \ /   \                                                   C
8009 C       o             o                                                        C
8010 C       i             i                                                        C
8011 C                                                                              C
8012 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8013 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8014 C AL 7/4/01 s1 would occur in the sixth-order moment,
8015 C           but not in a cluster cumulant
8016 #ifdef MOMENT
8017       s1=dip(1,jj,i)*dip(1,kk,k)
8018 #endif
8019       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8020       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8021       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8022       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8023       call transpose2(EUg(1,1,k),auxmat(1,1))
8024       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8025       vv(1)=pizda(1,1)-pizda(2,2)
8026       vv(2)=pizda(1,2)+pizda(2,1)
8027       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8028 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8029 #ifdef MOMENT
8030       eello6_graph2=-(s1+s2+s3+s4)
8031 #else
8032       eello6_graph2=-(s2+s3+s4)
8033 #endif
8034 c      eello6_graph2=-s3
8035 C Derivatives in gamma(i-1)
8036       if (i.gt.1) then
8037 #ifdef MOMENT
8038         s1=dipderg(1,jj,i)*dip(1,kk,k)
8039 #endif
8040         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8041         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8042         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8043         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8044 #ifdef MOMENT
8045         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8046 #else
8047         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8048 #endif
8049 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8050       endif
8051 C Derivatives in gamma(k-1)
8052 #ifdef MOMENT
8053       s1=dip(1,jj,i)*dipderg(1,kk,k)
8054 #endif
8055       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8056       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8057       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8058       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8059       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8060       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8061       vv(1)=pizda(1,1)-pizda(2,2)
8062       vv(2)=pizda(1,2)+pizda(2,1)
8063       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8064 #ifdef MOMENT
8065       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8066 #else
8067       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8068 #endif
8069 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8070 C Derivatives in gamma(j-1) or gamma(l-1)
8071       if (j.gt.1) then
8072 #ifdef MOMENT
8073         s1=dipderg(3,jj,i)*dip(1,kk,k)
8074 #endif
8075         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8076         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8077         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8078         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8079         vv(1)=pizda(1,1)-pizda(2,2)
8080         vv(2)=pizda(1,2)+pizda(2,1)
8081         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8082 #ifdef MOMENT
8083         if (swap) then
8084           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8085         else
8086           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8087         endif
8088 #endif
8089         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8090 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8091       endif
8092 C Derivatives in gamma(l-1) or gamma(j-1)
8093       if (l.gt.1) then
8094 #ifdef MOMENT
8095         s1=dip(1,jj,i)*dipderg(3,kk,k)
8096 #endif
8097         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8098         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8099         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8100         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8101         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8102         vv(1)=pizda(1,1)-pizda(2,2)
8103         vv(2)=pizda(1,2)+pizda(2,1)
8104         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8105 #ifdef MOMENT
8106         if (swap) then
8107           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8108         else
8109           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8110         endif
8111 #endif
8112         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8113 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8114       endif
8115 C Cartesian derivatives.
8116       if (lprn) then
8117         write (2,*) 'In eello6_graph2'
8118         do iii=1,2
8119           write (2,*) 'iii=',iii
8120           do kkk=1,5
8121             write (2,*) 'kkk=',kkk
8122             do jjj=1,2
8123               write (2,'(3(2f10.5),5x)')
8124      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8125             enddo
8126           enddo
8127         enddo
8128       endif
8129       do iii=1,2
8130         do kkk=1,5
8131           do lll=1,3
8132 #ifdef MOMENT
8133             if (iii.eq.1) then
8134               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8135             else
8136               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8137             endif
8138 #endif
8139             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8140      &        auxvec(1))
8141             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8142             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8143      &        auxvec(1))
8144             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8145             call transpose2(EUg(1,1,k),auxmat(1,1))
8146             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8147      &        pizda(1,1))
8148             vv(1)=pizda(1,1)-pizda(2,2)
8149             vv(2)=pizda(1,2)+pizda(2,1)
8150             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8151 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8152 #ifdef MOMENT
8153             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8154 #else
8155             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8156 #endif
8157             if (swap) then
8158               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8159             else
8160               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8161             endif
8162           enddo
8163         enddo
8164       enddo
8165       return
8166       end
8167 c----------------------------------------------------------------------------
8168       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8169       implicit real*8 (a-h,o-z)
8170       include 'DIMENSIONS'
8171       include 'COMMON.IOUNITS'
8172       include 'COMMON.CHAIN'
8173       include 'COMMON.DERIV'
8174       include 'COMMON.INTERACT'
8175       include 'COMMON.CONTACTS'
8176       include 'COMMON.TORSION'
8177       include 'COMMON.VAR'
8178       include 'COMMON.GEO'
8179       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8180       logical swap
8181 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8182 C                                                                              C
8183 C      Parallel       Antiparallel                                             C
8184 C                                                                              C
8185 C          o             o                                                     C
8186 C         /l\   /   \   /j\                                                    C
8187 C        /   \ /     \ /   \                                                   C
8188 C       /| o |o       o| o |\                                                  C
8189 C       j|/k\|  /      |/k\|l /                                                C
8190 C        /   \ /       /   \ /                                                 C
8191 C       /     o       /     o                                                  C
8192 C       i             i                                                        C
8193 C                                                                              C
8194 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8195 C
8196 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8197 C           energy moment and not to the cluster cumulant.
8198       iti=itortyp(itype(i))
8199       if (j.lt.nres-1) then
8200         itj1=itortyp(itype(j+1))
8201       else
8202         itj1=ntortyp+1
8203       endif
8204       itk=itortyp(itype(k))
8205       itk1=itortyp(itype(k+1))
8206       if (l.lt.nres-1) then
8207         itl1=itortyp(itype(l+1))
8208       else
8209         itl1=ntortyp+1
8210       endif
8211 #ifdef MOMENT
8212       s1=dip(4,jj,i)*dip(4,kk,k)
8213 #endif
8214       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8215       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8216       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8217       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8218       call transpose2(EE(1,1,itk),auxmat(1,1))
8219       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8220       vv(1)=pizda(1,1)+pizda(2,2)
8221       vv(2)=pizda(2,1)-pizda(1,2)
8222       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8223 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8224 cd     & "sum",-(s2+s3+s4)
8225 #ifdef MOMENT
8226       eello6_graph3=-(s1+s2+s3+s4)
8227 #else
8228       eello6_graph3=-(s2+s3+s4)
8229 #endif
8230 c      eello6_graph3=-s4
8231 C Derivatives in gamma(k-1)
8232       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8233       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8234       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8235       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8236 C Derivatives in gamma(l-1)
8237       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8238       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8239       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8240       vv(1)=pizda(1,1)+pizda(2,2)
8241       vv(2)=pizda(2,1)-pizda(1,2)
8242       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8243       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8244 C Cartesian derivatives.
8245       do iii=1,2
8246         do kkk=1,5
8247           do lll=1,3
8248 #ifdef MOMENT
8249             if (iii.eq.1) then
8250               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8251             else
8252               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8253             endif
8254 #endif
8255             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8256      &        auxvec(1))
8257             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8258             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8259      &        auxvec(1))
8260             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8261             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8262      &        pizda(1,1))
8263             vv(1)=pizda(1,1)+pizda(2,2)
8264             vv(2)=pizda(2,1)-pizda(1,2)
8265             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8266 #ifdef MOMENT
8267             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8268 #else
8269             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8270 #endif
8271             if (swap) then
8272               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8273             else
8274               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8275             endif
8276 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8277           enddo
8278         enddo
8279       enddo
8280       return
8281       end
8282 c----------------------------------------------------------------------------
8283       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8284       implicit real*8 (a-h,o-z)
8285       include 'DIMENSIONS'
8286       include 'COMMON.IOUNITS'
8287       include 'COMMON.CHAIN'
8288       include 'COMMON.DERIV'
8289       include 'COMMON.INTERACT'
8290       include 'COMMON.CONTACTS'
8291       include 'COMMON.TORSION'
8292       include 'COMMON.VAR'
8293       include 'COMMON.GEO'
8294       include 'COMMON.FFIELD'
8295       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8296      & auxvec1(2),auxmat1(2,2)
8297       logical swap
8298 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8299 C                                                                              C
8300 C      Parallel       Antiparallel                                             C
8301 C                                                                              C
8302 C          o             o                                                     C
8303 C         /l\   /   \   /j\                                                    C
8304 C        /   \ /     \ /   \                                                   C
8305 C       /| o |o       o| o |\                                                  C
8306 C     \ j|/k\|      \  |/k\|l                                                  C
8307 C      \ /   \       \ /   \                                                   C
8308 C       o     \       o     \                                                  C
8309 C       i             i                                                        C
8310 C                                                                              C
8311 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8312 C
8313 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8314 C           energy moment and not to the cluster cumulant.
8315 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8316       iti=itortyp(itype(i))
8317       itj=itortyp(itype(j))
8318       if (j.lt.nres-1) then
8319         itj1=itortyp(itype(j+1))
8320       else
8321         itj1=ntortyp+1
8322       endif
8323       itk=itortyp(itype(k))
8324       if (k.lt.nres-1) then
8325         itk1=itortyp(itype(k+1))
8326       else
8327         itk1=ntortyp+1
8328       endif
8329       itl=itortyp(itype(l))
8330       if (l.lt.nres-1) then
8331         itl1=itortyp(itype(l+1))
8332       else
8333         itl1=ntortyp+1
8334       endif
8335 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8336 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8337 cd     & ' itl',itl,' itl1',itl1
8338 #ifdef MOMENT
8339       if (imat.eq.1) then
8340         s1=dip(3,jj,i)*dip(3,kk,k)
8341       else
8342         s1=dip(2,jj,j)*dip(2,kk,l)
8343       endif
8344 #endif
8345       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8346       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8347       if (j.eq.l+1) then
8348         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8349         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8350       else
8351         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8352         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8353       endif
8354       call transpose2(EUg(1,1,k),auxmat(1,1))
8355       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8356       vv(1)=pizda(1,1)-pizda(2,2)
8357       vv(2)=pizda(2,1)+pizda(1,2)
8358       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8359 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8360 #ifdef MOMENT
8361       eello6_graph4=-(s1+s2+s3+s4)
8362 #else
8363       eello6_graph4=-(s2+s3+s4)
8364 #endif
8365 C Derivatives in gamma(i-1)
8366       if (i.gt.1) then
8367 #ifdef MOMENT
8368         if (imat.eq.1) then
8369           s1=dipderg(2,jj,i)*dip(3,kk,k)
8370         else
8371           s1=dipderg(4,jj,j)*dip(2,kk,l)
8372         endif
8373 #endif
8374         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8375         if (j.eq.l+1) then
8376           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8377           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8378         else
8379           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8380           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8381         endif
8382         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8383         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8384 cd          write (2,*) 'turn6 derivatives'
8385 #ifdef MOMENT
8386           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8387 #else
8388           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8389 #endif
8390         else
8391 #ifdef MOMENT
8392           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8393 #else
8394           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8395 #endif
8396         endif
8397       endif
8398 C Derivatives in gamma(k-1)
8399 #ifdef MOMENT
8400       if (imat.eq.1) then
8401         s1=dip(3,jj,i)*dipderg(2,kk,k)
8402       else
8403         s1=dip(2,jj,j)*dipderg(4,kk,l)
8404       endif
8405 #endif
8406       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8407       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8408       if (j.eq.l+1) then
8409         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8410         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8411       else
8412         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8413         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8414       endif
8415       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8416       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8417       vv(1)=pizda(1,1)-pizda(2,2)
8418       vv(2)=pizda(2,1)+pizda(1,2)
8419       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8420       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8421 #ifdef MOMENT
8422         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8423 #else
8424         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8425 #endif
8426       else
8427 #ifdef MOMENT
8428         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8429 #else
8430         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8431 #endif
8432       endif
8433 C Derivatives in gamma(j-1) or gamma(l-1)
8434       if (l.eq.j+1 .and. l.gt.1) then
8435         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8436         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8437         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8438         vv(1)=pizda(1,1)-pizda(2,2)
8439         vv(2)=pizda(2,1)+pizda(1,2)
8440         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8441         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8442       else if (j.gt.1) then
8443         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8444         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8445         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8446         vv(1)=pizda(1,1)-pizda(2,2)
8447         vv(2)=pizda(2,1)+pizda(1,2)
8448         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8449         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8450           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8451         else
8452           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8453         endif
8454       endif
8455 C Cartesian derivatives.
8456       do iii=1,2
8457         do kkk=1,5
8458           do lll=1,3
8459 #ifdef MOMENT
8460             if (iii.eq.1) then
8461               if (imat.eq.1) then
8462                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8463               else
8464                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8465               endif
8466             else
8467               if (imat.eq.1) then
8468                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8469               else
8470                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8471               endif
8472             endif
8473 #endif
8474             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8475      &        auxvec(1))
8476             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8477             if (j.eq.l+1) then
8478               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8479      &          b1(1,itj1),auxvec(1))
8480               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8481             else
8482               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8483      &          b1(1,itl1),auxvec(1))
8484               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8485             endif
8486             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8487      &        pizda(1,1))
8488             vv(1)=pizda(1,1)-pizda(2,2)
8489             vv(2)=pizda(2,1)+pizda(1,2)
8490             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8491             if (swap) then
8492               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8493 #ifdef MOMENT
8494                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8495      &             -(s1+s2+s4)
8496 #else
8497                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8498      &             -(s2+s4)
8499 #endif
8500                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8501               else
8502 #ifdef MOMENT
8503                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8504 #else
8505                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8506 #endif
8507                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8508               endif
8509             else
8510 #ifdef MOMENT
8511               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8512 #else
8513               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8514 #endif
8515               if (l.eq.j+1) then
8516                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8517               else
8518                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8519               endif
8520             endif
8521           enddo
8522         enddo
8523       enddo
8524       return
8525       end
8526 c----------------------------------------------------------------------------
8527       double precision function eello_turn6(i,jj,kk)
8528       implicit real*8 (a-h,o-z)
8529       include 'DIMENSIONS'
8530       include 'COMMON.IOUNITS'
8531       include 'COMMON.CHAIN'
8532       include 'COMMON.DERIV'
8533       include 'COMMON.INTERACT'
8534       include 'COMMON.CONTACTS'
8535       include 'COMMON.TORSION'
8536       include 'COMMON.VAR'
8537       include 'COMMON.GEO'
8538       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8539      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8540      &  ggg1(3),ggg2(3)
8541       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8542      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8543 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8544 C           the respective energy moment and not to the cluster cumulant.
8545       s1=0.0d0
8546       s8=0.0d0
8547       s13=0.0d0
8548 c
8549       eello_turn6=0.0d0
8550       j=i+4
8551       k=i+1
8552       l=i+3
8553       iti=itortyp(itype(i))
8554       itk=itortyp(itype(k))
8555       itk1=itortyp(itype(k+1))
8556       itl=itortyp(itype(l))
8557       itj=itortyp(itype(j))
8558 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8559 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8560 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8561 cd        eello6=0.0d0
8562 cd        return
8563 cd      endif
8564 cd      write (iout,*)
8565 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8566 cd     &   ' and',k,l
8567 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8568       do iii=1,2
8569         do kkk=1,5
8570           do lll=1,3
8571             derx_turn(lll,kkk,iii)=0.0d0
8572           enddo
8573         enddo
8574       enddo
8575 cd      eij=1.0d0
8576 cd      ekl=1.0d0
8577 cd      ekont=1.0d0
8578       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8579 cd      eello6_5=0.0d0
8580 cd      write (2,*) 'eello6_5',eello6_5
8581 #ifdef MOMENT
8582       call transpose2(AEA(1,1,1),auxmat(1,1))
8583       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8584       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8585       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8586 #endif
8587       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8588       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8589       s2 = scalar2(b1(1,itk),vtemp1(1))
8590 #ifdef MOMENT
8591       call transpose2(AEA(1,1,2),atemp(1,1))
8592       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8593       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8594       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8595 #endif
8596       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8597       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8598       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8599 #ifdef MOMENT
8600       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8601       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8602       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8603       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8604       ss13 = scalar2(b1(1,itk),vtemp4(1))
8605       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8606 #endif
8607 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8608 c      s1=0.0d0
8609 c      s2=0.0d0
8610 c      s8=0.0d0
8611 c      s12=0.0d0
8612 c      s13=0.0d0
8613       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8614 C Derivatives in gamma(i+2)
8615       s1d =0.0d0
8616       s8d =0.0d0
8617 #ifdef MOMENT
8618       call transpose2(AEA(1,1,1),auxmatd(1,1))
8619       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8620       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8621       call transpose2(AEAderg(1,1,2),atempd(1,1))
8622       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8623       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8624 #endif
8625       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8626       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8627       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8628 c      s1d=0.0d0
8629 c      s2d=0.0d0
8630 c      s8d=0.0d0
8631 c      s12d=0.0d0
8632 c      s13d=0.0d0
8633       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8634 C Derivatives in gamma(i+3)
8635 #ifdef MOMENT
8636       call transpose2(AEA(1,1,1),auxmatd(1,1))
8637       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8638       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8639       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8640 #endif
8641       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8642       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8643       s2d = scalar2(b1(1,itk),vtemp1d(1))
8644 #ifdef MOMENT
8645       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8646       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8647 #endif
8648       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8649 #ifdef MOMENT
8650       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8651       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8652       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8653 #endif
8654 c      s1d=0.0d0
8655 c      s2d=0.0d0
8656 c      s8d=0.0d0
8657 c      s12d=0.0d0
8658 c      s13d=0.0d0
8659 #ifdef MOMENT
8660       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8661      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8662 #else
8663       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8664      &               -0.5d0*ekont*(s2d+s12d)
8665 #endif
8666 C Derivatives in gamma(i+4)
8667       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8668       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8669       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8670 #ifdef MOMENT
8671       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8672       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8673       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8674 #endif
8675 c      s1d=0.0d0
8676 c      s2d=0.0d0
8677 c      s8d=0.0d0
8678 C      s12d=0.0d0
8679 c      s13d=0.0d0
8680 #ifdef MOMENT
8681       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8682 #else
8683       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8684 #endif
8685 C Derivatives in gamma(i+5)
8686 #ifdef MOMENT
8687       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8688       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8689       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8690 #endif
8691       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8692       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8693       s2d = scalar2(b1(1,itk),vtemp1d(1))
8694 #ifdef MOMENT
8695       call transpose2(AEA(1,1,2),atempd(1,1))
8696       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8697       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8698 #endif
8699       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8700       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8701 #ifdef MOMENT
8702       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8703       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8704       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8705 #endif
8706 c      s1d=0.0d0
8707 c      s2d=0.0d0
8708 c      s8d=0.0d0
8709 c      s12d=0.0d0
8710 c      s13d=0.0d0
8711 #ifdef MOMENT
8712       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8713      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8714 #else
8715       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8716      &               -0.5d0*ekont*(s2d+s12d)
8717 #endif
8718 C Cartesian derivatives
8719       do iii=1,2
8720         do kkk=1,5
8721           do lll=1,3
8722 #ifdef MOMENT
8723             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8724             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8725             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8726 #endif
8727             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8728             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8729      &          vtemp1d(1))
8730             s2d = scalar2(b1(1,itk),vtemp1d(1))
8731 #ifdef MOMENT
8732             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8733             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8734             s8d = -(atempd(1,1)+atempd(2,2))*
8735      &           scalar2(cc(1,1,itl),vtemp2(1))
8736 #endif
8737             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8738      &           auxmatd(1,1))
8739             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8740             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8741 c      s1d=0.0d0
8742 c      s2d=0.0d0
8743 c      s8d=0.0d0
8744 c      s12d=0.0d0
8745 c      s13d=0.0d0
8746 #ifdef MOMENT
8747             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8748      &        - 0.5d0*(s1d+s2d)
8749 #else
8750             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8751      &        - 0.5d0*s2d
8752 #endif
8753 #ifdef MOMENT
8754             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8755      &        - 0.5d0*(s8d+s12d)
8756 #else
8757             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8758      &        - 0.5d0*s12d
8759 #endif
8760           enddo
8761         enddo
8762       enddo
8763 #ifdef MOMENT
8764       do kkk=1,5
8765         do lll=1,3
8766           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8767      &      achuj_tempd(1,1))
8768           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8769           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8770           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8771           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8772           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8773      &      vtemp4d(1))
8774           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8775           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8776           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8777         enddo
8778       enddo
8779 #endif
8780 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8781 cd     &  16*eel_turn6_num
8782 cd      goto 1112
8783       if (j.lt.nres-1) then
8784         j1=j+1
8785         j2=j-1
8786       else
8787         j1=j-1
8788         j2=j-2
8789       endif
8790       if (l.lt.nres-1) then
8791         l1=l+1
8792         l2=l-1
8793       else
8794         l1=l-1
8795         l2=l-2
8796       endif
8797       do ll=1,3
8798 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8799 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8800 cgrad        ghalf=0.5d0*ggg1(ll)
8801 cd        ghalf=0.0d0
8802         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8803         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8804         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8805      &    +ekont*derx_turn(ll,2,1)
8806         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8807         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8808      &    +ekont*derx_turn(ll,4,1)
8809         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8810         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8811         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8812 cgrad        ghalf=0.5d0*ggg2(ll)
8813 cd        ghalf=0.0d0
8814         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8815      &    +ekont*derx_turn(ll,2,2)
8816         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8817         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8818      &    +ekont*derx_turn(ll,4,2)
8819         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8820         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8821         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8822       enddo
8823 cd      goto 1112
8824 cgrad      do m=i+1,j-1
8825 cgrad        do ll=1,3
8826 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8827 cgrad        enddo
8828 cgrad      enddo
8829 cgrad      do m=k+1,l-1
8830 cgrad        do ll=1,3
8831 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8832 cgrad        enddo
8833 cgrad      enddo
8834 cgrad1112  continue
8835 cgrad      do m=i+2,j2
8836 cgrad        do ll=1,3
8837 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8838 cgrad        enddo
8839 cgrad      enddo
8840 cgrad      do m=k+2,l2
8841 cgrad        do ll=1,3
8842 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8843 cgrad        enddo
8844 cgrad      enddo
8845 cd      do iii=1,nres-3
8846 cd        write (2,*) iii,g_corr6_loc(iii)
8847 cd      enddo
8848       eello_turn6=ekont*eel_turn6
8849 cd      write (2,*) 'ekont',ekont
8850 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8851       return
8852       end
8853
8854 C-----------------------------------------------------------------------------
8855       double precision function scalar(u,v)
8856 !DIR$ INLINEALWAYS scalar
8857 #ifndef OSF
8858 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8859 #endif
8860       implicit none
8861       double precision u(3),v(3)
8862 cd      double precision sc
8863 cd      integer i
8864 cd      sc=0.0d0
8865 cd      do i=1,3
8866 cd        sc=sc+u(i)*v(i)
8867 cd      enddo
8868 cd      scalar=sc
8869
8870       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8871       return
8872       end
8873 crc-------------------------------------------------
8874       SUBROUTINE MATVEC2(A1,V1,V2)
8875 !DIR$ INLINEALWAYS MATVEC2
8876 #ifndef OSF
8877 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8878 #endif
8879       implicit real*8 (a-h,o-z)
8880       include 'DIMENSIONS'
8881       DIMENSION A1(2,2),V1(2),V2(2)
8882 c      DO 1 I=1,2
8883 c        VI=0.0
8884 c        DO 3 K=1,2
8885 c    3     VI=VI+A1(I,K)*V1(K)
8886 c        Vaux(I)=VI
8887 c    1 CONTINUE
8888
8889       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8890       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8891
8892       v2(1)=vaux1
8893       v2(2)=vaux2
8894       END
8895 C---------------------------------------
8896       SUBROUTINE MATMAT2(A1,A2,A3)
8897 #ifndef OSF
8898 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8899 #endif
8900       implicit real*8 (a-h,o-z)
8901       include 'DIMENSIONS'
8902       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8903 c      DIMENSION AI3(2,2)
8904 c        DO  J=1,2
8905 c          A3IJ=0.0
8906 c          DO K=1,2
8907 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8908 c          enddo
8909 c          A3(I,J)=A3IJ
8910 c       enddo
8911 c      enddo
8912
8913       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8914       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8915       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8916       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8917
8918       A3(1,1)=AI3_11
8919       A3(2,1)=AI3_21
8920       A3(1,2)=AI3_12
8921       A3(2,2)=AI3_22
8922       END
8923
8924 c-------------------------------------------------------------------------
8925       double precision function scalar2(u,v)
8926 !DIR$ INLINEALWAYS scalar2
8927       implicit none
8928       double precision u(2),v(2)
8929       double precision sc
8930       integer i
8931       scalar2=u(1)*v(1)+u(2)*v(2)
8932       return
8933       end
8934
8935 C-----------------------------------------------------------------------------
8936
8937       subroutine transpose2(a,at)
8938 !DIR$ INLINEALWAYS transpose2
8939 #ifndef OSF
8940 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8941 #endif
8942       implicit none
8943       double precision a(2,2),at(2,2)
8944       at(1,1)=a(1,1)
8945       at(1,2)=a(2,1)
8946       at(2,1)=a(1,2)
8947       at(2,2)=a(2,2)
8948       return
8949       end
8950 c--------------------------------------------------------------------------
8951       subroutine transpose(n,a,at)
8952       implicit none
8953       integer n,i,j
8954       double precision a(n,n),at(n,n)
8955       do i=1,n
8956         do j=1,n
8957           at(j,i)=a(i,j)
8958         enddo
8959       enddo
8960       return
8961       end
8962 C---------------------------------------------------------------------------
8963       subroutine prodmat3(a1,a2,kk,transp,prod)
8964 !DIR$ INLINEALWAYS prodmat3
8965 #ifndef OSF
8966 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8967 #endif
8968       implicit none
8969       integer i,j
8970       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8971       logical transp
8972 crc      double precision auxmat(2,2),prod_(2,2)
8973
8974       if (transp) then
8975 crc        call transpose2(kk(1,1),auxmat(1,1))
8976 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8977 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8978
8979            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8980      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8981            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8982      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8983            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8984      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8985            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8986      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8987
8988       else
8989 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8990 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8991
8992            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8993      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8994            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8995      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8996            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8997      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8998            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8999      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9000
9001       endif
9002 c      call transpose2(a2(1,1),a2t(1,1))
9003
9004 crc      print *,transp
9005 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9006 crc      print *,((prod(i,j),i=1,2),j=1,2)
9007
9008       return
9009       end
9010