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(max0(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
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          esccor_ii=0.0D0
5757 cc Added 09 May 2012 (Adasko)
5758 cc  Intertyp means interaction type of backbone mainchain correlation:
5759 c   1 = SC...Ca...Ca...Ca
5760 c   2 = Ca...Ca...Ca...SC
5761 c   3 = SC...Ca...Ca...SCi
5762         gloci=0.0D0
5763         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5764      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5765      &      (itype(i-1).eq.ntyp1)))
5766      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5767      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5768      &     .or.(itype(i).eq.ntyp1)))
5769      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5770      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5771      &      (itype(i-3).eq.ntyp1)))) cycle
5772         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5773         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5774      & cycle
5775        do j=1,nterm_sccor(isccori,isccori1)
5776           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5777           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5778           cosphi=dcos(j*tauangle(intertyp,i))
5779           sinphi=dsin(j*tauangle(intertyp,i))
5780           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5781           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5782           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5783         enddo
5784           if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
5785      &         'esccor',i,intertyp,esccor_ii
5786 cd       write (iout,*) "tau ",i,intertyp,tauangle(intertyp,i)*RAD2DEG
5787 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5788         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5789         if (lprn)
5790      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5791      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5792      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5793      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5794         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5795        enddo !intertyp
5796       enddo
5797
5798       return
5799       end
5800 c----------------------------------------------------------------------------
5801       subroutine multibody(ecorr)
5802 C This subroutine calculates multi-body contributions to energy following
5803 C the idea of Skolnick et al. If side chains I and J make a contact and
5804 C at the same time side chains I+1 and J+1 make a contact, an extra
5805 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5806       implicit real*8 (a-h,o-z)
5807       include 'DIMENSIONS'
5808       include 'COMMON.IOUNITS'
5809       include 'COMMON.DERIV'
5810       include 'COMMON.INTERACT'
5811       include 'COMMON.CONTACTS'
5812       double precision gx(3),gx1(3)
5813       logical lprn
5814
5815 C Set lprn=.true. for debugging
5816       lprn=.false.
5817
5818       if (lprn) then
5819         write (iout,'(a)') 'Contact function values:'
5820         do i=nnt,nct-2
5821           write (iout,'(i2,20(1x,i2,f10.5))')
5822      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5823         enddo
5824       endif
5825       ecorr=0.0D0
5826       do i=nnt,nct
5827         do j=1,3
5828           gradcorr(j,i)=0.0D0
5829           gradxorr(j,i)=0.0D0
5830         enddo
5831       enddo
5832       do i=nnt,nct-2
5833
5834         DO ISHIFT = 3,4
5835
5836         i1=i+ishift
5837         num_conti=num_cont(i)
5838         num_conti1=num_cont(i1)
5839         do jj=1,num_conti
5840           j=jcont(jj,i)
5841           do kk=1,num_conti1
5842             j1=jcont(kk,i1)
5843             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5844 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5845 cd   &                   ' ishift=',ishift
5846 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5847 C The system gains extra energy.
5848               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5849             endif   ! j1==j+-ishift
5850           enddo     ! kk
5851         enddo       ! jj
5852
5853         ENDDO ! ISHIFT
5854
5855       enddo         ! i
5856       return
5857       end
5858 c------------------------------------------------------------------------------
5859       double precision function esccorr(i,j,k,l,jj,kk)
5860       implicit real*8 (a-h,o-z)
5861       include 'DIMENSIONS'
5862       include 'COMMON.IOUNITS'
5863       include 'COMMON.DERIV'
5864       include 'COMMON.INTERACT'
5865       include 'COMMON.CONTACTS'
5866       double precision gx(3),gx1(3)
5867       logical lprn
5868       lprn=.false.
5869       eij=facont(jj,i)
5870       ekl=facont(kk,k)
5871 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5872 C Calculate the multi-body contribution to energy.
5873 C Calculate multi-body contributions to the gradient.
5874 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5875 cd   & k,l,(gacont(m,kk,k),m=1,3)
5876       do m=1,3
5877         gx(m) =ekl*gacont(m,jj,i)
5878         gx1(m)=eij*gacont(m,kk,k)
5879         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5880         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5881         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5882         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5883       enddo
5884       do m=i,j-1
5885         do ll=1,3
5886           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5887         enddo
5888       enddo
5889       do m=k,l-1
5890         do ll=1,3
5891           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5892         enddo
5893       enddo
5894       esccorr=-eij*ekl
5895       return
5896       end
5897 c------------------------------------------------------------------------------
5898       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5899 C This subroutine calculates multi-body contributions to hydrogen-bonding
5900       implicit real*8 (a-h,o-z)
5901       include 'DIMENSIONS'
5902       include 'COMMON.IOUNITS'
5903 #ifdef MPI
5904       include "mpif.h"
5905       parameter (max_cont=maxconts)
5906       parameter (max_dim=26)
5907       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5908       double precision zapas(max_dim,maxconts,max_fg_procs),
5909      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5910       common /przechowalnia/ zapas
5911       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5912      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5913 #endif
5914       include 'COMMON.SETUP'
5915       include 'COMMON.FFIELD'
5916       include 'COMMON.DERIV'
5917       include 'COMMON.INTERACT'
5918       include 'COMMON.CONTACTS'
5919       include 'COMMON.CONTROL'
5920       include 'COMMON.LOCAL'
5921       double precision gx(3),gx1(3),time00
5922       logical lprn,ldone
5923
5924 C Set lprn=.true. for debugging
5925       lprn=.false.
5926 #ifdef MPI
5927       n_corr=0
5928       n_corr1=0
5929       if (nfgtasks.le.1) goto 30
5930       if (lprn) then
5931         write (iout,'(a)') 'Contact function values before RECEIVE:'
5932         do i=nnt,nct-2
5933           write (iout,'(2i3,50(1x,i2,f5.2))')
5934      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5935      &    j=1,num_cont_hb(i))
5936         enddo
5937       endif
5938       call flush(iout)
5939       do i=1,ntask_cont_from
5940         ncont_recv(i)=0
5941       enddo
5942       do i=1,ntask_cont_to
5943         ncont_sent(i)=0
5944       enddo
5945 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5946 c     & ntask_cont_to
5947 C Make the list of contacts to send to send to other procesors
5948 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5949 c      call flush(iout)
5950       do i=iturn3_start,iturn3_end
5951 c        write (iout,*) "make contact list turn3",i," num_cont",
5952 c     &    num_cont_hb(i)
5953         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5954       enddo
5955       do i=iturn4_start,iturn4_end
5956 c        write (iout,*) "make contact list turn4",i," num_cont",
5957 c     &   num_cont_hb(i)
5958         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5959       enddo
5960       do ii=1,nat_sent
5961         i=iat_sent(ii)
5962 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5963 c     &    num_cont_hb(i)
5964         do j=1,num_cont_hb(i)
5965         do k=1,4
5966           jjc=jcont_hb(j,i)
5967           iproc=iint_sent_local(k,jjc,ii)
5968 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5969           if (iproc.gt.0) then
5970             ncont_sent(iproc)=ncont_sent(iproc)+1
5971             nn=ncont_sent(iproc)
5972             zapas(1,nn,iproc)=i
5973             zapas(2,nn,iproc)=jjc
5974             zapas(3,nn,iproc)=facont_hb(j,i)
5975             zapas(4,nn,iproc)=ees0p(j,i)
5976             zapas(5,nn,iproc)=ees0m(j,i)
5977             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5978             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5979             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5980             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5981             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5982             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5983             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5984             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5985             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5986             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5987             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5988             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5989             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5990             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5991             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5992             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5993             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5994             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5995             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5996             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5997             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5998           endif
5999         enddo
6000         enddo
6001       enddo
6002       if (lprn) then
6003       write (iout,*)
6004      &  "Numbers of contacts to be sent to other processors",
6005      &  (ncont_sent(i),i=1,ntask_cont_to)
6006       write (iout,*) "Contacts sent"
6007       do ii=1,ntask_cont_to
6008         nn=ncont_sent(ii)
6009         iproc=itask_cont_to(ii)
6010         write (iout,*) nn," contacts to processor",iproc,
6011      &   " of CONT_TO_COMM group"
6012         do i=1,nn
6013           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6014         enddo
6015       enddo
6016       call flush(iout)
6017       endif
6018       CorrelType=477
6019       CorrelID=fg_rank+1
6020       CorrelType1=478
6021       CorrelID1=nfgtasks+fg_rank+1
6022       ireq=0
6023 C Receive the numbers of needed contacts from other processors
6024       do ii=1,ntask_cont_from
6025         iproc=itask_cont_from(ii)
6026         ireq=ireq+1
6027         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6028      &    FG_COMM,req(ireq),IERR)
6029       enddo
6030 c      write (iout,*) "IRECV ended"
6031 c      call flush(iout)
6032 C Send the number of contacts needed by other processors
6033       do ii=1,ntask_cont_to
6034         iproc=itask_cont_to(ii)
6035         ireq=ireq+1
6036         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6037      &    FG_COMM,req(ireq),IERR)
6038       enddo
6039 c      write (iout,*) "ISEND ended"
6040 c      write (iout,*) "number of requests (nn)",ireq
6041       call flush(iout)
6042       if (ireq.gt.0)
6043      &  call MPI_Waitall(ireq,req,status_array,ierr)
6044 c      write (iout,*)
6045 c     &  "Numbers of contacts to be received from other processors",
6046 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6047 c      call flush(iout)
6048 C Receive contacts
6049       ireq=0
6050       do ii=1,ntask_cont_from
6051         iproc=itask_cont_from(ii)
6052         nn=ncont_recv(ii)
6053 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6054 c     &   " of CONT_TO_COMM group"
6055         call flush(iout)
6056         if (nn.gt.0) then
6057           ireq=ireq+1
6058           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6059      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6060 c          write (iout,*) "ireq,req",ireq,req(ireq)
6061         endif
6062       enddo
6063 C Send the contacts to processors that need them
6064       do ii=1,ntask_cont_to
6065         iproc=itask_cont_to(ii)
6066         nn=ncont_sent(ii)
6067 c        write (iout,*) nn," contacts to processor",iproc,
6068 c     &   " of CONT_TO_COMM group"
6069         if (nn.gt.0) then
6070           ireq=ireq+1
6071           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6072      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6073 c          write (iout,*) "ireq,req",ireq,req(ireq)
6074 c          do i=1,nn
6075 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6076 c          enddo
6077         endif
6078       enddo
6079 c      write (iout,*) "number of requests (contacts)",ireq
6080 c      write (iout,*) "req",(req(i),i=1,4)
6081 c      call flush(iout)
6082       if (ireq.gt.0)
6083      & call MPI_Waitall(ireq,req,status_array,ierr)
6084       do iii=1,ntask_cont_from
6085         iproc=itask_cont_from(iii)
6086         nn=ncont_recv(iii)
6087         if (lprn) then
6088         write (iout,*) "Received",nn," contacts from processor",iproc,
6089      &   " of CONT_FROM_COMM group"
6090         call flush(iout)
6091         do i=1,nn
6092           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6093         enddo
6094         call flush(iout)
6095         endif
6096         do i=1,nn
6097           ii=zapas_recv(1,i,iii)
6098 c Flag the received contacts to prevent double-counting
6099           jj=-zapas_recv(2,i,iii)
6100 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6101 c          call flush(iout)
6102           nnn=num_cont_hb(ii)+1
6103           num_cont_hb(ii)=nnn
6104           jcont_hb(nnn,ii)=jj
6105           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6106           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6107           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6108           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6109           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6110           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6111           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6112           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6113           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6114           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6115           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6116           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6117           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6118           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6119           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6120           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6121           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6122           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6123           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6124           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6125           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6126           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6127           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6128           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6129         enddo
6130       enddo
6131       call flush(iout)
6132       if (lprn) then
6133         write (iout,'(a)') 'Contact function values after receive:'
6134         do i=nnt,nct-2
6135           write (iout,'(2i3,50(1x,i3,f5.2))')
6136      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6137      &    j=1,num_cont_hb(i))
6138         enddo
6139         call flush(iout)
6140       endif
6141    30 continue
6142 #endif
6143       if (lprn) then
6144         write (iout,'(a)') 'Contact function values:'
6145         do i=nnt,nct-2
6146           write (iout,'(2i3,50(1x,i3,f5.2))')
6147      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6148      &    j=1,num_cont_hb(i))
6149         enddo
6150       endif
6151       ecorr=0.0D0
6152 C Remove the loop below after debugging !!!
6153       do i=nnt,nct
6154         do j=1,3
6155           gradcorr(j,i)=0.0D0
6156           gradxorr(j,i)=0.0D0
6157         enddo
6158       enddo
6159 C Calculate the local-electrostatic correlation terms
6160       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6161         i1=i+1
6162         num_conti=num_cont_hb(i)
6163         num_conti1=num_cont_hb(i+1)
6164         do jj=1,num_conti
6165           j=jcont_hb(jj,i)
6166           jp=iabs(j)
6167           do kk=1,num_conti1
6168             j1=jcont_hb(kk,i1)
6169             jp1=iabs(j1)
6170 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6171 c     &         ' jj=',jj,' kk=',kk
6172             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6173      &          .or. j.lt.0 .and. j1.gt.0) .and.
6174      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6175 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6176 C The system gains extra energy.
6177               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6178               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6179      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6180               n_corr=n_corr+1
6181             else if (j1.eq.j) then
6182 C Contacts I-J and I-(J+1) occur simultaneously.
6183 C The system loses extra energy.
6184 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6185             endif
6186           enddo ! kk
6187           do kk=1,num_conti
6188             j1=jcont_hb(kk,i)
6189 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6190 c    &         ' jj=',jj,' kk=',kk
6191             if (j1.eq.j+1) then
6192 C Contacts I-J and (I+1)-J occur simultaneously.
6193 C The system loses extra energy.
6194 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6195             endif ! j1==j+1
6196           enddo ! kk
6197         enddo ! jj
6198       enddo ! i
6199       return
6200       end
6201 c------------------------------------------------------------------------------
6202       subroutine add_hb_contact(ii,jj,itask)
6203       implicit real*8 (a-h,o-z)
6204       include "DIMENSIONS"
6205       include "COMMON.IOUNITS"
6206       integer max_cont
6207       integer max_dim
6208       parameter (max_cont=maxconts)
6209       parameter (max_dim=26)
6210       include "COMMON.CONTACTS"
6211       double precision zapas(max_dim,maxconts,max_fg_procs),
6212      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6213       common /przechowalnia/ zapas
6214       integer i,j,ii,jj,iproc,itask(4),nn
6215 c      write (iout,*) "itask",itask
6216       do i=1,2
6217         iproc=itask(i)
6218         if (iproc.gt.0) then
6219           do j=1,num_cont_hb(ii)
6220             jjc=jcont_hb(j,ii)
6221 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6222             if (jjc.eq.jj) then
6223               ncont_sent(iproc)=ncont_sent(iproc)+1
6224               nn=ncont_sent(iproc)
6225               zapas(1,nn,iproc)=ii
6226               zapas(2,nn,iproc)=jjc
6227               zapas(3,nn,iproc)=facont_hb(j,ii)
6228               zapas(4,nn,iproc)=ees0p(j,ii)
6229               zapas(5,nn,iproc)=ees0m(j,ii)
6230               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6231               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6232               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6233               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6234               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6235               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6236               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6237               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6238               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6239               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6240               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6241               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6242               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6243               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6244               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6245               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6246               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6247               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6248               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6249               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6250               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6251               exit
6252             endif
6253           enddo
6254         endif
6255       enddo
6256       return
6257       end
6258 c------------------------------------------------------------------------------
6259       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6260      &  n_corr1)
6261 C This subroutine calculates multi-body contributions to hydrogen-bonding
6262       implicit real*8 (a-h,o-z)
6263       include 'DIMENSIONS'
6264       include 'COMMON.IOUNITS'
6265 #ifdef MPI
6266       include "mpif.h"
6267       parameter (max_cont=maxconts)
6268       parameter (max_dim=70)
6269       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6270       double precision zapas(max_dim,maxconts,max_fg_procs),
6271      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6272       common /przechowalnia/ zapas
6273       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6274      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6275 #endif
6276       include 'COMMON.SETUP'
6277       include 'COMMON.FFIELD'
6278       include 'COMMON.DERIV'
6279       include 'COMMON.LOCAL'
6280       include 'COMMON.INTERACT'
6281       include 'COMMON.CONTACTS'
6282       include 'COMMON.CHAIN'
6283       include 'COMMON.CONTROL'
6284       double precision gx(3),gx1(3)
6285       integer num_cont_hb_old(maxres)
6286       logical lprn,ldone
6287       double precision eello4,eello5,eelo6,eello_turn6
6288       external eello4,eello5,eello6,eello_turn6
6289 C Set lprn=.true. for debugging
6290       lprn=.false.
6291       eturn6=0.0d0
6292 #ifdef MPI
6293       do i=1,nres
6294         num_cont_hb_old(i)=num_cont_hb(i)
6295       enddo
6296       n_corr=0
6297       n_corr1=0
6298       if (nfgtasks.le.1) goto 30
6299       if (lprn) then
6300         write (iout,'(a)') 'Contact function values before RECEIVE:'
6301         do i=nnt,nct-2
6302           write (iout,'(2i3,50(1x,i2,f5.2))')
6303      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6304      &    j=1,num_cont_hb(i))
6305         enddo
6306       endif
6307       call flush(iout)
6308       do i=1,ntask_cont_from
6309         ncont_recv(i)=0
6310       enddo
6311       do i=1,ntask_cont_to
6312         ncont_sent(i)=0
6313       enddo
6314 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6315 c     & ntask_cont_to
6316 C Make the list of contacts to send to send to other procesors
6317       do i=iturn3_start,iturn3_end
6318 c        write (iout,*) "make contact list turn3",i," num_cont",
6319 c     &    num_cont_hb(i)
6320         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6321       enddo
6322       do i=iturn4_start,iturn4_end
6323 c        write (iout,*) "make contact list turn4",i," num_cont",
6324 c     &   num_cont_hb(i)
6325         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6326       enddo
6327       do ii=1,nat_sent
6328         i=iat_sent(ii)
6329 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6330 c     &    num_cont_hb(i)
6331         do j=1,num_cont_hb(i)
6332         do k=1,4
6333           jjc=jcont_hb(j,i)
6334           iproc=iint_sent_local(k,jjc,ii)
6335 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6336           if (iproc.ne.0) then
6337             ncont_sent(iproc)=ncont_sent(iproc)+1
6338             nn=ncont_sent(iproc)
6339             zapas(1,nn,iproc)=i
6340             zapas(2,nn,iproc)=jjc
6341             zapas(3,nn,iproc)=d_cont(j,i)
6342             ind=3
6343             do kk=1,3
6344               ind=ind+1
6345               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6346             enddo
6347             do kk=1,2
6348               do ll=1,2
6349                 ind=ind+1
6350                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6351               enddo
6352             enddo
6353             do jj=1,5
6354               do kk=1,3
6355                 do ll=1,2
6356                   do mm=1,2
6357                     ind=ind+1
6358                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6359                   enddo
6360                 enddo
6361               enddo
6362             enddo
6363           endif
6364         enddo
6365         enddo
6366       enddo
6367       if (lprn) then
6368       write (iout,*)
6369      &  "Numbers of contacts to be sent to other processors",
6370      &  (ncont_sent(i),i=1,ntask_cont_to)
6371       write (iout,*) "Contacts sent"
6372       do ii=1,ntask_cont_to
6373         nn=ncont_sent(ii)
6374         iproc=itask_cont_to(ii)
6375         write (iout,*) nn," contacts to processor",iproc,
6376      &   " of CONT_TO_COMM group"
6377         do i=1,nn
6378           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6379         enddo
6380       enddo
6381       call flush(iout)
6382       endif
6383       CorrelType=477
6384       CorrelID=fg_rank+1
6385       CorrelType1=478
6386       CorrelID1=nfgtasks+fg_rank+1
6387       ireq=0
6388 C Receive the numbers of needed contacts from other processors
6389       do ii=1,ntask_cont_from
6390         iproc=itask_cont_from(ii)
6391         ireq=ireq+1
6392         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6393      &    FG_COMM,req(ireq),IERR)
6394       enddo
6395 c      write (iout,*) "IRECV ended"
6396 c      call flush(iout)
6397 C Send the number of contacts needed by other processors
6398       do ii=1,ntask_cont_to
6399         iproc=itask_cont_to(ii)
6400         ireq=ireq+1
6401         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6402      &    FG_COMM,req(ireq),IERR)
6403       enddo
6404 c      write (iout,*) "ISEND ended"
6405 c      write (iout,*) "number of requests (nn)",ireq
6406       call flush(iout)
6407       if (ireq.gt.0)
6408      &  call MPI_Waitall(ireq,req,status_array,ierr)
6409 c      write (iout,*)
6410 c     &  "Numbers of contacts to be received from other processors",
6411 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6412 c      call flush(iout)
6413 C Receive contacts
6414       ireq=0
6415       do ii=1,ntask_cont_from
6416         iproc=itask_cont_from(ii)
6417         nn=ncont_recv(ii)
6418 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6419 c     &   " of CONT_TO_COMM group"
6420         call flush(iout)
6421         if (nn.gt.0) then
6422           ireq=ireq+1
6423           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6424      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6425 c          write (iout,*) "ireq,req",ireq,req(ireq)
6426         endif
6427       enddo
6428 C Send the contacts to processors that need them
6429       do ii=1,ntask_cont_to
6430         iproc=itask_cont_to(ii)
6431         nn=ncont_sent(ii)
6432 c        write (iout,*) nn," contacts to processor",iproc,
6433 c     &   " of CONT_TO_COMM group"
6434         if (nn.gt.0) then
6435           ireq=ireq+1
6436           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6437      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6438 c          write (iout,*) "ireq,req",ireq,req(ireq)
6439 c          do i=1,nn
6440 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6441 c          enddo
6442         endif
6443       enddo
6444 c      write (iout,*) "number of requests (contacts)",ireq
6445 c      write (iout,*) "req",(req(i),i=1,4)
6446 c      call flush(iout)
6447       if (ireq.gt.0)
6448      & call MPI_Waitall(ireq,req,status_array,ierr)
6449       do iii=1,ntask_cont_from
6450         iproc=itask_cont_from(iii)
6451         nn=ncont_recv(iii)
6452         if (lprn) then
6453         write (iout,*) "Received",nn," contacts from processor",iproc,
6454      &   " of CONT_FROM_COMM group"
6455         call flush(iout)
6456         do i=1,nn
6457           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6458         enddo
6459         call flush(iout)
6460         endif
6461         do i=1,nn
6462           ii=zapas_recv(1,i,iii)
6463 c Flag the received contacts to prevent double-counting
6464           jj=-zapas_recv(2,i,iii)
6465 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6466 c          call flush(iout)
6467           nnn=num_cont_hb(ii)+1
6468           num_cont_hb(ii)=nnn
6469           jcont_hb(nnn,ii)=jj
6470           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6471           ind=3
6472           do kk=1,3
6473             ind=ind+1
6474             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6475           enddo
6476           do kk=1,2
6477             do ll=1,2
6478               ind=ind+1
6479               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6480             enddo
6481           enddo
6482           do jj=1,5
6483             do kk=1,3
6484               do ll=1,2
6485                 do mm=1,2
6486                   ind=ind+1
6487                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6488                 enddo
6489               enddo
6490             enddo
6491           enddo
6492         enddo
6493       enddo
6494       call flush(iout)
6495       if (lprn) then
6496         write (iout,'(a)') 'Contact function values after receive:'
6497         do i=nnt,nct-2
6498           write (iout,'(2i3,50(1x,i3,5f6.3))')
6499      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6500      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6501         enddo
6502         call flush(iout)
6503       endif
6504    30 continue
6505 #endif
6506       if (lprn) then
6507         write (iout,'(a)') 'Contact function values:'
6508         do i=nnt,nct-2
6509           write (iout,'(2i3,50(1x,i2,5f6.3))')
6510      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6511      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6512         enddo
6513       endif
6514       ecorr=0.0D0
6515       ecorr5=0.0d0
6516       ecorr6=0.0d0
6517 C Remove the loop below after debugging !!!
6518       do i=nnt,nct
6519         do j=1,3
6520           gradcorr(j,i)=0.0D0
6521           gradxorr(j,i)=0.0D0
6522         enddo
6523       enddo
6524 C Calculate the dipole-dipole interaction energies
6525       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6526       do i=iatel_s,iatel_e+1
6527         num_conti=num_cont_hb(i)
6528         do jj=1,num_conti
6529           j=jcont_hb(jj,i)
6530 #ifdef MOMENT
6531           call dipole(i,j,jj)
6532 #endif
6533         enddo
6534       enddo
6535       endif
6536 C Calculate the local-electrostatic correlation terms
6537 c                write (iout,*) "gradcorr5 in eello5 before loop"
6538 c                do iii=1,nres
6539 c                  write (iout,'(i5,3f10.5)')
6540 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6541 c                enddo
6542       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6543 c        write (iout,*) "corr loop i",i
6544         i1=i+1
6545         num_conti=num_cont_hb(i)
6546         num_conti1=num_cont_hb(i+1)
6547         do jj=1,num_conti
6548           j=jcont_hb(jj,i)
6549           jp=iabs(j)
6550           do kk=1,num_conti1
6551             j1=jcont_hb(kk,i1)
6552             jp1=iabs(j1)
6553 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6554 c     &         ' jj=',jj,' kk=',kk
6555 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6556             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6557      &          .or. j.lt.0 .and. j1.gt.0) .and.
6558      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6559 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6560 C The system gains extra energy.
6561               n_corr=n_corr+1
6562               sqd1=dsqrt(d_cont(jj,i))
6563               sqd2=dsqrt(d_cont(kk,i1))
6564               sred_geom = sqd1*sqd2
6565               IF (sred_geom.lt.cutoff_corr) THEN
6566                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6567      &            ekont,fprimcont)
6568 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6569 cd     &         ' jj=',jj,' kk=',kk
6570                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6571                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6572                 do l=1,3
6573                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6574                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6575                 enddo
6576                 n_corr1=n_corr1+1
6577 cd               write (iout,*) 'sred_geom=',sred_geom,
6578 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6579 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6580 cd               write (iout,*) "g_contij",g_contij
6581 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6582 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6583                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6584                 if (wcorr4.gt.0.0d0)
6585      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6586                   if (energy_dec.and.wcorr4.gt.0.0d0)
6587      1                 write (iout,'(a6,4i5,0pf7.3)')
6588      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6589 c                write (iout,*) "gradcorr5 before eello5"
6590 c                do iii=1,nres
6591 c                  write (iout,'(i5,3f10.5)')
6592 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6593 c                enddo
6594                 if (wcorr5.gt.0.0d0)
6595      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6596 c                write (iout,*) "gradcorr5 after eello5"
6597 c                do iii=1,nres
6598 c                  write (iout,'(i5,3f10.5)')
6599 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6600 c                enddo
6601                   if (energy_dec.and.wcorr5.gt.0.0d0)
6602      1                 write (iout,'(a6,4i5,0pf7.3)')
6603      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6604 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6605 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6606                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6607      &               .or. wturn6.eq.0.0d0))then
6608 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6609                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6610                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6611      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6612 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6613 cd     &            'ecorr6=',ecorr6
6614 cd                write (iout,'(4e15.5)') sred_geom,
6615 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6616 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6617 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6618                 else if (wturn6.gt.0.0d0
6619      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6620 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6621                   eturn6=eturn6+eello_turn6(i,jj,kk)
6622                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6623      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6624 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6625                 endif
6626               ENDIF
6627 1111          continue
6628             endif
6629           enddo ! kk
6630         enddo ! jj
6631       enddo ! i
6632       do i=1,nres
6633         num_cont_hb(i)=num_cont_hb_old(i)
6634       enddo
6635 c                write (iout,*) "gradcorr5 in eello5"
6636 c                do iii=1,nres
6637 c                  write (iout,'(i5,3f10.5)')
6638 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6639 c                enddo
6640       return
6641       end
6642 c------------------------------------------------------------------------------
6643       subroutine add_hb_contact_eello(ii,jj,itask)
6644       implicit real*8 (a-h,o-z)
6645       include "DIMENSIONS"
6646       include "COMMON.IOUNITS"
6647       integer max_cont
6648       integer max_dim
6649       parameter (max_cont=maxconts)
6650       parameter (max_dim=70)
6651       include "COMMON.CONTACTS"
6652       double precision zapas(max_dim,maxconts,max_fg_procs),
6653      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6654       common /przechowalnia/ zapas
6655       integer i,j,ii,jj,iproc,itask(4),nn
6656 c      write (iout,*) "itask",itask
6657       do i=1,2
6658         iproc=itask(i)
6659         if (iproc.gt.0) then
6660           do j=1,num_cont_hb(ii)
6661             jjc=jcont_hb(j,ii)
6662 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6663             if (jjc.eq.jj) then
6664               ncont_sent(iproc)=ncont_sent(iproc)+1
6665               nn=ncont_sent(iproc)
6666               zapas(1,nn,iproc)=ii
6667               zapas(2,nn,iproc)=jjc
6668               zapas(3,nn,iproc)=d_cont(j,ii)
6669               ind=3
6670               do kk=1,3
6671                 ind=ind+1
6672                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6673               enddo
6674               do kk=1,2
6675                 do ll=1,2
6676                   ind=ind+1
6677                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6678                 enddo
6679               enddo
6680               do jj=1,5
6681                 do kk=1,3
6682                   do ll=1,2
6683                     do mm=1,2
6684                       ind=ind+1
6685                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6686                     enddo
6687                   enddo
6688                 enddo
6689               enddo
6690               exit
6691             endif
6692           enddo
6693         endif
6694       enddo
6695       return
6696       end
6697 c------------------------------------------------------------------------------
6698       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6699       implicit real*8 (a-h,o-z)
6700       include 'DIMENSIONS'
6701       include 'COMMON.IOUNITS'
6702       include 'COMMON.DERIV'
6703       include 'COMMON.INTERACT'
6704       include 'COMMON.CONTACTS'
6705       double precision gx(3),gx1(3)
6706       logical lprn
6707       lprn=.false.
6708       eij=facont_hb(jj,i)
6709       ekl=facont_hb(kk,k)
6710       ees0pij=ees0p(jj,i)
6711       ees0pkl=ees0p(kk,k)
6712       ees0mij=ees0m(jj,i)
6713       ees0mkl=ees0m(kk,k)
6714       ekont=eij*ekl
6715       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6716 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6717 C Following 4 lines for diagnostics.
6718 cd    ees0pkl=0.0D0
6719 cd    ees0pij=1.0D0
6720 cd    ees0mkl=0.0D0
6721 cd    ees0mij=1.0D0
6722 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6723 c     & 'Contacts ',i,j,
6724 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6725 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6726 c     & 'gradcorr_long'
6727 C Calculate the multi-body contribution to energy.
6728 c      ecorr=ecorr+ekont*ees
6729 C Calculate multi-body contributions to the gradient.
6730       coeffpees0pij=coeffp*ees0pij
6731       coeffmees0mij=coeffm*ees0mij
6732       coeffpees0pkl=coeffp*ees0pkl
6733       coeffmees0mkl=coeffm*ees0mkl
6734       do ll=1,3
6735 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6736         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6737      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6738      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6739         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6740      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6741      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6742 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6743         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6744      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6745      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6746         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6747      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6748      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6749         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6750      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6751      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6752         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6753         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6754         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6755      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6756      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6757         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6758         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6759 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6760       enddo
6761 c      write (iout,*)
6762 cgrad      do m=i+1,j-1
6763 cgrad        do ll=1,3
6764 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6765 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6766 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6767 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6768 cgrad        enddo
6769 cgrad      enddo
6770 cgrad      do m=k+1,l-1
6771 cgrad        do ll=1,3
6772 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6773 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6774 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6775 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6776 cgrad        enddo
6777 cgrad      enddo
6778 c      write (iout,*) "ehbcorr",ekont*ees
6779       ehbcorr=ekont*ees
6780       return
6781       end
6782 #ifdef MOMENT
6783 C---------------------------------------------------------------------------
6784       subroutine dipole(i,j,jj)
6785       implicit real*8 (a-h,o-z)
6786       include 'DIMENSIONS'
6787       include 'COMMON.IOUNITS'
6788       include 'COMMON.CHAIN'
6789       include 'COMMON.FFIELD'
6790       include 'COMMON.DERIV'
6791       include 'COMMON.INTERACT'
6792       include 'COMMON.CONTACTS'
6793       include 'COMMON.TORSION'
6794       include 'COMMON.VAR'
6795       include 'COMMON.GEO'
6796       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6797      &  auxmat(2,2)
6798       iti1 = itortyp(itype(i+1))
6799       if (j.lt.nres-1) then
6800         itj1 = itortyp(itype(j+1))
6801       else
6802         itj1=ntortyp+1
6803       endif
6804       do iii=1,2
6805         dipi(iii,1)=Ub2(iii,i)
6806         dipderi(iii)=Ub2der(iii,i)
6807         dipi(iii,2)=b1(iii,iti1)
6808         dipj(iii,1)=Ub2(iii,j)
6809         dipderj(iii)=Ub2der(iii,j)
6810         dipj(iii,2)=b1(iii,itj1)
6811       enddo
6812       kkk=0
6813       do iii=1,2
6814         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6815         do jjj=1,2
6816           kkk=kkk+1
6817           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6818         enddo
6819       enddo
6820       do kkk=1,5
6821         do lll=1,3
6822           mmm=0
6823           do iii=1,2
6824             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6825      &        auxvec(1))
6826             do jjj=1,2
6827               mmm=mmm+1
6828               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6829             enddo
6830           enddo
6831         enddo
6832       enddo
6833       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6834       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6835       do iii=1,2
6836         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6837       enddo
6838       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6839       do iii=1,2
6840         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6841       enddo
6842       return
6843       end
6844 #endif
6845 C---------------------------------------------------------------------------
6846       subroutine calc_eello(i,j,k,l,jj,kk)
6847 C
6848 C This subroutine computes matrices and vectors needed to calculate
6849 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6850 C
6851       implicit real*8 (a-h,o-z)
6852       include 'DIMENSIONS'
6853       include 'COMMON.IOUNITS'
6854       include 'COMMON.CHAIN'
6855       include 'COMMON.DERIV'
6856       include 'COMMON.INTERACT'
6857       include 'COMMON.CONTACTS'
6858       include 'COMMON.TORSION'
6859       include 'COMMON.VAR'
6860       include 'COMMON.GEO'
6861       include 'COMMON.FFIELD'
6862       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6863      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6864       logical lprn
6865       common /kutas/ lprn
6866 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6867 cd     & ' jj=',jj,' kk=',kk
6868 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6869 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6870 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6871       do iii=1,2
6872         do jjj=1,2
6873           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6874           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6875         enddo
6876       enddo
6877       call transpose2(aa1(1,1),aa1t(1,1))
6878       call transpose2(aa2(1,1),aa2t(1,1))
6879       do kkk=1,5
6880         do lll=1,3
6881           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6882      &      aa1tder(1,1,lll,kkk))
6883           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6884      &      aa2tder(1,1,lll,kkk))
6885         enddo
6886       enddo
6887       if (l.eq.j+1) then
6888 C parallel orientation of the two CA-CA-CA frames.
6889         if (i.gt.1) then
6890           iti=itortyp(itype(i))
6891         else
6892           iti=ntortyp+1
6893         endif
6894         itk1=itortyp(itype(k+1))
6895         itj=itortyp(itype(j))
6896         if (l.lt.nres-1) then
6897           itl1=itortyp(itype(l+1))
6898         else
6899           itl1=ntortyp+1
6900         endif
6901 C A1 kernel(j+1) A2T
6902 cd        do iii=1,2
6903 cd          write (iout,'(3f10.5,5x,3f10.5)')
6904 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6905 cd        enddo
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.,EUg(1,1,l),EUgder(1,1,l),
6908      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6909 C Following matrices are needed only for 6-th order cumulants
6910         IF (wcorr6.gt.0.0d0) THEN
6911         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6912      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6913      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
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.,Ug2DtEUg(1,1,l),
6916      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6917      &   ADtEAderx(1,1,1,1,1,1))
6918         lprn=.false.
6919         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6920      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6921      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6922      &   ADtEA1derx(1,1,1,1,1,1))
6923         ENDIF
6924 C End 6-th order cumulants
6925 cd        lprn=.false.
6926 cd        if (lprn) then
6927 cd        write (2,*) 'In calc_eello6'
6928 cd        do iii=1,2
6929 cd          write (2,*) 'iii=',iii
6930 cd          do kkk=1,5
6931 cd            write (2,*) 'kkk=',kkk
6932 cd            do jjj=1,2
6933 cd              write (2,'(3(2f10.5),5x)')
6934 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6935 cd            enddo
6936 cd          enddo
6937 cd        enddo
6938 cd        endif
6939         call transpose2(EUgder(1,1,k),auxmat(1,1))
6940         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6941         call transpose2(EUg(1,1,k),auxmat(1,1))
6942         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6943         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6944         do iii=1,2
6945           do kkk=1,5
6946             do lll=1,3
6947               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6948      &          EAEAderx(1,1,lll,kkk,iii,1))
6949             enddo
6950           enddo
6951         enddo
6952 C A1T kernel(i+1) A2
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.,EUg(1,1,k),EUgder(1,1,k),
6955      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6956 C Following matrices are needed only for 6-th order cumulants
6957         IF (wcorr6.gt.0.0d0) THEN
6958         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6959      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6960      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6961         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6962      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6963      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6964      &   ADtEAderx(1,1,1,1,1,2))
6965         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6966      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6967      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6968      &   ADtEA1derx(1,1,1,1,1,2))
6969         ENDIF
6970 C End 6-th order cumulants
6971         call transpose2(EUgder(1,1,l),auxmat(1,1))
6972         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6973         call transpose2(EUg(1,1,l),auxmat(1,1))
6974         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6975         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6976         do iii=1,2
6977           do kkk=1,5
6978             do lll=1,3
6979               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6980      &          EAEAderx(1,1,lll,kkk,iii,2))
6981             enddo
6982           enddo
6983         enddo
6984 C AEAb1 and AEAb2
6985 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6986 C They are needed only when the fifth- or the sixth-order cumulants are
6987 C indluded.
6988         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6989         call transpose2(AEA(1,1,1),auxmat(1,1))
6990         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6991         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6992         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6993         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6994         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6995         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6996         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6997         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6998         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6999         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7000         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7001         call transpose2(AEA(1,1,2),auxmat(1,1))
7002         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7003         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7004         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7005         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7006         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7007         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7008         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7009         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7010         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7011         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7012         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7013 C Calculate the Cartesian derivatives of the vectors.
7014         do iii=1,2
7015           do kkk=1,5
7016             do lll=1,3
7017               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7018               call matvec2(auxmat(1,1),b1(1,iti),
7019      &          AEAb1derx(1,lll,kkk,iii,1,1))
7020               call matvec2(auxmat(1,1),Ub2(1,i),
7021      &          AEAb2derx(1,lll,kkk,iii,1,1))
7022               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7023      &          AEAb1derx(1,lll,kkk,iii,2,1))
7024               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7025      &          AEAb2derx(1,lll,kkk,iii,2,1))
7026               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7027               call matvec2(auxmat(1,1),b1(1,itj),
7028      &          AEAb1derx(1,lll,kkk,iii,1,2))
7029               call matvec2(auxmat(1,1),Ub2(1,j),
7030      &          AEAb2derx(1,lll,kkk,iii,1,2))
7031               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7032      &          AEAb1derx(1,lll,kkk,iii,2,2))
7033               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7034      &          AEAb2derx(1,lll,kkk,iii,2,2))
7035             enddo
7036           enddo
7037         enddo
7038         ENDIF
7039 C End vectors
7040       else
7041 C Antiparallel orientation of the two CA-CA-CA frames.
7042         if (i.gt.1) then
7043           iti=itortyp(itype(i))
7044         else
7045           iti=ntortyp+1
7046         endif
7047         itk1=itortyp(itype(k+1))
7048         itl=itortyp(itype(l))
7049         itj=itortyp(itype(j))
7050         if (j.lt.nres-1) then
7051           itj1=itortyp(itype(j+1))
7052         else
7053           itj1=ntortyp+1
7054         endif
7055 C A2 kernel(j-1)T A1T
7056         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7057      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7058      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7059 C Following matrices are needed only for 6-th order cumulants
7060         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7061      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7062         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7063      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7064      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7065         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7066      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7067      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7068      &   ADtEAderx(1,1,1,1,1,1))
7069         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7070      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7071      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7072      &   ADtEA1derx(1,1,1,1,1,1))
7073         ENDIF
7074 C End 6-th order cumulants
7075         call transpose2(EUgder(1,1,k),auxmat(1,1))
7076         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7077         call transpose2(EUg(1,1,k),auxmat(1,1))
7078         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7079         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7080         do iii=1,2
7081           do kkk=1,5
7082             do lll=1,3
7083               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7084      &          EAEAderx(1,1,lll,kkk,iii,1))
7085             enddo
7086           enddo
7087         enddo
7088 C A2T kernel(i+1)T A1
7089         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7090      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7091      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7092 C Following matrices are needed only for 6-th order cumulants
7093         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7094      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7095         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7096      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7097      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7098         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7099      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7100      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7101      &   ADtEAderx(1,1,1,1,1,2))
7102         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7103      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7104      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7105      &   ADtEA1derx(1,1,1,1,1,2))
7106         ENDIF
7107 C End 6-th order cumulants
7108         call transpose2(EUgder(1,1,j),auxmat(1,1))
7109         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7110         call transpose2(EUg(1,1,j),auxmat(1,1))
7111         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7112         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7113         do iii=1,2
7114           do kkk=1,5
7115             do lll=1,3
7116               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7117      &          EAEAderx(1,1,lll,kkk,iii,2))
7118             enddo
7119           enddo
7120         enddo
7121 C AEAb1 and AEAb2
7122 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7123 C They are needed only when the fifth- or the sixth-order cumulants are
7124 C indluded.
7125         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7126      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7127         call transpose2(AEA(1,1,1),auxmat(1,1))
7128         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7129         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7130         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7131         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7132         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7133         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7134         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7135         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7136         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7137         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7138         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7139         call transpose2(AEA(1,1,2),auxmat(1,1))
7140         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7141         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7142         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7143         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7144         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7145         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7146         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7147         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7148         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7149         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7150         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7151 C Calculate the Cartesian derivatives of the vectors.
7152         do iii=1,2
7153           do kkk=1,5
7154             do lll=1,3
7155               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7156               call matvec2(auxmat(1,1),b1(1,iti),
7157      &          AEAb1derx(1,lll,kkk,iii,1,1))
7158               call matvec2(auxmat(1,1),Ub2(1,i),
7159      &          AEAb2derx(1,lll,kkk,iii,1,1))
7160               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7161      &          AEAb1derx(1,lll,kkk,iii,2,1))
7162               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7163      &          AEAb2derx(1,lll,kkk,iii,2,1))
7164               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7165               call matvec2(auxmat(1,1),b1(1,itl),
7166      &          AEAb1derx(1,lll,kkk,iii,1,2))
7167               call matvec2(auxmat(1,1),Ub2(1,l),
7168      &          AEAb2derx(1,lll,kkk,iii,1,2))
7169               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7170      &          AEAb1derx(1,lll,kkk,iii,2,2))
7171               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7172      &          AEAb2derx(1,lll,kkk,iii,2,2))
7173             enddo
7174           enddo
7175         enddo
7176         ENDIF
7177 C End vectors
7178       endif
7179       return
7180       end
7181 C---------------------------------------------------------------------------
7182       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7183      &  KK,KKderg,AKA,AKAderg,AKAderx)
7184       implicit none
7185       integer nderg
7186       logical transp
7187       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7188      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7189      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7190       integer iii,kkk,lll
7191       integer jjj,mmm
7192       logical lprn
7193       common /kutas/ lprn
7194       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7195       do iii=1,nderg
7196         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7197      &    AKAderg(1,1,iii))
7198       enddo
7199 cd      if (lprn) write (2,*) 'In kernel'
7200       do kkk=1,5
7201 cd        if (lprn) write (2,*) 'kkk=',kkk
7202         do lll=1,3
7203           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7204      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7205 cd          if (lprn) then
7206 cd            write (2,*) 'lll=',lll
7207 cd            write (2,*) 'iii=1'
7208 cd            do jjj=1,2
7209 cd              write (2,'(3(2f10.5),5x)')
7210 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7211 cd            enddo
7212 cd          endif
7213           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7214      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7215 cd          if (lprn) then
7216 cd            write (2,*) 'lll=',lll
7217 cd            write (2,*) 'iii=2'
7218 cd            do jjj=1,2
7219 cd              write (2,'(3(2f10.5),5x)')
7220 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7221 cd            enddo
7222 cd          endif
7223         enddo
7224       enddo
7225       return
7226       end
7227 C---------------------------------------------------------------------------
7228       double precision function eello4(i,j,k,l,jj,kk)
7229       implicit real*8 (a-h,o-z)
7230       include 'DIMENSIONS'
7231       include 'COMMON.IOUNITS'
7232       include 'COMMON.CHAIN'
7233       include 'COMMON.DERIV'
7234       include 'COMMON.INTERACT'
7235       include 'COMMON.CONTACTS'
7236       include 'COMMON.TORSION'
7237       include 'COMMON.VAR'
7238       include 'COMMON.GEO'
7239       double precision pizda(2,2),ggg1(3),ggg2(3)
7240 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7241 cd        eello4=0.0d0
7242 cd        return
7243 cd      endif
7244 cd      print *,'eello4:',i,j,k,l,jj,kk
7245 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7246 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7247 cold      eij=facont_hb(jj,i)
7248 cold      ekl=facont_hb(kk,k)
7249 cold      ekont=eij*ekl
7250       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7251 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7252       gcorr_loc(k-1)=gcorr_loc(k-1)
7253      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7254       if (l.eq.j+1) then
7255         gcorr_loc(l-1)=gcorr_loc(l-1)
7256      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7257       else
7258         gcorr_loc(j-1)=gcorr_loc(j-1)
7259      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7260       endif
7261       do iii=1,2
7262         do kkk=1,5
7263           do lll=1,3
7264             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7265      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7266 cd            derx(lll,kkk,iii)=0.0d0
7267           enddo
7268         enddo
7269       enddo
7270 cd      gcorr_loc(l-1)=0.0d0
7271 cd      gcorr_loc(j-1)=0.0d0
7272 cd      gcorr_loc(k-1)=0.0d0
7273 cd      eel4=1.0d0
7274 cd      write (iout,*)'Contacts have occurred for peptide groups',
7275 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7276 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7277       if (j.lt.nres-1) then
7278         j1=j+1
7279         j2=j-1
7280       else
7281         j1=j-1
7282         j2=j-2
7283       endif
7284       if (l.lt.nres-1) then
7285         l1=l+1
7286         l2=l-1
7287       else
7288         l1=l-1
7289         l2=l-2
7290       endif
7291       do ll=1,3
7292 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7293 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7294         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7295         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7296 cgrad        ghalf=0.5d0*ggg1(ll)
7297         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7298         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7299         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7300         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7301         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7302         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7303 cgrad        ghalf=0.5d0*ggg2(ll)
7304         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7305         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7306         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7307         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7308         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7309         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7310       enddo
7311 cgrad      do m=i+1,j-1
7312 cgrad        do ll=1,3
7313 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7314 cgrad        enddo
7315 cgrad      enddo
7316 cgrad      do m=k+1,l-1
7317 cgrad        do ll=1,3
7318 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7319 cgrad        enddo
7320 cgrad      enddo
7321 cgrad      do m=i+2,j2
7322 cgrad        do ll=1,3
7323 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7324 cgrad        enddo
7325 cgrad      enddo
7326 cgrad      do m=k+2,l2
7327 cgrad        do ll=1,3
7328 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7329 cgrad        enddo
7330 cgrad      enddo
7331 cd      do iii=1,nres-3
7332 cd        write (2,*) iii,gcorr_loc(iii)
7333 cd      enddo
7334       eello4=ekont*eel4
7335 cd      write (2,*) 'ekont',ekont
7336 cd      write (iout,*) 'eello4',ekont*eel4
7337       return
7338       end
7339 C---------------------------------------------------------------------------
7340       double precision function eello5(i,j,k,l,jj,kk)
7341       implicit real*8 (a-h,o-z)
7342       include 'DIMENSIONS'
7343       include 'COMMON.IOUNITS'
7344       include 'COMMON.CHAIN'
7345       include 'COMMON.DERIV'
7346       include 'COMMON.INTERACT'
7347       include 'COMMON.CONTACTS'
7348       include 'COMMON.TORSION'
7349       include 'COMMON.VAR'
7350       include 'COMMON.GEO'
7351       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7352       double precision ggg1(3),ggg2(3)
7353 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7354 C                                                                              C
7355 C                            Parallel chains                                   C
7356 C                                                                              C
7357 C          o             o                   o             o                   C
7358 C         /l\           / \             \   / \           / \   /              C
7359 C        /   \         /   \             \ /   \         /   \ /               C
7360 C       j| o |l1       | o |              o| o |         | o |o                C
7361 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7362 C      \i/   \         /   \ /             /   \         /   \                 C
7363 C       o    k1             o                                                  C
7364 C         (I)          (II)                (III)          (IV)                 C
7365 C                                                                              C
7366 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7367 C                                                                              C
7368 C                            Antiparallel chains                               C
7369 C                                                                              C
7370 C          o             o                   o             o                   C
7371 C         /j\           / \             \   / \           / \   /              C
7372 C        /   \         /   \             \ /   \         /   \ /               C
7373 C      j1| o |l        | o |              o| o |         | o |o                C
7374 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7375 C      \i/   \         /   \ /             /   \         /   \                 C
7376 C       o     k1            o                                                  C
7377 C         (I)          (II)                (III)          (IV)                 C
7378 C                                                                              C
7379 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7380 C                                                                              C
7381 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7382 C                                                                              C
7383 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7384 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7385 cd        eello5=0.0d0
7386 cd        return
7387 cd      endif
7388 cd      write (iout,*)
7389 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7390 cd     &   ' and',k,l
7391       itk=itortyp(itype(k))
7392       itl=itortyp(itype(l))
7393       itj=itortyp(itype(j))
7394       eello5_1=0.0d0
7395       eello5_2=0.0d0
7396       eello5_3=0.0d0
7397       eello5_4=0.0d0
7398 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7399 cd     &   eel5_3_num,eel5_4_num)
7400       do iii=1,2
7401         do kkk=1,5
7402           do lll=1,3
7403             derx(lll,kkk,iii)=0.0d0
7404           enddo
7405         enddo
7406       enddo
7407 cd      eij=facont_hb(jj,i)
7408 cd      ekl=facont_hb(kk,k)
7409 cd      ekont=eij*ekl
7410 cd      write (iout,*)'Contacts have occurred for peptide groups',
7411 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7412 cd      goto 1111
7413 C Contribution from the graph I.
7414 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7415 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7416       call transpose2(EUg(1,1,k),auxmat(1,1))
7417       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7418       vv(1)=pizda(1,1)-pizda(2,2)
7419       vv(2)=pizda(1,2)+pizda(2,1)
7420       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7421      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7422 C Explicit gradient in virtual-dihedral angles.
7423       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7424      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7425      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7426       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7427       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7428       vv(1)=pizda(1,1)-pizda(2,2)
7429       vv(2)=pizda(1,2)+pizda(2,1)
7430       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7431      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7432      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7433       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7434       vv(1)=pizda(1,1)-pizda(2,2)
7435       vv(2)=pizda(1,2)+pizda(2,1)
7436       if (l.eq.j+1) then
7437         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7438      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7439      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7440       else
7441         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7442      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7443      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7444       endif
7445 C Cartesian gradient
7446       do iii=1,2
7447         do kkk=1,5
7448           do lll=1,3
7449             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7450      &        pizda(1,1))
7451             vv(1)=pizda(1,1)-pizda(2,2)
7452             vv(2)=pizda(1,2)+pizda(2,1)
7453             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7454      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7455      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7456           enddo
7457         enddo
7458       enddo
7459 c      goto 1112
7460 c1111  continue
7461 C Contribution from graph II
7462       call transpose2(EE(1,1,itk),auxmat(1,1))
7463       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7464       vv(1)=pizda(1,1)+pizda(2,2)
7465       vv(2)=pizda(2,1)-pizda(1,2)
7466       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7467      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7468 C Explicit gradient in virtual-dihedral angles.
7469       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7470      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7471       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7472       vv(1)=pizda(1,1)+pizda(2,2)
7473       vv(2)=pizda(2,1)-pizda(1,2)
7474       if (l.eq.j+1) then
7475         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7476      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7477      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7478       else
7479         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7480      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7481      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7482       endif
7483 C Cartesian gradient
7484       do iii=1,2
7485         do kkk=1,5
7486           do lll=1,3
7487             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7488      &        pizda(1,1))
7489             vv(1)=pizda(1,1)+pizda(2,2)
7490             vv(2)=pizda(2,1)-pizda(1,2)
7491             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7492      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7493      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7494           enddo
7495         enddo
7496       enddo
7497 cd      goto 1112
7498 cd1111  continue
7499       if (l.eq.j+1) then
7500 cd        goto 1110
7501 C Parallel orientation
7502 C Contribution from graph III
7503         call transpose2(EUg(1,1,l),auxmat(1,1))
7504         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7505         vv(1)=pizda(1,1)-pizda(2,2)
7506         vv(2)=pizda(1,2)+pizda(2,1)
7507         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7508      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7509 C Explicit gradient in virtual-dihedral angles.
7510         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7511      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7512      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7513         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7514         vv(1)=pizda(1,1)-pizda(2,2)
7515         vv(2)=pizda(1,2)+pizda(2,1)
7516         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7517      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7518      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7519         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7520         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7521         vv(1)=pizda(1,1)-pizda(2,2)
7522         vv(2)=pizda(1,2)+pizda(2,1)
7523         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7524      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7525      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7526 C Cartesian gradient
7527         do iii=1,2
7528           do kkk=1,5
7529             do lll=1,3
7530               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7531      &          pizda(1,1))
7532               vv(1)=pizda(1,1)-pizda(2,2)
7533               vv(2)=pizda(1,2)+pizda(2,1)
7534               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7535      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7536      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7537             enddo
7538           enddo
7539         enddo
7540 cd        goto 1112
7541 C Contribution from graph IV
7542 cd1110    continue
7543         call transpose2(EE(1,1,itl),auxmat(1,1))
7544         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7545         vv(1)=pizda(1,1)+pizda(2,2)
7546         vv(2)=pizda(2,1)-pizda(1,2)
7547         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7548      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7549 C Explicit gradient in virtual-dihedral angles.
7550         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7551      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7552         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7553         vv(1)=pizda(1,1)+pizda(2,2)
7554         vv(2)=pizda(2,1)-pizda(1,2)
7555         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7556      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7557      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7558 C Cartesian gradient
7559         do iii=1,2
7560           do kkk=1,5
7561             do lll=1,3
7562               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7563      &          pizda(1,1))
7564               vv(1)=pizda(1,1)+pizda(2,2)
7565               vv(2)=pizda(2,1)-pizda(1,2)
7566               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7567      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7568      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7569             enddo
7570           enddo
7571         enddo
7572       else
7573 C Antiparallel orientation
7574 C Contribution from graph III
7575 c        goto 1110
7576         call transpose2(EUg(1,1,j),auxmat(1,1))
7577         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7578         vv(1)=pizda(1,1)-pizda(2,2)
7579         vv(2)=pizda(1,2)+pizda(2,1)
7580         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7581      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7582 C Explicit gradient in virtual-dihedral angles.
7583         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7584      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7585      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7586         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7587         vv(1)=pizda(1,1)-pizda(2,2)
7588         vv(2)=pizda(1,2)+pizda(2,1)
7589         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7590      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7591      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7592         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7593         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7594         vv(1)=pizda(1,1)-pizda(2,2)
7595         vv(2)=pizda(1,2)+pizda(2,1)
7596         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7597      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7598      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7599 C Cartesian gradient
7600         do iii=1,2
7601           do kkk=1,5
7602             do lll=1,3
7603               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7604      &          pizda(1,1))
7605               vv(1)=pizda(1,1)-pizda(2,2)
7606               vv(2)=pizda(1,2)+pizda(2,1)
7607               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7608      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7609      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7610             enddo
7611           enddo
7612         enddo
7613 cd        goto 1112
7614 C Contribution from graph IV
7615 1110    continue
7616         call transpose2(EE(1,1,itj),auxmat(1,1))
7617         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7618         vv(1)=pizda(1,1)+pizda(2,2)
7619         vv(2)=pizda(2,1)-pizda(1,2)
7620         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7621      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7622 C Explicit gradient in virtual-dihedral angles.
7623         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7624      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7625         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7626         vv(1)=pizda(1,1)+pizda(2,2)
7627         vv(2)=pizda(2,1)-pizda(1,2)
7628         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7629      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7630      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7631 C Cartesian gradient
7632         do iii=1,2
7633           do kkk=1,5
7634             do lll=1,3
7635               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7636      &          pizda(1,1))
7637               vv(1)=pizda(1,1)+pizda(2,2)
7638               vv(2)=pizda(2,1)-pizda(1,2)
7639               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7640      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7641      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7642             enddo
7643           enddo
7644         enddo
7645       endif
7646 1112  continue
7647       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7648 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7649 cd        write (2,*) 'ijkl',i,j,k,l
7650 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7651 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7652 cd      endif
7653 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7654 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7655 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7656 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7657       if (j.lt.nres-1) then
7658         j1=j+1
7659         j2=j-1
7660       else
7661         j1=j-1
7662         j2=j-2
7663       endif
7664       if (l.lt.nres-1) then
7665         l1=l+1
7666         l2=l-1
7667       else
7668         l1=l-1
7669         l2=l-2
7670       endif
7671 cd      eij=1.0d0
7672 cd      ekl=1.0d0
7673 cd      ekont=1.0d0
7674 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7675 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7676 C        summed up outside the subrouine as for the other subroutines
7677 C        handling long-range interactions. The old code is commented out
7678 C        with "cgrad" to keep track of changes.
7679       do ll=1,3
7680 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7681 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7682         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7683         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7684 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7685 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7686 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7687 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7688 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7689 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7690 c     &   gradcorr5ij,
7691 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7692 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7693 cgrad        ghalf=0.5d0*ggg1(ll)
7694 cd        ghalf=0.0d0
7695         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7696         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7697         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7698         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7699         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7700         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7701 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7702 cgrad        ghalf=0.5d0*ggg2(ll)
7703 cd        ghalf=0.0d0
7704         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7705         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7706         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7707         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7708         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7709         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7710       enddo
7711 cd      goto 1112
7712 cgrad      do m=i+1,j-1
7713 cgrad        do ll=1,3
7714 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7715 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7716 cgrad        enddo
7717 cgrad      enddo
7718 cgrad      do m=k+1,l-1
7719 cgrad        do ll=1,3
7720 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7721 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7722 cgrad        enddo
7723 cgrad      enddo
7724 c1112  continue
7725 cgrad      do m=i+2,j2
7726 cgrad        do ll=1,3
7727 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7728 cgrad        enddo
7729 cgrad      enddo
7730 cgrad      do m=k+2,l2
7731 cgrad        do ll=1,3
7732 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7733 cgrad        enddo
7734 cgrad      enddo
7735 cd      do iii=1,nres-3
7736 cd        write (2,*) iii,g_corr5_loc(iii)
7737 cd      enddo
7738       eello5=ekont*eel5
7739 cd      write (2,*) 'ekont',ekont
7740 cd      write (iout,*) 'eello5',ekont*eel5
7741       return
7742       end
7743 c--------------------------------------------------------------------------
7744       double precision function eello6(i,j,k,l,jj,kk)
7745       implicit real*8 (a-h,o-z)
7746       include 'DIMENSIONS'
7747       include 'COMMON.IOUNITS'
7748       include 'COMMON.CHAIN'
7749       include 'COMMON.DERIV'
7750       include 'COMMON.INTERACT'
7751       include 'COMMON.CONTACTS'
7752       include 'COMMON.TORSION'
7753       include 'COMMON.VAR'
7754       include 'COMMON.GEO'
7755       include 'COMMON.FFIELD'
7756       double precision ggg1(3),ggg2(3)
7757 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7758 cd        eello6=0.0d0
7759 cd        return
7760 cd      endif
7761 cd      write (iout,*)
7762 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7763 cd     &   ' and',k,l
7764       eello6_1=0.0d0
7765       eello6_2=0.0d0
7766       eello6_3=0.0d0
7767       eello6_4=0.0d0
7768       eello6_5=0.0d0
7769       eello6_6=0.0d0
7770 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7771 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7772       do iii=1,2
7773         do kkk=1,5
7774           do lll=1,3
7775             derx(lll,kkk,iii)=0.0d0
7776           enddo
7777         enddo
7778       enddo
7779 cd      eij=facont_hb(jj,i)
7780 cd      ekl=facont_hb(kk,k)
7781 cd      ekont=eij*ekl
7782 cd      eij=1.0d0
7783 cd      ekl=1.0d0
7784 cd      ekont=1.0d0
7785       if (l.eq.j+1) then
7786         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7787         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7788         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7789         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7790         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7791         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7792       else
7793         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7794         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7795         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7796         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7797         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7798           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7799         else
7800           eello6_5=0.0d0
7801         endif
7802         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7803       endif
7804 C If turn contributions are considered, they will be handled separately.
7805       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7806 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7807 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7808 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7809 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7810 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7811 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7812 cd      goto 1112
7813       if (j.lt.nres-1) then
7814         j1=j+1
7815         j2=j-1
7816       else
7817         j1=j-1
7818         j2=j-2
7819       endif
7820       if (l.lt.nres-1) then
7821         l1=l+1
7822         l2=l-1
7823       else
7824         l1=l-1
7825         l2=l-2
7826       endif
7827       do ll=1,3
7828 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7829 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7830 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7831 cgrad        ghalf=0.5d0*ggg1(ll)
7832 cd        ghalf=0.0d0
7833         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7834         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7835         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7836         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7837         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7838         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7839         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7840         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7841 cgrad        ghalf=0.5d0*ggg2(ll)
7842 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7843 cd        ghalf=0.0d0
7844         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7845         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7846         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7847         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7848         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7849         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7850       enddo
7851 cd      goto 1112
7852 cgrad      do m=i+1,j-1
7853 cgrad        do ll=1,3
7854 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7855 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7856 cgrad        enddo
7857 cgrad      enddo
7858 cgrad      do m=k+1,l-1
7859 cgrad        do ll=1,3
7860 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7861 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7862 cgrad        enddo
7863 cgrad      enddo
7864 cgrad1112  continue
7865 cgrad      do m=i+2,j2
7866 cgrad        do ll=1,3
7867 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7868 cgrad        enddo
7869 cgrad      enddo
7870 cgrad      do m=k+2,l2
7871 cgrad        do ll=1,3
7872 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7873 cgrad        enddo
7874 cgrad      enddo
7875 cd      do iii=1,nres-3
7876 cd        write (2,*) iii,g_corr6_loc(iii)
7877 cd      enddo
7878       eello6=ekont*eel6
7879 cd      write (2,*) 'ekont',ekont
7880 cd      write (iout,*) 'eello6',ekont*eel6
7881       return
7882       end
7883 c--------------------------------------------------------------------------
7884       double precision function eello6_graph1(i,j,k,l,imat,swap)
7885       implicit real*8 (a-h,o-z)
7886       include 'DIMENSIONS'
7887       include 'COMMON.IOUNITS'
7888       include 'COMMON.CHAIN'
7889       include 'COMMON.DERIV'
7890       include 'COMMON.INTERACT'
7891       include 'COMMON.CONTACTS'
7892       include 'COMMON.TORSION'
7893       include 'COMMON.VAR'
7894       include 'COMMON.GEO'
7895       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7896       logical swap
7897       logical lprn
7898       common /kutas/ lprn
7899 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7900 C                                                                              C
7901 C      Parallel       Antiparallel                                             C
7902 C                                                                              C
7903 C          o             o                                                     C
7904 C         /l\           /j\                                                    C
7905 C        /   \         /   \                                                   C
7906 C       /| o |         | o |\                                                  C
7907 C     \ j|/k\|  /   \  |/k\|l /                                                C
7908 C      \ /   \ /     \ /   \ /                                                 C
7909 C       o     o       o     o                                                  C
7910 C       i             i                                                        C
7911 C                                                                              C
7912 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7913       itk=itortyp(itype(k))
7914       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7915       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7916       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7917       call transpose2(EUgC(1,1,k),auxmat(1,1))
7918       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7919       vv1(1)=pizda1(1,1)-pizda1(2,2)
7920       vv1(2)=pizda1(1,2)+pizda1(2,1)
7921       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7922       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7923       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7924       s5=scalar2(vv(1),Dtobr2(1,i))
7925 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7926       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7927       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7928      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7929      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7930      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7931      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7932      & +scalar2(vv(1),Dtobr2der(1,i)))
7933       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7934       vv1(1)=pizda1(1,1)-pizda1(2,2)
7935       vv1(2)=pizda1(1,2)+pizda1(2,1)
7936       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7937       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7938       if (l.eq.j+1) then
7939         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7940      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7941      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7942      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7943      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7944       else
7945         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7946      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7947      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7948      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7949      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7950       endif
7951       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7952       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7953       vv1(1)=pizda1(1,1)-pizda1(2,2)
7954       vv1(2)=pizda1(1,2)+pizda1(2,1)
7955       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7956      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7957      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7958      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7959       do iii=1,2
7960         if (swap) then
7961           ind=3-iii
7962         else
7963           ind=iii
7964         endif
7965         do kkk=1,5
7966           do lll=1,3
7967             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7968             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7969             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7970             call transpose2(EUgC(1,1,k),auxmat(1,1))
7971             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7972      &        pizda1(1,1))
7973             vv1(1)=pizda1(1,1)-pizda1(2,2)
7974             vv1(2)=pizda1(1,2)+pizda1(2,1)
7975             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7976             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7977      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7978             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7979      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7980             s5=scalar2(vv(1),Dtobr2(1,i))
7981             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7982           enddo
7983         enddo
7984       enddo
7985       return
7986       end
7987 c----------------------------------------------------------------------------
7988       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7989       implicit real*8 (a-h,o-z)
7990       include 'DIMENSIONS'
7991       include 'COMMON.IOUNITS'
7992       include 'COMMON.CHAIN'
7993       include 'COMMON.DERIV'
7994       include 'COMMON.INTERACT'
7995       include 'COMMON.CONTACTS'
7996       include 'COMMON.TORSION'
7997       include 'COMMON.VAR'
7998       include 'COMMON.GEO'
7999       logical swap
8000       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8001      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8002       logical lprn
8003       common /kutas/ lprn
8004 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8005 C                                                                              C
8006 C      Parallel       Antiparallel                                             C
8007 C                                                                              C
8008 C          o             o                                                     C
8009 C     \   /l\           /j\   /                                                C
8010 C      \ /   \         /   \ /                                                 C
8011 C       o| o |         | o |o                                                  C
8012 C     \ j|/k\|      \  |/k\|l                                                  C
8013 C      \ /   \       \ /   \                                                   C
8014 C       o             o                                                        C
8015 C       i             i                                                        C
8016 C                                                                              C
8017 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8018 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8019 C AL 7/4/01 s1 would occur in the sixth-order moment,
8020 C           but not in a cluster cumulant
8021 #ifdef MOMENT
8022       s1=dip(1,jj,i)*dip(1,kk,k)
8023 #endif
8024       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8025       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8026       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8027       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8028       call transpose2(EUg(1,1,k),auxmat(1,1))
8029       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8030       vv(1)=pizda(1,1)-pizda(2,2)
8031       vv(2)=pizda(1,2)+pizda(2,1)
8032       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8033 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8034 #ifdef MOMENT
8035       eello6_graph2=-(s1+s2+s3+s4)
8036 #else
8037       eello6_graph2=-(s2+s3+s4)
8038 #endif
8039 c      eello6_graph2=-s3
8040 C Derivatives in gamma(i-1)
8041       if (i.gt.1) then
8042 #ifdef MOMENT
8043         s1=dipderg(1,jj,i)*dip(1,kk,k)
8044 #endif
8045         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8046         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8047         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8048         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8049 #ifdef MOMENT
8050         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8051 #else
8052         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8053 #endif
8054 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8055       endif
8056 C Derivatives in gamma(k-1)
8057 #ifdef MOMENT
8058       s1=dip(1,jj,i)*dipderg(1,kk,k)
8059 #endif
8060       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8061       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8062       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8063       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8064       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8065       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8066       vv(1)=pizda(1,1)-pizda(2,2)
8067       vv(2)=pizda(1,2)+pizda(2,1)
8068       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8069 #ifdef MOMENT
8070       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8071 #else
8072       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8073 #endif
8074 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8075 C Derivatives in gamma(j-1) or gamma(l-1)
8076       if (j.gt.1) then
8077 #ifdef MOMENT
8078         s1=dipderg(3,jj,i)*dip(1,kk,k)
8079 #endif
8080         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8081         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8082         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8083         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8084         vv(1)=pizda(1,1)-pizda(2,2)
8085         vv(2)=pizda(1,2)+pizda(2,1)
8086         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8087 #ifdef MOMENT
8088         if (swap) then
8089           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8090         else
8091           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8092         endif
8093 #endif
8094         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8095 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8096       endif
8097 C Derivatives in gamma(l-1) or gamma(j-1)
8098       if (l.gt.1) then
8099 #ifdef MOMENT
8100         s1=dip(1,jj,i)*dipderg(3,kk,k)
8101 #endif
8102         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8103         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8104         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8105         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8106         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8107         vv(1)=pizda(1,1)-pizda(2,2)
8108         vv(2)=pizda(1,2)+pizda(2,1)
8109         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8110 #ifdef MOMENT
8111         if (swap) then
8112           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8113         else
8114           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8115         endif
8116 #endif
8117         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8118 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8119       endif
8120 C Cartesian derivatives.
8121       if (lprn) then
8122         write (2,*) 'In eello6_graph2'
8123         do iii=1,2
8124           write (2,*) 'iii=',iii
8125           do kkk=1,5
8126             write (2,*) 'kkk=',kkk
8127             do jjj=1,2
8128               write (2,'(3(2f10.5),5x)')
8129      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8130             enddo
8131           enddo
8132         enddo
8133       endif
8134       do iii=1,2
8135         do kkk=1,5
8136           do lll=1,3
8137 #ifdef MOMENT
8138             if (iii.eq.1) then
8139               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8140             else
8141               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8142             endif
8143 #endif
8144             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8145      &        auxvec(1))
8146             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8147             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8148      &        auxvec(1))
8149             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8150             call transpose2(EUg(1,1,k),auxmat(1,1))
8151             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8152      &        pizda(1,1))
8153             vv(1)=pizda(1,1)-pizda(2,2)
8154             vv(2)=pizda(1,2)+pizda(2,1)
8155             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8156 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8157 #ifdef MOMENT
8158             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8159 #else
8160             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8161 #endif
8162             if (swap) then
8163               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8164             else
8165               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8166             endif
8167           enddo
8168         enddo
8169       enddo
8170       return
8171       end
8172 c----------------------------------------------------------------------------
8173       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8174       implicit real*8 (a-h,o-z)
8175       include 'DIMENSIONS'
8176       include 'COMMON.IOUNITS'
8177       include 'COMMON.CHAIN'
8178       include 'COMMON.DERIV'
8179       include 'COMMON.INTERACT'
8180       include 'COMMON.CONTACTS'
8181       include 'COMMON.TORSION'
8182       include 'COMMON.VAR'
8183       include 'COMMON.GEO'
8184       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8185       logical swap
8186 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8187 C                                                                              C
8188 C      Parallel       Antiparallel                                             C
8189 C                                                                              C
8190 C          o             o                                                     C
8191 C         /l\   /   \   /j\                                                    C
8192 C        /   \ /     \ /   \                                                   C
8193 C       /| o |o       o| o |\                                                  C
8194 C       j|/k\|  /      |/k\|l /                                                C
8195 C        /   \ /       /   \ /                                                 C
8196 C       /     o       /     o                                                  C
8197 C       i             i                                                        C
8198 C                                                                              C
8199 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8200 C
8201 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8202 C           energy moment and not to the cluster cumulant.
8203       iti=itortyp(itype(i))
8204       if (j.lt.nres-1) then
8205         itj1=itortyp(itype(j+1))
8206       else
8207         itj1=ntortyp+1
8208       endif
8209       itk=itortyp(itype(k))
8210       itk1=itortyp(itype(k+1))
8211       if (l.lt.nres-1) then
8212         itl1=itortyp(itype(l+1))
8213       else
8214         itl1=ntortyp+1
8215       endif
8216 #ifdef MOMENT
8217       s1=dip(4,jj,i)*dip(4,kk,k)
8218 #endif
8219       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8220       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8221       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8222       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8223       call transpose2(EE(1,1,itk),auxmat(1,1))
8224       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8225       vv(1)=pizda(1,1)+pizda(2,2)
8226       vv(2)=pizda(2,1)-pizda(1,2)
8227       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8228 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8229 cd     & "sum",-(s2+s3+s4)
8230 #ifdef MOMENT
8231       eello6_graph3=-(s1+s2+s3+s4)
8232 #else
8233       eello6_graph3=-(s2+s3+s4)
8234 #endif
8235 c      eello6_graph3=-s4
8236 C Derivatives in gamma(k-1)
8237       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8238       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8239       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8240       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8241 C Derivatives in gamma(l-1)
8242       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8243       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8244       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8245       vv(1)=pizda(1,1)+pizda(2,2)
8246       vv(2)=pizda(2,1)-pizda(1,2)
8247       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8248       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8249 C Cartesian derivatives.
8250       do iii=1,2
8251         do kkk=1,5
8252           do lll=1,3
8253 #ifdef MOMENT
8254             if (iii.eq.1) then
8255               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8256             else
8257               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8258             endif
8259 #endif
8260             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8261      &        auxvec(1))
8262             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8263             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8264      &        auxvec(1))
8265             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8266             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8267      &        pizda(1,1))
8268             vv(1)=pizda(1,1)+pizda(2,2)
8269             vv(2)=pizda(2,1)-pizda(1,2)
8270             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8271 #ifdef MOMENT
8272             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8273 #else
8274             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8275 #endif
8276             if (swap) then
8277               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8278             else
8279               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8280             endif
8281 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8282           enddo
8283         enddo
8284       enddo
8285       return
8286       end
8287 c----------------------------------------------------------------------------
8288       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8289       implicit real*8 (a-h,o-z)
8290       include 'DIMENSIONS'
8291       include 'COMMON.IOUNITS'
8292       include 'COMMON.CHAIN'
8293       include 'COMMON.DERIV'
8294       include 'COMMON.INTERACT'
8295       include 'COMMON.CONTACTS'
8296       include 'COMMON.TORSION'
8297       include 'COMMON.VAR'
8298       include 'COMMON.GEO'
8299       include 'COMMON.FFIELD'
8300       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8301      & auxvec1(2),auxmat1(2,2)
8302       logical swap
8303 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8304 C                                                                              C
8305 C      Parallel       Antiparallel                                             C
8306 C                                                                              C
8307 C          o             o                                                     C
8308 C         /l\   /   \   /j\                                                    C
8309 C        /   \ /     \ /   \                                                   C
8310 C       /| o |o       o| o |\                                                  C
8311 C     \ j|/k\|      \  |/k\|l                                                  C
8312 C      \ /   \       \ /   \                                                   C
8313 C       o     \       o     \                                                  C
8314 C       i             i                                                        C
8315 C                                                                              C
8316 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8317 C
8318 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8319 C           energy moment and not to the cluster cumulant.
8320 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8321       iti=itortyp(itype(i))
8322       itj=itortyp(itype(j))
8323       if (j.lt.nres-1) then
8324         itj1=itortyp(itype(j+1))
8325       else
8326         itj1=ntortyp+1
8327       endif
8328       itk=itortyp(itype(k))
8329       if (k.lt.nres-1) then
8330         itk1=itortyp(itype(k+1))
8331       else
8332         itk1=ntortyp+1
8333       endif
8334       itl=itortyp(itype(l))
8335       if (l.lt.nres-1) then
8336         itl1=itortyp(itype(l+1))
8337       else
8338         itl1=ntortyp+1
8339       endif
8340 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8341 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8342 cd     & ' itl',itl,' itl1',itl1
8343 #ifdef MOMENT
8344       if (imat.eq.1) then
8345         s1=dip(3,jj,i)*dip(3,kk,k)
8346       else
8347         s1=dip(2,jj,j)*dip(2,kk,l)
8348       endif
8349 #endif
8350       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8351       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8352       if (j.eq.l+1) then
8353         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8354         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8355       else
8356         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8357         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8358       endif
8359       call transpose2(EUg(1,1,k),auxmat(1,1))
8360       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8361       vv(1)=pizda(1,1)-pizda(2,2)
8362       vv(2)=pizda(2,1)+pizda(1,2)
8363       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8364 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8365 #ifdef MOMENT
8366       eello6_graph4=-(s1+s2+s3+s4)
8367 #else
8368       eello6_graph4=-(s2+s3+s4)
8369 #endif
8370 C Derivatives in gamma(i-1)
8371       if (i.gt.1) then
8372 #ifdef MOMENT
8373         if (imat.eq.1) then
8374           s1=dipderg(2,jj,i)*dip(3,kk,k)
8375         else
8376           s1=dipderg(4,jj,j)*dip(2,kk,l)
8377         endif
8378 #endif
8379         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8380         if (j.eq.l+1) then
8381           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8382           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8383         else
8384           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8385           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8386         endif
8387         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8388         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8389 cd          write (2,*) 'turn6 derivatives'
8390 #ifdef MOMENT
8391           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8392 #else
8393           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8394 #endif
8395         else
8396 #ifdef MOMENT
8397           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8398 #else
8399           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8400 #endif
8401         endif
8402       endif
8403 C Derivatives in gamma(k-1)
8404 #ifdef MOMENT
8405       if (imat.eq.1) then
8406         s1=dip(3,jj,i)*dipderg(2,kk,k)
8407       else
8408         s1=dip(2,jj,j)*dipderg(4,kk,l)
8409       endif
8410 #endif
8411       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8412       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8413       if (j.eq.l+1) then
8414         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8415         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8416       else
8417         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8418         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8419       endif
8420       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8421       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8422       vv(1)=pizda(1,1)-pizda(2,2)
8423       vv(2)=pizda(2,1)+pizda(1,2)
8424       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8425       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8426 #ifdef MOMENT
8427         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8428 #else
8429         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8430 #endif
8431       else
8432 #ifdef MOMENT
8433         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8434 #else
8435         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8436 #endif
8437       endif
8438 C Derivatives in gamma(j-1) or gamma(l-1)
8439       if (l.eq.j+1 .and. l.gt.1) then
8440         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8441         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8442         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8443         vv(1)=pizda(1,1)-pizda(2,2)
8444         vv(2)=pizda(2,1)+pizda(1,2)
8445         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8446         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8447       else if (j.gt.1) then
8448         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8449         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8450         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8451         vv(1)=pizda(1,1)-pizda(2,2)
8452         vv(2)=pizda(2,1)+pizda(1,2)
8453         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8454         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8455           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8456         else
8457           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8458         endif
8459       endif
8460 C Cartesian derivatives.
8461       do iii=1,2
8462         do kkk=1,5
8463           do lll=1,3
8464 #ifdef MOMENT
8465             if (iii.eq.1) then
8466               if (imat.eq.1) then
8467                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8468               else
8469                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8470               endif
8471             else
8472               if (imat.eq.1) then
8473                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8474               else
8475                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8476               endif
8477             endif
8478 #endif
8479             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8480      &        auxvec(1))
8481             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8482             if (j.eq.l+1) then
8483               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8484      &          b1(1,itj1),auxvec(1))
8485               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8486             else
8487               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8488      &          b1(1,itl1),auxvec(1))
8489               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8490             endif
8491             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8492      &        pizda(1,1))
8493             vv(1)=pizda(1,1)-pizda(2,2)
8494             vv(2)=pizda(2,1)+pizda(1,2)
8495             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8496             if (swap) then
8497               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8498 #ifdef MOMENT
8499                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8500      &             -(s1+s2+s4)
8501 #else
8502                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8503      &             -(s2+s4)
8504 #endif
8505                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8506               else
8507 #ifdef MOMENT
8508                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8509 #else
8510                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8511 #endif
8512                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8513               endif
8514             else
8515 #ifdef MOMENT
8516               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8517 #else
8518               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8519 #endif
8520               if (l.eq.j+1) then
8521                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8522               else
8523                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8524               endif
8525             endif
8526           enddo
8527         enddo
8528       enddo
8529       return
8530       end
8531 c----------------------------------------------------------------------------
8532       double precision function eello_turn6(i,jj,kk)
8533       implicit real*8 (a-h,o-z)
8534       include 'DIMENSIONS'
8535       include 'COMMON.IOUNITS'
8536       include 'COMMON.CHAIN'
8537       include 'COMMON.DERIV'
8538       include 'COMMON.INTERACT'
8539       include 'COMMON.CONTACTS'
8540       include 'COMMON.TORSION'
8541       include 'COMMON.VAR'
8542       include 'COMMON.GEO'
8543       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8544      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8545      &  ggg1(3),ggg2(3)
8546       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8547      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8548 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8549 C           the respective energy moment and not to the cluster cumulant.
8550       s1=0.0d0
8551       s8=0.0d0
8552       s13=0.0d0
8553 c
8554       eello_turn6=0.0d0
8555       j=i+4
8556       k=i+1
8557       l=i+3
8558       iti=itortyp(itype(i))
8559       itk=itortyp(itype(k))
8560       itk1=itortyp(itype(k+1))
8561       itl=itortyp(itype(l))
8562       itj=itortyp(itype(j))
8563 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8564 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8565 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8566 cd        eello6=0.0d0
8567 cd        return
8568 cd      endif
8569 cd      write (iout,*)
8570 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8571 cd     &   ' and',k,l
8572 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8573       do iii=1,2
8574         do kkk=1,5
8575           do lll=1,3
8576             derx_turn(lll,kkk,iii)=0.0d0
8577           enddo
8578         enddo
8579       enddo
8580 cd      eij=1.0d0
8581 cd      ekl=1.0d0
8582 cd      ekont=1.0d0
8583       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8584 cd      eello6_5=0.0d0
8585 cd      write (2,*) 'eello6_5',eello6_5
8586 #ifdef MOMENT
8587       call transpose2(AEA(1,1,1),auxmat(1,1))
8588       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8589       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8590       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8591 #endif
8592       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8593       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8594       s2 = scalar2(b1(1,itk),vtemp1(1))
8595 #ifdef MOMENT
8596       call transpose2(AEA(1,1,2),atemp(1,1))
8597       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8598       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8599       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8600 #endif
8601       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8602       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8603       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8604 #ifdef MOMENT
8605       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8606       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8607       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8608       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8609       ss13 = scalar2(b1(1,itk),vtemp4(1))
8610       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8611 #endif
8612 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8613 c      s1=0.0d0
8614 c      s2=0.0d0
8615 c      s8=0.0d0
8616 c      s12=0.0d0
8617 c      s13=0.0d0
8618       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8619 C Derivatives in gamma(i+2)
8620       s1d =0.0d0
8621       s8d =0.0d0
8622 #ifdef MOMENT
8623       call transpose2(AEA(1,1,1),auxmatd(1,1))
8624       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8625       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8626       call transpose2(AEAderg(1,1,2),atempd(1,1))
8627       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8628       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8629 #endif
8630       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8631       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8632       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8633 c      s1d=0.0d0
8634 c      s2d=0.0d0
8635 c      s8d=0.0d0
8636 c      s12d=0.0d0
8637 c      s13d=0.0d0
8638       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8639 C Derivatives in gamma(i+3)
8640 #ifdef MOMENT
8641       call transpose2(AEA(1,1,1),auxmatd(1,1))
8642       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8643       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8644       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8645 #endif
8646       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8647       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8648       s2d = scalar2(b1(1,itk),vtemp1d(1))
8649 #ifdef MOMENT
8650       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8651       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8652 #endif
8653       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8654 #ifdef MOMENT
8655       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8656       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8657       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8658 #endif
8659 c      s1d=0.0d0
8660 c      s2d=0.0d0
8661 c      s8d=0.0d0
8662 c      s12d=0.0d0
8663 c      s13d=0.0d0
8664 #ifdef MOMENT
8665       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8666      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8667 #else
8668       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8669      &               -0.5d0*ekont*(s2d+s12d)
8670 #endif
8671 C Derivatives in gamma(i+4)
8672       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8673       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8674       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8675 #ifdef MOMENT
8676       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8677       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8678       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8679 #endif
8680 c      s1d=0.0d0
8681 c      s2d=0.0d0
8682 c      s8d=0.0d0
8683 C      s12d=0.0d0
8684 c      s13d=0.0d0
8685 #ifdef MOMENT
8686       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8687 #else
8688       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8689 #endif
8690 C Derivatives in gamma(i+5)
8691 #ifdef MOMENT
8692       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8693       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8694       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8695 #endif
8696       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8697       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8698       s2d = scalar2(b1(1,itk),vtemp1d(1))
8699 #ifdef MOMENT
8700       call transpose2(AEA(1,1,2),atempd(1,1))
8701       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8702       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8703 #endif
8704       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8705       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8706 #ifdef MOMENT
8707       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8708       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8709       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8710 #endif
8711 c      s1d=0.0d0
8712 c      s2d=0.0d0
8713 c      s8d=0.0d0
8714 c      s12d=0.0d0
8715 c      s13d=0.0d0
8716 #ifdef MOMENT
8717       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8718      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8719 #else
8720       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8721      &               -0.5d0*ekont*(s2d+s12d)
8722 #endif
8723 C Cartesian derivatives
8724       do iii=1,2
8725         do kkk=1,5
8726           do lll=1,3
8727 #ifdef MOMENT
8728             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8729             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8730             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8731 #endif
8732             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8733             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8734      &          vtemp1d(1))
8735             s2d = scalar2(b1(1,itk),vtemp1d(1))
8736 #ifdef MOMENT
8737             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8738             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8739             s8d = -(atempd(1,1)+atempd(2,2))*
8740      &           scalar2(cc(1,1,itl),vtemp2(1))
8741 #endif
8742             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8743      &           auxmatd(1,1))
8744             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8745             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8746 c      s1d=0.0d0
8747 c      s2d=0.0d0
8748 c      s8d=0.0d0
8749 c      s12d=0.0d0
8750 c      s13d=0.0d0
8751 #ifdef MOMENT
8752             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8753      &        - 0.5d0*(s1d+s2d)
8754 #else
8755             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8756      &        - 0.5d0*s2d
8757 #endif
8758 #ifdef MOMENT
8759             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8760      &        - 0.5d0*(s8d+s12d)
8761 #else
8762             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8763      &        - 0.5d0*s12d
8764 #endif
8765           enddo
8766         enddo
8767       enddo
8768 #ifdef MOMENT
8769       do kkk=1,5
8770         do lll=1,3
8771           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8772      &      achuj_tempd(1,1))
8773           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8774           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8775           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8776           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8777           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8778      &      vtemp4d(1))
8779           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8780           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8781           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8782         enddo
8783       enddo
8784 #endif
8785 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8786 cd     &  16*eel_turn6_num
8787 cd      goto 1112
8788       if (j.lt.nres-1) then
8789         j1=j+1
8790         j2=j-1
8791       else
8792         j1=j-1
8793         j2=j-2
8794       endif
8795       if (l.lt.nres-1) then
8796         l1=l+1
8797         l2=l-1
8798       else
8799         l1=l-1
8800         l2=l-2
8801       endif
8802       do ll=1,3
8803 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8804 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8805 cgrad        ghalf=0.5d0*ggg1(ll)
8806 cd        ghalf=0.0d0
8807         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8808         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8809         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8810      &    +ekont*derx_turn(ll,2,1)
8811         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8812         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8813      &    +ekont*derx_turn(ll,4,1)
8814         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8815         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8816         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8817 cgrad        ghalf=0.5d0*ggg2(ll)
8818 cd        ghalf=0.0d0
8819         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8820      &    +ekont*derx_turn(ll,2,2)
8821         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8822         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8823      &    +ekont*derx_turn(ll,4,2)
8824         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8825         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8826         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8827       enddo
8828 cd      goto 1112
8829 cgrad      do m=i+1,j-1
8830 cgrad        do ll=1,3
8831 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8832 cgrad        enddo
8833 cgrad      enddo
8834 cgrad      do m=k+1,l-1
8835 cgrad        do ll=1,3
8836 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8837 cgrad        enddo
8838 cgrad      enddo
8839 cgrad1112  continue
8840 cgrad      do m=i+2,j2
8841 cgrad        do ll=1,3
8842 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8843 cgrad        enddo
8844 cgrad      enddo
8845 cgrad      do m=k+2,l2
8846 cgrad        do ll=1,3
8847 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8848 cgrad        enddo
8849 cgrad      enddo
8850 cd      do iii=1,nres-3
8851 cd        write (2,*) iii,g_corr6_loc(iii)
8852 cd      enddo
8853       eello_turn6=ekont*eel_turn6
8854 cd      write (2,*) 'ekont',ekont
8855 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8856       return
8857       end
8858
8859 C-----------------------------------------------------------------------------
8860       double precision function scalar(u,v)
8861 !DIR$ INLINEALWAYS scalar
8862 #ifndef OSF
8863 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8864 #endif
8865       implicit none
8866       double precision u(3),v(3)
8867 cd      double precision sc
8868 cd      integer i
8869 cd      sc=0.0d0
8870 cd      do i=1,3
8871 cd        sc=sc+u(i)*v(i)
8872 cd      enddo
8873 cd      scalar=sc
8874
8875       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8876       return
8877       end
8878 crc-------------------------------------------------
8879       SUBROUTINE MATVEC2(A1,V1,V2)
8880 !DIR$ INLINEALWAYS MATVEC2
8881 #ifndef OSF
8882 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8883 #endif
8884       implicit real*8 (a-h,o-z)
8885       include 'DIMENSIONS'
8886       DIMENSION A1(2,2),V1(2),V2(2)
8887 c      DO 1 I=1,2
8888 c        VI=0.0
8889 c        DO 3 K=1,2
8890 c    3     VI=VI+A1(I,K)*V1(K)
8891 c        Vaux(I)=VI
8892 c    1 CONTINUE
8893
8894       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8895       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8896
8897       v2(1)=vaux1
8898       v2(2)=vaux2
8899       END
8900 C---------------------------------------
8901       SUBROUTINE MATMAT2(A1,A2,A3)
8902 #ifndef OSF
8903 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8904 #endif
8905       implicit real*8 (a-h,o-z)
8906       include 'DIMENSIONS'
8907       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8908 c      DIMENSION AI3(2,2)
8909 c        DO  J=1,2
8910 c          A3IJ=0.0
8911 c          DO K=1,2
8912 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8913 c          enddo
8914 c          A3(I,J)=A3IJ
8915 c       enddo
8916 c      enddo
8917
8918       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8919       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8920       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8921       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8922
8923       A3(1,1)=AI3_11
8924       A3(2,1)=AI3_21
8925       A3(1,2)=AI3_12
8926       A3(2,2)=AI3_22
8927       END
8928
8929 c-------------------------------------------------------------------------
8930       double precision function scalar2(u,v)
8931 !DIR$ INLINEALWAYS scalar2
8932       implicit none
8933       double precision u(2),v(2)
8934       double precision sc
8935       integer i
8936       scalar2=u(1)*v(1)+u(2)*v(2)
8937       return
8938       end
8939
8940 C-----------------------------------------------------------------------------
8941
8942       subroutine transpose2(a,at)
8943 !DIR$ INLINEALWAYS transpose2
8944 #ifndef OSF
8945 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8946 #endif
8947       implicit none
8948       double precision a(2,2),at(2,2)
8949       at(1,1)=a(1,1)
8950       at(1,2)=a(2,1)
8951       at(2,1)=a(1,2)
8952       at(2,2)=a(2,2)
8953       return
8954       end
8955 c--------------------------------------------------------------------------
8956       subroutine transpose(n,a,at)
8957       implicit none
8958       integer n,i,j
8959       double precision a(n,n),at(n,n)
8960       do i=1,n
8961         do j=1,n
8962           at(j,i)=a(i,j)
8963         enddo
8964       enddo
8965       return
8966       end
8967 C---------------------------------------------------------------------------
8968       subroutine prodmat3(a1,a2,kk,transp,prod)
8969 !DIR$ INLINEALWAYS prodmat3
8970 #ifndef OSF
8971 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8972 #endif
8973       implicit none
8974       integer i,j
8975       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8976       logical transp
8977 crc      double precision auxmat(2,2),prod_(2,2)
8978
8979       if (transp) then
8980 crc        call transpose2(kk(1,1),auxmat(1,1))
8981 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8982 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8983
8984            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8985      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8986            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8987      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8988            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8989      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8990            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8991      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8992
8993       else
8994 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8995 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8996
8997            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8998      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8999            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9000      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9001            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9002      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9003            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9004      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9005
9006       endif
9007 c      call transpose2(a2(1,1),a2t(1,1))
9008
9009 crc      print *,transp
9010 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9011 crc      print *,((prod(i,j),i=1,2),j=1,2)
9012
9013       return
9014       end
9015