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),i-2
2399 cd        write (iout,*) 'b1  ',b1(:,iti1),i-2
2400 cd        write (iout,*) 'Ub2 ',Ub2(:,i-2),i-2
2401 cd        write (iout,*) 'Ug  ',Ug(:,:,i-2),i-2
2402 cd        write (iout,*) 'b2  ',b2(:,itortyp(itype(i))),i-2
2403 cd        write (iout,*) 'mu1',mu1(:,i-2)
2404 cd        write (iout,*) 'mu2',mu2(:,i-2)
2405         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2406      &  then
2407         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2408         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2409         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2410         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2411         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2412 C Vectors and matrices dependent on a single virtual-bond dihedral.
2413         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2414         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2415         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2416         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2417         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2418         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2419         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2420         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2421         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2422         endif
2423       enddo
2424 C Matrices dependent on two consecutive virtual-bond dihedrals.
2425 C The order of matrices is from left to right.
2426       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2427      &then
2428 c      do i=max0(ivec_start,2),ivec_end
2429       do i=2,nres-1
2430         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2431         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2432         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2433         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2434         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2435         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2436         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2437         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2438       enddo
2439       endif
2440 #if defined(MPI) && defined(PARMAT)
2441 #ifdef DEBUG
2442 c      if (fg_rank.eq.0) then
2443         write (iout,*) "Arrays UG and UGDER before GATHER"
2444         do i=1,nres-1
2445           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2446      &     ((ug(l,k,i),l=1,2),k=1,2),
2447      &     ((ugder(l,k,i),l=1,2),k=1,2)
2448         enddo
2449         write (iout,*) "Arrays UG2 and UG2DER"
2450         do i=1,nres-1
2451           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2452      &     ((ug2(l,k,i),l=1,2),k=1,2),
2453      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2454         enddo
2455         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2456         do i=1,nres-1
2457           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2458      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2459      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2460         enddo
2461         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2462         do i=1,nres-1
2463           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2464      &     costab(i),sintab(i),costab2(i),sintab2(i)
2465         enddo
2466         write (iout,*) "Array MUDER"
2467         do i=1,nres-1
2468           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2469         enddo
2470 c      endif
2471 #endif
2472       if (nfgtasks.gt.1) then
2473         time00=MPI_Wtime()
2474 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2475 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2476 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2477 #ifdef MATGATHER
2478         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2479      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2480      &   FG_COMM1,IERR)
2481         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2482      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2483      &   FG_COMM1,IERR)
2484         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2485      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2486      &   FG_COMM1,IERR)
2487         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2488      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2489      &   FG_COMM1,IERR)
2490         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2491      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2492      &   FG_COMM1,IERR)
2493         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2494      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2495      &   FG_COMM1,IERR)
2496         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2497      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2498      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2499         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2500      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2501      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2502         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2503      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2504      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2505         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2506      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2507      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2508         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2509      &  then
2510         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2514      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2515      &   FG_COMM1,IERR)
2516         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2517      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2518      &   FG_COMM1,IERR)
2519        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2523      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2524      &   FG_COMM1,IERR)
2525         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2526      &   ivec_count(fg_rank1),
2527      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2528      &   FG_COMM1,IERR)
2529         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2530      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2531      &   FG_COMM1,IERR)
2532         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2533      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2534      &   FG_COMM1,IERR)
2535         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2536      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2537      &   FG_COMM1,IERR)
2538         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2539      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2540      &   FG_COMM1,IERR)
2541         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2542      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2543      &   FG_COMM1,IERR)
2544         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2545      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2548      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2549      &   FG_COMM1,IERR)
2550         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2551      &   ivec_count(fg_rank1),
2552      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2553      &   FG_COMM1,IERR)
2554         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2555      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2556      &   FG_COMM1,IERR)
2557        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2558      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2559      &   FG_COMM1,IERR)
2560         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2561      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2562      &   FG_COMM1,IERR)
2563        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2564      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2565      &   FG_COMM1,IERR)
2566         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2567      &   ivec_count(fg_rank1),
2568      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2571      &   ivec_count(fg_rank1),
2572      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2573      &   FG_COMM1,IERR)
2574         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2575      &   ivec_count(fg_rank1),
2576      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2577      &   MPI_MAT2,FG_COMM1,IERR)
2578         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2579      &   ivec_count(fg_rank1),
2580      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2581      &   MPI_MAT2,FG_COMM1,IERR)
2582         endif
2583 #else
2584 c Passes matrix info through the ring
2585       isend=fg_rank1
2586       irecv=fg_rank1-1
2587       if (irecv.lt.0) irecv=nfgtasks1-1
2588       iprev=irecv
2589       inext=fg_rank1+1
2590       if (inext.ge.nfgtasks1) inext=0
2591       do i=1,nfgtasks1-1
2592 c        write (iout,*) "isend",isend," irecv",irecv
2593 c        call flush(iout)
2594         lensend=lentyp(isend)
2595         lenrecv=lentyp(irecv)
2596 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2597 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2598 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2599 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2600 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2601 c        write (iout,*) "Gather ROTAT1"
2602 c        call flush(iout)
2603 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2604 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2605 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2606 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2607 c        write (iout,*) "Gather ROTAT2"
2608 c        call flush(iout)
2609         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2610      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2611      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2612      &   iprev,4400+irecv,FG_COMM,status,IERR)
2613 c        write (iout,*) "Gather ROTAT_OLD"
2614 c        call flush(iout)
2615         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2616      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2617      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2618      &   iprev,5500+irecv,FG_COMM,status,IERR)
2619 c        write (iout,*) "Gather PRECOMP11"
2620 c        call flush(iout)
2621         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2622      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2623      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2624      &   iprev,6600+irecv,FG_COMM,status,IERR)
2625 c        write (iout,*) "Gather PRECOMP12"
2626 c        call flush(iout)
2627         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2628      &  then
2629         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2630      &   MPI_ROTAT2(lensend),inext,7700+isend,
2631      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2632      &   iprev,7700+irecv,FG_COMM,status,IERR)
2633 c        write (iout,*) "Gather PRECOMP21"
2634 c        call flush(iout)
2635         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2636      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2637      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2638      &   iprev,8800+irecv,FG_COMM,status,IERR)
2639 c        write (iout,*) "Gather PRECOMP22"
2640 c        call flush(iout)
2641         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2642      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2643      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2644      &   MPI_PRECOMP23(lenrecv),
2645      &   iprev,9900+irecv,FG_COMM,status,IERR)
2646 c        write (iout,*) "Gather PRECOMP23"
2647 c        call flush(iout)
2648         endif
2649         isend=irecv
2650         irecv=irecv-1
2651         if (irecv.lt.0) irecv=nfgtasks1-1
2652       enddo
2653 #endif
2654         time_gather=time_gather+MPI_Wtime()-time00
2655       endif
2656 #ifdef DEBUG
2657 c      if (fg_rank.eq.0) then
2658         write (iout,*) "Arrays UG and UGDER"
2659         do i=1,nres-1
2660           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2661      &     ((ug(l,k,i),l=1,2),k=1,2),
2662      &     ((ugder(l,k,i),l=1,2),k=1,2)
2663         enddo
2664         write (iout,*) "Arrays UG2 and UG2DER"
2665         do i=1,nres-1
2666           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2667      &     ((ug2(l,k,i),l=1,2),k=1,2),
2668      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2669         enddo
2670         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2671         do i=1,nres-1
2672           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2673      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2674      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2675         enddo
2676         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2677         do i=1,nres-1
2678           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2679      &     costab(i),sintab(i),costab2(i),sintab2(i)
2680         enddo
2681         write (iout,*) "Array MUDER"
2682         do i=1,nres-1
2683           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2684         enddo
2685 c      endif
2686 #endif
2687 #endif
2688 cd      do i=1,nres
2689 cd        iti = itortyp(itype(i))
2690 cd        write (iout,*) i
2691 cd        do j=1,2
2692 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2693 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2694 cd        enddo
2695 cd      enddo
2696       return
2697       end
2698 C--------------------------------------------------------------------------
2699       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2700 C
2701 C This subroutine calculates the average interaction energy and its gradient
2702 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2703 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2704 C The potential depends both on the distance of peptide-group centers and on
2705 C the orientation of the CA-CA virtual bonds.
2706 C
2707       implicit real*8 (a-h,o-z)
2708 #ifdef MPI
2709       include 'mpif.h'
2710 #endif
2711       include 'DIMENSIONS'
2712       include 'COMMON.CONTROL'
2713       include 'COMMON.SETUP'
2714       include 'COMMON.IOUNITS'
2715       include 'COMMON.GEO'
2716       include 'COMMON.VAR'
2717       include 'COMMON.LOCAL'
2718       include 'COMMON.CHAIN'
2719       include 'COMMON.DERIV'
2720       include 'COMMON.INTERACT'
2721       include 'COMMON.CONTACTS'
2722       include 'COMMON.TORSION'
2723       include 'COMMON.VECTORS'
2724       include 'COMMON.FFIELD'
2725       include 'COMMON.TIME1'
2726       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2727      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2728       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2729      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),eel_loc_ij
2730       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2731      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2732      &    num_conti,j1,j2
2733 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2734 #ifdef MOMENT
2735       double precision scal_el /1.0d0/
2736 #else
2737       double precision scal_el /0.5d0/
2738 #endif
2739 C 12/13/98
2740 C 13-go grudnia roku pamietnego...
2741       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2742      &                   0.0d0,1.0d0,0.0d0,
2743      &                   0.0d0,0.0d0,1.0d0/
2744 cd      write(iout,*) 'In EELEC'
2745 cd      do i=1,nloctyp
2746 cd        write(iout,*) 'Type',i
2747 cd        write(iout,*) 'B1',B1(:,i)
2748 cd        write(iout,*) 'B2',B2(:,i)
2749 cd        write(iout,*) 'CC',CC(:,:,i)
2750 cd        write(iout,*) 'DD',DD(:,:,i)
2751 cd        write(iout,*) 'EE',EE(:,:,i)
2752 cd      enddo
2753 cd      call check_vecgrad
2754 cd      stop
2755       if (icheckgrad.eq.1) then
2756         do i=1,nres-1
2757           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2758           do k=1,3
2759             dc_norm(k,i)=dc(k,i)*fac
2760           enddo
2761 c          write (iout,*) 'i',i,' fac',fac
2762         enddo
2763       endif
2764       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2765      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2766      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2767 c        call vec_and_deriv
2768 #ifdef TIMING
2769         time01=MPI_Wtime()
2770 #endif
2771         call set_matrices
2772 c        write (iout,*) "after set matrices"
2773 #ifdef TIMING
2774         time_mat=time_mat+MPI_Wtime()-time01
2775 #endif
2776       endif
2777 cd      do i=1,nres-1
2778 cd        write (iout,*) 'i=',i
2779 cd        do k=1,3
2780 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2781 cd        enddo
2782 cd        do k=1,3
2783 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2784 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2785 cd        enddo
2786 cd      enddo
2787       t_eelecij=0.0d0
2788       ees=0.0D0
2789       evdw1=0.0D0
2790       eel_loc=0.0d0
2791       eello_turn3=0.0d0
2792       eello_turn4=0.0d0
2793       ind=0
2794       do i=1,nres
2795         num_cont_hb(i)=0
2796       enddo
2797 cd      print '(a)','Enter EELEC'
2798 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2799       do i=1,nres
2800         gel_loc_loc(i)=0.0d0
2801         gcorr_loc(i)=0.0d0
2802       enddo
2803 c
2804 c
2805 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2806 C
2807 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2808 C
2809 c      write(iout,*) "przed turnem3 loop"
2810       do i=iturn3_start,iturn3_end
2811         if (itype(i).eq.21 .or. itype(i+1).eq.21
2812      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2813         dxi=dc(1,i)
2814         dyi=dc(2,i)
2815         dzi=dc(3,i)
2816         dx_normi=dc_norm(1,i)
2817         dy_normi=dc_norm(2,i)
2818         dz_normi=dc_norm(3,i)
2819         xmedi=c(1,i)+0.5d0*dxi
2820         ymedi=c(2,i)+0.5d0*dyi
2821         zmedi=c(3,i)+0.5d0*dzi
2822         num_conti=0
2823         call eelecij(i,i+2,ees,evdw1,eel_loc)
2824         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2825         num_cont_hb(i)=num_conti
2826       enddo
2827       do i=iturn4_start,iturn4_end
2828         if (itype(i).eq.21 .or. itype(i+1).eq.21
2829      &    .or. itype(i+3).eq.21
2830      &    .or. itype(i+4).eq.21) cycle
2831         dxi=dc(1,i)
2832         dyi=dc(2,i)
2833         dzi=dc(3,i)
2834         dx_normi=dc_norm(1,i)
2835         dy_normi=dc_norm(2,i)
2836         dz_normi=dc_norm(3,i)
2837         xmedi=c(1,i)+0.5d0*dxi
2838         ymedi=c(2,i)+0.5d0*dyi
2839         zmedi=c(3,i)+0.5d0*dzi
2840         num_conti=num_cont_hb(i)
2841         call eelecij(i,i+3,ees,evdw1,eel_loc)
2842         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2843      &   call eturn4(i,eello_turn4)
2844         num_cont_hb(i)=num_conti
2845       enddo   ! i
2846 c
2847 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2848 c
2849       do i=iatel_s,iatel_e
2850         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2851         dxi=dc(1,i)
2852         dyi=dc(2,i)
2853         dzi=dc(3,i)
2854         dx_normi=dc_norm(1,i)
2855         dy_normi=dc_norm(2,i)
2856         dz_normi=dc_norm(3,i)
2857         xmedi=c(1,i)+0.5d0*dxi
2858         ymedi=c(2,i)+0.5d0*dyi
2859         zmedi=c(3,i)+0.5d0*dzi
2860 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2861         num_conti=num_cont_hb(i)
2862         do j=ielstart(i),ielend(i)
2863 c          write (iout,*) i,j,itype(i),itype(j)
2864           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2865           call eelecij(i,j,ees,evdw1,eel_loc)
2866         enddo ! j
2867         num_cont_hb(i)=num_conti
2868       enddo   ! i
2869 c      write (iout,*) "Number of loop steps in EELEC:",ind
2870 cd      do i=1,nres
2871 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2872 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2873 cd      enddo
2874 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2875 ccc      eel_loc=eel_loc+eello_turn3
2876 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2877       return
2878       end
2879 C-------------------------------------------------------------------------------
2880       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2881       implicit real*8 (a-h,o-z)
2882       include 'DIMENSIONS'
2883 #ifdef MPI
2884       include "mpif.h"
2885 #endif
2886       include 'COMMON.CONTROL'
2887       include 'COMMON.IOUNITS'
2888       include 'COMMON.GEO'
2889       include 'COMMON.VAR'
2890       include 'COMMON.LOCAL'
2891       include 'COMMON.CHAIN'
2892       include 'COMMON.DERIV'
2893       include 'COMMON.INTERACT'
2894       include 'COMMON.CONTACTS'
2895       include 'COMMON.TORSION'
2896       include 'COMMON.VECTORS'
2897       include 'COMMON.FFIELD'
2898       include 'COMMON.TIME1'
2899       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2900      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2901       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2902      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),a22,a23,a32,a33
2903       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2904      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2905      &    num_conti,j1,j2
2906 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2907 #ifdef MOMENT
2908       double precision scal_el /1.0d0/
2909 #else
2910       double precision scal_el /0.5d0/
2911 #endif
2912 C 12/13/98
2913 C 13-go grudnia roku pamietnego...
2914       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2915      &                   0.0d0,1.0d0,0.0d0,
2916      &                   0.0d0,0.0d0,1.0d0/
2917 c          time00=MPI_Wtime()
2918 cd      write (iout,*) "eelecij",i,j
2919 c          ind=ind+1
2920           iteli=itel(i)
2921           itelj=itel(j)
2922           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2923           aaa=app(iteli,itelj)
2924           bbb=bpp(iteli,itelj)
2925           ael6i=ael6(iteli,itelj)
2926           ael3i=ael3(iteli,itelj)
2927           dxj=dc(1,j)
2928           dyj=dc(2,j)
2929           dzj=dc(3,j)
2930           dx_normj=dc_norm(1,j)
2931           dy_normj=dc_norm(2,j)
2932           dz_normj=dc_norm(3,j)
2933           xj=c(1,j)+0.5D0*dxj-xmedi
2934           yj=c(2,j)+0.5D0*dyj-ymedi
2935           zj=c(3,j)+0.5D0*dzj-zmedi
2936           rij=xj*xj+yj*yj+zj*zj
2937           rrmij=1.0D0/rij
2938           rij=dsqrt(rij)
2939           rmij=1.0D0/rij
2940           r3ij=rrmij*rmij
2941           r6ij=r3ij*r3ij
2942           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2943           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2944           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2945           fac=cosa-3.0D0*cosb*cosg
2946           ev1=aaa*r6ij*r6ij
2947 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2948           if (j.eq.i+2) ev1=scal_el*ev1
2949           ev2=bbb*r6ij
2950           fac3=ael6i*r6ij
2951           fac4=ael3i*r3ij
2952           evdwij=ev1+ev2
2953           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2954           el2=fac4*fac
2955           eesij=el1+el2
2956 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2957           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2958           ees=ees+eesij
2959           evdw1=evdw1+evdwij
2960 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2961 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2962 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2963 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2964
2965           if (energy_dec) then
2966               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2967               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2968           endif
2969
2970 C
2971 C Calculate contributions to the Cartesian gradient.
2972 C
2973 #ifdef SPLITELE
2974           facvdw=-6*rrmij*(ev1+evdwij)
2975           facel=-3*rrmij*(el1+eesij)
2976           fac1=fac
2977           erij(1)=xj*rmij
2978           erij(2)=yj*rmij
2979           erij(3)=zj*rmij
2980 *
2981 * Radial derivatives. First process both termini of the fragment (i,j)
2982 *
2983           ggg(1)=facel*xj
2984           ggg(2)=facel*yj
2985           ggg(3)=facel*zj
2986 c          do k=1,3
2987 c            ghalf=0.5D0*ggg(k)
2988 c            gelc(k,i)=gelc(k,i)+ghalf
2989 c            gelc(k,j)=gelc(k,j)+ghalf
2990 c          enddo
2991 c 9/28/08 AL Gradient compotents will be summed only at the end
2992           do k=1,3
2993             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2994             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2995           enddo
2996 *
2997 * Loop over residues i+1 thru j-1.
2998 *
2999 cgrad          do k=i+1,j-1
3000 cgrad            do l=1,3
3001 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3002 cgrad            enddo
3003 cgrad          enddo
3004           ggg(1)=facvdw*xj
3005           ggg(2)=facvdw*yj
3006           ggg(3)=facvdw*zj
3007 c          do k=1,3
3008 c            ghalf=0.5D0*ggg(k)
3009 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3010 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3011 c          enddo
3012 c 9/28/08 AL Gradient compotents will be summed only at the end
3013           do k=1,3
3014             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3015             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3016           enddo
3017 *
3018 * Loop over residues i+1 thru j-1.
3019 *
3020 cgrad          do k=i+1,j-1
3021 cgrad            do l=1,3
3022 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3023 cgrad            enddo
3024 cgrad          enddo
3025 #else
3026           facvdw=ev1+evdwij
3027           facel=el1+eesij
3028           fac1=fac
3029           fac=-3*rrmij*(facvdw+facvdw+facel)
3030           erij(1)=xj*rmij
3031           erij(2)=yj*rmij
3032           erij(3)=zj*rmij
3033 *
3034 * Radial derivatives. First process both termini of the fragment (i,j)
3035 *
3036           ggg(1)=fac*xj
3037           ggg(2)=fac*yj
3038           ggg(3)=fac*zj
3039 c          do k=1,3
3040 c            ghalf=0.5D0*ggg(k)
3041 c            gelc(k,i)=gelc(k,i)+ghalf
3042 c            gelc(k,j)=gelc(k,j)+ghalf
3043 c          enddo
3044 c 9/28/08 AL Gradient compotents will be summed only at the end
3045           do k=1,3
3046             gelc_long(k,j)=gelc(k,j)+ggg(k)
3047             gelc_long(k,i)=gelc(k,i)-ggg(k)
3048           enddo
3049 *
3050 * Loop over residues i+1 thru j-1.
3051 *
3052 cgrad          do k=i+1,j-1
3053 cgrad            do l=1,3
3054 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3055 cgrad            enddo
3056 cgrad          enddo
3057 c 9/28/08 AL Gradient compotents will be summed only at the end
3058           ggg(1)=facvdw*xj
3059           ggg(2)=facvdw*yj
3060           ggg(3)=facvdw*zj
3061           do k=1,3
3062             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3063             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3064           enddo
3065 #endif
3066 *
3067 * Angular part
3068 *
3069           ecosa=2.0D0*fac3*fac1+fac4
3070           fac4=-3.0D0*fac4
3071           fac3=-6.0D0*fac3
3072           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3073           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3074           do k=1,3
3075             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3076             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3077           enddo
3078 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3079 cd   &          (dcosg(k),k=1,3)
3080           do k=1,3
3081             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3082           enddo
3083 c          do k=1,3
3084 c            ghalf=0.5D0*ggg(k)
3085 c            gelc(k,i)=gelc(k,i)+ghalf
3086 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3087 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3088 c            gelc(k,j)=gelc(k,j)+ghalf
3089 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3090 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3091 c          enddo
3092 cgrad          do k=i+1,j-1
3093 cgrad            do l=1,3
3094 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3095 cgrad            enddo
3096 cgrad          enddo
3097           do k=1,3
3098             gelc(k,i)=gelc(k,i)
3099      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3100      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3101             gelc(k,j)=gelc(k,j)
3102      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3103      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3104             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3105             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3106           enddo
3107           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3108      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3109      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3110 C
3111 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3112 C   energy of a peptide unit is assumed in the form of a second-order
3113 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3114 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3115 C   are computed for EVERY pair of non-contiguous peptide groups.
3116 C
3117           if (j.lt.nres-1) then
3118             j1=j+1
3119             j2=j-1
3120           else
3121             j1=j-1
3122             j2=j-2
3123           endif
3124           kkk=0
3125           do k=1,2
3126             do l=1,2
3127               kkk=kkk+1
3128               muij(kkk)=mu(k,i)*mu(l,j)
3129             enddo
3130           enddo
3131 cd         write (iout,*) 'EELEC: i',i,' j',j
3132 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3133 cd          write(iout,*) 'muij',muij
3134           ury=scalar(uy(1,i),erij)
3135           urz=scalar(uz(1,i),erij)
3136           vry=scalar(uy(1,j),erij)
3137           vrz=scalar(uz(1,j),erij)
3138           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3139           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3140           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3141           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3142           fac=dsqrt(-ael6i)*r3ij
3143           a22=a22*fac
3144           a23=a23*fac
3145           a32=a32*fac
3146           a33=a33*fac
3147 cd          write (iout,'(4i5,4f10.5)')
3148 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3149 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3150 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3151 cd     &      uy(:,j),uz(:,j)
3152 cd          write (iout,'(4f10.5)')
3153 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3154 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3155 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3156 cd           write (iout,'(9f10.5/)')
3157 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3158 C Derivatives of the elements of A in virtual-bond vectors
3159           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3160           do k=1,3
3161             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3162             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3163             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3164             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3165             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3166             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3167             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3168             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3169             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3170             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3171             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3172             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3173           enddo
3174 C Compute radial contributions to the gradient
3175           facr=-3.0d0*rrmij
3176           a22der=a22*facr
3177           a23der=a23*facr
3178           a32der=a32*facr
3179           a33der=a33*facr
3180           agg(1,1)=a22der*xj
3181           agg(2,1)=a22der*yj
3182           agg(3,1)=a22der*zj
3183           agg(1,2)=a23der*xj
3184           agg(2,2)=a23der*yj
3185           agg(3,2)=a23der*zj
3186           agg(1,3)=a32der*xj
3187           agg(2,3)=a32der*yj
3188           agg(3,3)=a32der*zj
3189           agg(1,4)=a33der*xj
3190           agg(2,4)=a33der*yj
3191           agg(3,4)=a33der*zj
3192 C Add the contributions coming from er
3193           fac3=-3.0d0*fac
3194           do k=1,3
3195             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3196             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3197             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3198             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3199           enddo
3200           do k=1,3
3201 C Derivatives in DC(i)
3202 cgrad            ghalf1=0.5d0*agg(k,1)
3203 cgrad            ghalf2=0.5d0*agg(k,2)
3204 cgrad            ghalf3=0.5d0*agg(k,3)
3205 cgrad            ghalf4=0.5d0*agg(k,4)
3206             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3207      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3208             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3209      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3210             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3211      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3212             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3213      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3214 C Derivatives in DC(i+1)
3215             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3216      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3217             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3218      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3219             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3220      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3221             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3222      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3223 C Derivatives in DC(j)
3224             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3225      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3226             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3227      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3228             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3229      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3230             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3231      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3232 C Derivatives in DC(j+1) or DC(nres-1)
3233             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3234      &      -3.0d0*vryg(k,3)*ury)
3235             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3236      &      -3.0d0*vrzg(k,3)*ury)
3237             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3238      &      -3.0d0*vryg(k,3)*urz)
3239             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3240      &      -3.0d0*vrzg(k,3)*urz)
3241 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3242 cgrad              do l=1,4
3243 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3244 cgrad              enddo
3245 cgrad            endif
3246           enddo
3247           acipa(1,1)=a22
3248           acipa(1,2)=a23
3249           acipa(2,1)=a32
3250           acipa(2,2)=a33
3251           a22=-a22
3252           a23=-a23
3253           do l=1,2
3254             do k=1,3
3255               agg(k,l)=-agg(k,l)
3256               aggi(k,l)=-aggi(k,l)
3257               aggi1(k,l)=-aggi1(k,l)
3258               aggj(k,l)=-aggj(k,l)
3259               aggj1(k,l)=-aggj1(k,l)
3260             enddo
3261           enddo
3262           if (j.lt.nres-1) then
3263             a22=-a22
3264             a32=-a32
3265             do l=1,3,2
3266               do k=1,3
3267                 agg(k,l)=-agg(k,l)
3268                 aggi(k,l)=-aggi(k,l)
3269                 aggi1(k,l)=-aggi1(k,l)
3270                 aggj(k,l)=-aggj(k,l)
3271                 aggj1(k,l)=-aggj1(k,l)
3272               enddo
3273             enddo
3274           else
3275             a22=-a22
3276             a23=-a23
3277             a32=-a32
3278             a33=-a33
3279             do l=1,4
3280               do k=1,3
3281                 agg(k,l)=-agg(k,l)
3282                 aggi(k,l)=-aggi(k,l)
3283                 aggi1(k,l)=-aggi1(k,l)
3284                 aggj(k,l)=-aggj(k,l)
3285                 aggj1(k,l)=-aggj1(k,l)
3286               enddo
3287             enddo
3288           endif
3289           ENDIF ! WCORR
3290           IF (wel_loc.gt.0.0d0) THEN
3291 C Contribution to the local-electrostatic energy coming from the i-j pair
3292           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3293      &     +a33*muij(4)
3294 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3295
3296           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3297      &            'eelloc',i,j,eel_loc_ij
3298
3299           eel_loc=eel_loc+eel_loc_ij
3300 C Partial derivatives in virtual-bond dihedral angles gamma
3301           if (i.gt.1)
3302      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3303      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3304      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3305           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3306      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3307      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3308 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3309           do l=1,3
3310             ggg(l)=agg(l,1)*muij(1)+
3311      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3312             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3313             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3314 cgrad            ghalf=0.5d0*ggg(l)
3315 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3316 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3317           enddo
3318 cgrad          do k=i+1,j2
3319 cgrad            do l=1,3
3320 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3321 cgrad            enddo
3322 cgrad          enddo
3323 C Remaining derivatives of eello
3324           do l=1,3
3325             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3326      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3327             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3328      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3329             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3330      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3331             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3332      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3333           enddo
3334           ENDIF
3335 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3336 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3337           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3338      &       .and. num_conti.le.maxconts) then
3339 c            write (iout,*) i,j," entered corr"
3340 C
3341 C Calculate the contact function. The ith column of the array JCONT will
3342 C contain the numbers of atoms that make contacts with the atom I (of numbers
3343 C greater than I). The arrays FACONT and GACONT will contain the values of
3344 C the contact function and its derivative.
3345 c           r0ij=1.02D0*rpp(iteli,itelj)
3346 c           r0ij=1.11D0*rpp(iteli,itelj)
3347             r0ij=2.20D0*rpp(iteli,itelj)
3348 c           r0ij=1.55D0*rpp(iteli,itelj)
3349             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3350             if (fcont.gt.0.0D0) then
3351               num_conti=num_conti+1
3352               if (num_conti.gt.maxconts) then
3353                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3354      &                         ' will skip next contacts for this conf.'
3355               else
3356                 jcont_hb(num_conti,i)=j
3357 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3358 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3359                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3360      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3361 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3362 C  terms.
3363                 d_cont(num_conti,i)=rij
3364 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3365 C     --- Electrostatic-interaction matrix ---
3366                 a_chuj(1,1,num_conti,i)=a22
3367                 a_chuj(1,2,num_conti,i)=a23
3368                 a_chuj(2,1,num_conti,i)=a32
3369                 a_chuj(2,2,num_conti,i)=a33
3370 C     --- Gradient of rij
3371                 do kkk=1,3
3372                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3373                 enddo
3374                 kkll=0
3375                 do k=1,2
3376                   do l=1,2
3377                     kkll=kkll+1
3378                     do m=1,3
3379                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3380                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3381                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3382                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3383                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3384                     enddo
3385                   enddo
3386                 enddo
3387                 ENDIF
3388                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3389 C Calculate contact energies
3390                 cosa4=4.0D0*cosa
3391                 wij=cosa-3.0D0*cosb*cosg
3392                 cosbg1=cosb+cosg
3393                 cosbg2=cosb-cosg
3394 c               fac3=dsqrt(-ael6i)/r0ij**3
3395                 fac3=dsqrt(-ael6i)*r3ij
3396 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3397                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3398                 if (ees0tmp.gt.0) then
3399                   ees0pij=dsqrt(ees0tmp)
3400                 else
3401                   ees0pij=0
3402                 endif
3403 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3404                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3405                 if (ees0tmp.gt.0) then
3406                   ees0mij=dsqrt(ees0tmp)
3407                 else
3408                   ees0mij=0
3409                 endif
3410 c               ees0mij=0.0D0
3411                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3412                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3413 C Diagnostics. Comment out or remove after debugging!
3414 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3415 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3416 c               ees0m(num_conti,i)=0.0D0
3417 C End diagnostics.
3418 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3419 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3420 C Angular derivatives of the contact function
3421                 ees0pij1=fac3/ees0pij
3422                 ees0mij1=fac3/ees0mij
3423                 fac3p=-3.0D0*fac3*rrmij
3424                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3425                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3426 c               ees0mij1=0.0D0
3427                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3428                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3429                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3430                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3431                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3432                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3433                 ecosap=ecosa1+ecosa2
3434                 ecosbp=ecosb1+ecosb2
3435                 ecosgp=ecosg1+ecosg2
3436                 ecosam=ecosa1-ecosa2
3437                 ecosbm=ecosb1-ecosb2
3438                 ecosgm=ecosg1-ecosg2
3439 C Diagnostics
3440 c               ecosap=ecosa1
3441 c               ecosbp=ecosb1
3442 c               ecosgp=ecosg1
3443 c               ecosam=0.0D0
3444 c               ecosbm=0.0D0
3445 c               ecosgm=0.0D0
3446 C End diagnostics
3447                 facont_hb(num_conti,i)=fcont
3448                 fprimcont=fprimcont/rij
3449 cd              facont_hb(num_conti,i)=1.0D0
3450 C Following line is for diagnostics.
3451 cd              fprimcont=0.0D0
3452                 do k=1,3
3453                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3454                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3455                 enddo
3456                 do k=1,3
3457                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3458                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3459                 enddo
3460                 gggp(1)=gggp(1)+ees0pijp*xj
3461                 gggp(2)=gggp(2)+ees0pijp*yj
3462                 gggp(3)=gggp(3)+ees0pijp*zj
3463                 gggm(1)=gggm(1)+ees0mijp*xj
3464                 gggm(2)=gggm(2)+ees0mijp*yj
3465                 gggm(3)=gggm(3)+ees0mijp*zj
3466 C Derivatives due to the contact function
3467                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3468                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3469                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3470                 do k=1,3
3471 c
3472 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3473 c          following the change of gradient-summation algorithm.
3474 c
3475 cgrad                  ghalfp=0.5D0*gggp(k)
3476 cgrad                  ghalfm=0.5D0*gggm(k)
3477                   gacontp_hb1(k,num_conti,i)=!ghalfp
3478      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3479      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3480                   gacontp_hb2(k,num_conti,i)=!ghalfp
3481      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3482      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3483                   gacontp_hb3(k,num_conti,i)=gggp(k)
3484                   gacontm_hb1(k,num_conti,i)=!ghalfm
3485      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3486      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3487                   gacontm_hb2(k,num_conti,i)=!ghalfm
3488      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3489      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3490                   gacontm_hb3(k,num_conti,i)=gggm(k)
3491                 enddo
3492 C Diagnostics. Comment out or remove after debugging!
3493 cdiag           do k=1,3
3494 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3495 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3496 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3497 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3498 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3499 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3500 cdiag           enddo
3501               ENDIF ! wcorr
3502               endif  ! num_conti.le.maxconts
3503             endif  ! fcont.gt.0
3504           endif    ! j.gt.i+1
3505           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3506             do k=1,4
3507               do l=1,3
3508                 ghalf=0.5d0*agg(l,k)
3509                 aggi(l,k)=aggi(l,k)+ghalf
3510                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3511                 aggj(l,k)=aggj(l,k)+ghalf
3512               enddo
3513             enddo
3514             if (j.eq.nres-1 .and. i.lt.j-2) then
3515               do k=1,4
3516                 do l=1,3
3517                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3518                 enddo
3519               enddo
3520             endif
3521           endif
3522 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3523       return
3524       end
3525 C-----------------------------------------------------------------------------
3526       subroutine eturn3(i,eello_turn3)
3527 C Third- and fourth-order contributions from turns
3528       implicit real*8 (a-h,o-z)
3529       include 'DIMENSIONS'
3530       include 'COMMON.IOUNITS'
3531       include 'COMMON.GEO'
3532       include 'COMMON.VAR'
3533       include 'COMMON.LOCAL'
3534       include 'COMMON.CHAIN'
3535       include 'COMMON.DERIV'
3536       include 'COMMON.INTERACT'
3537       include 'COMMON.CONTACTS'
3538       include 'COMMON.TORSION'
3539       include 'COMMON.VECTORS'
3540       include 'COMMON.FFIELD'
3541       include 'COMMON.CONTROL'
3542       dimension ggg(3)
3543       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3544      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3545      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3546       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3547      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3548       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3549      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3550      &    num_conti,j1,j2
3551       j=i+2
3552 c      write (iout,*) "eturn3",i,j,j1,j2
3553       a_temp(1,1)=a22
3554       a_temp(1,2)=a23
3555       a_temp(2,1)=a32
3556       a_temp(2,2)=a33
3557 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3558 C
3559 C               Third-order contributions
3560 C
3561 C                 (i+2)o----(i+3)
3562 C                      | |
3563 C                      | |
3564 C                 (i+1)o----i
3565 C
3566 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3567 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3568         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3569         call transpose2(auxmat(1,1),auxmat1(1,1))
3570         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3571         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3572         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3573      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3574 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3575 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3576 cd     &    ' eello_turn3_num',4*eello_turn3_num
3577 C Derivatives in gamma(i)
3578         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3579         call transpose2(auxmat2(1,1),auxmat3(1,1))
3580         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3581         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3582 C Derivatives in gamma(i+1)
3583         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3584         call transpose2(auxmat2(1,1),auxmat3(1,1))
3585         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3586         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3587      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3588 C Cartesian derivatives
3589         do l=1,3
3590 c            ghalf1=0.5d0*agg(l,1)
3591 c            ghalf2=0.5d0*agg(l,2)
3592 c            ghalf3=0.5d0*agg(l,3)
3593 c            ghalf4=0.5d0*agg(l,4)
3594           a_temp(1,1)=aggi(l,1)!+ghalf1
3595           a_temp(1,2)=aggi(l,2)!+ghalf2
3596           a_temp(2,1)=aggi(l,3)!+ghalf3
3597           a_temp(2,2)=aggi(l,4)!+ghalf4
3598           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3599           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3600      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3601           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3602           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3603           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3604           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3605           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3606           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3607      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3608           a_temp(1,1)=aggj(l,1)!+ghalf1
3609           a_temp(1,2)=aggj(l,2)!+ghalf2
3610           a_temp(2,1)=aggj(l,3)!+ghalf3
3611           a_temp(2,2)=aggj(l,4)!+ghalf4
3612           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3613           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3614      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3615           a_temp(1,1)=aggj1(l,1)
3616           a_temp(1,2)=aggj1(l,2)
3617           a_temp(2,1)=aggj1(l,3)
3618           a_temp(2,2)=aggj1(l,4)
3619           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3620           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3621      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3622         enddo
3623       return
3624       end
3625 C-------------------------------------------------------------------------------
3626       subroutine eturn4(i,eello_turn4)
3627 C Third- and fourth-order contributions from turns
3628       implicit real*8 (a-h,o-z)
3629       include 'DIMENSIONS'
3630       include 'COMMON.IOUNITS'
3631       include 'COMMON.GEO'
3632       include 'COMMON.VAR'
3633       include 'COMMON.LOCAL'
3634       include 'COMMON.CHAIN'
3635       include 'COMMON.DERIV'
3636       include 'COMMON.INTERACT'
3637       include 'COMMON.CONTACTS'
3638       include 'COMMON.TORSION'
3639       include 'COMMON.VECTORS'
3640       include 'COMMON.FFIELD'
3641       include 'COMMON.CONTROL'
3642       dimension ggg(3)
3643       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3644      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3645      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3646       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3647      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3648       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3649      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3650      &    num_conti,j1,j2
3651       j=i+3
3652 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3653 C
3654 C               Fourth-order contributions
3655 C
3656 C                 (i+3)o----(i+4)
3657 C                     /  |
3658 C               (i+2)o   |
3659 C                     \  |
3660 C                 (i+1)o----i
3661 C
3662 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3663 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3664 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3665         a_temp(1,1)=a22
3666         a_temp(1,2)=a23
3667         a_temp(2,1)=a32
3668         a_temp(2,2)=a33
3669         iti1=itortyp(itype(i+1))
3670         iti2=itortyp(itype(i+2))
3671         iti3=itortyp(itype(i+3))
3672 C        write(iout,*) i,"iti1",iti1," iti2",iti2," iti3",iti3,itype(i+3)
3673         call transpose2(EUg(1,1,i+1),e1t(1,1))
3674         call transpose2(Eug(1,1,i+2),e2t(1,1))
3675         call transpose2(Eug(1,1,i+3),e3t(1,1))
3676         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3677         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3678         s1=scalar2(b1(1,iti2),auxvec(1))
3679         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3680         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3681         s2=scalar2(b1(1,iti1),auxvec(1))
3682         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3683         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3684         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3685         eello_turn4=eello_turn4-(s1+s2+s3)
3686         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3687      &      'eturn4',i,j,-(s1+s2+s3)
3688 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3689 cd     &    ' eello_turn4_num',8*eello_turn4_num
3690 C Derivatives in gamma(i)
3691         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3692         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3693         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3694         s1=scalar2(b1(1,iti2),auxvec(1))
3695         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3696         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3697         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3698 C Derivatives in gamma(i+1)
3699         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3700         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3701         s2=scalar2(b1(1,iti1),auxvec(1))
3702         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3703         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3704         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3705         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3706 C Derivatives in gamma(i+2)
3707         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3708         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3709         s1=scalar2(b1(1,iti2),auxvec(1))
3710         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3711         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3712         s2=scalar2(b1(1,iti1),auxvec(1))
3713         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3714         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3715         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3716         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3717 C Cartesian derivatives
3718 C Derivatives of this turn contributions in DC(i+2)
3719         if (j.lt.nres-1) then
3720           do l=1,3
3721             a_temp(1,1)=agg(l,1)
3722             a_temp(1,2)=agg(l,2)
3723             a_temp(2,1)=agg(l,3)
3724             a_temp(2,2)=agg(l,4)
3725             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3726             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3727             s1=scalar2(b1(1,iti2),auxvec(1))
3728             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3729             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3730             s2=scalar2(b1(1,iti1),auxvec(1))
3731             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3732             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3733             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3734             ggg(l)=-(s1+s2+s3)
3735             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3736           enddo
3737         endif
3738 C Remaining derivatives of this turn contribution
3739         do l=1,3
3740           a_temp(1,1)=aggi(l,1)
3741           a_temp(1,2)=aggi(l,2)
3742           a_temp(2,1)=aggi(l,3)
3743           a_temp(2,2)=aggi(l,4)
3744           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3745           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3746           s1=scalar2(b1(1,iti2),auxvec(1))
3747           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3748           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3749           s2=scalar2(b1(1,iti1),auxvec(1))
3750           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3751           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3752           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3753           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3754           a_temp(1,1)=aggi1(l,1)
3755           a_temp(1,2)=aggi1(l,2)
3756           a_temp(2,1)=aggi1(l,3)
3757           a_temp(2,2)=aggi1(l,4)
3758           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3759           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3760           s1=scalar2(b1(1,iti2),auxvec(1))
3761           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3762           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3763           s2=scalar2(b1(1,iti1),auxvec(1))
3764           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3765           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3766           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3767           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3768           a_temp(1,1)=aggj(l,1)
3769           a_temp(1,2)=aggj(l,2)
3770           a_temp(2,1)=aggj(l,3)
3771           a_temp(2,2)=aggj(l,4)
3772           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3773           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3774           s1=scalar2(b1(1,iti2),auxvec(1))
3775           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3776           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3777           s2=scalar2(b1(1,iti1),auxvec(1))
3778           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3779           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3780           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3781           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3782           a_temp(1,1)=aggj1(l,1)
3783           a_temp(1,2)=aggj1(l,2)
3784           a_temp(2,1)=aggj1(l,3)
3785           a_temp(2,2)=aggj1(l,4)
3786           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3787           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3788           s1=scalar2(b1(1,iti2),auxvec(1))
3789           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3790           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3791           s2=scalar2(b1(1,iti1),auxvec(1))
3792           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3793           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3794           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3795 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3796           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3797         enddo
3798       return
3799       end
3800 C-----------------------------------------------------------------------------
3801       subroutine vecpr(u,v,w)
3802       implicit real*8(a-h,o-z)
3803       dimension u(3),v(3),w(3)
3804       w(1)=u(2)*v(3)-u(3)*v(2)
3805       w(2)=-u(1)*v(3)+u(3)*v(1)
3806       w(3)=u(1)*v(2)-u(2)*v(1)
3807       return
3808       end
3809 C-----------------------------------------------------------------------------
3810       subroutine unormderiv(u,ugrad,unorm,ungrad)
3811 C This subroutine computes the derivatives of a normalized vector u, given
3812 C the derivatives computed without normalization conditions, ugrad. Returns
3813 C ungrad.
3814       implicit none
3815       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3816       double precision vec(3)
3817       double precision scalar
3818       integer i,j
3819 c      write (2,*) 'ugrad',ugrad
3820 c      write (2,*) 'u',u
3821       do i=1,3
3822         vec(i)=scalar(ugrad(1,i),u(1))
3823       enddo
3824 c      write (2,*) 'vec',vec
3825       do i=1,3
3826         do j=1,3
3827           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3828         enddo
3829       enddo
3830 c      write (2,*) 'ungrad',ungrad
3831       return
3832       end
3833 C-----------------------------------------------------------------------------
3834       subroutine escp_soft_sphere(evdw2,evdw2_14)
3835 C
3836 C This subroutine calculates the excluded-volume interaction energy between
3837 C peptide-group centers and side chains and its gradient in virtual-bond and
3838 C side-chain vectors.
3839 C
3840       implicit real*8 (a-h,o-z)
3841       include 'DIMENSIONS'
3842       include 'COMMON.GEO'
3843       include 'COMMON.VAR'
3844       include 'COMMON.LOCAL'
3845       include 'COMMON.CHAIN'
3846       include 'COMMON.DERIV'
3847       include 'COMMON.INTERACT'
3848       include 'COMMON.FFIELD'
3849       include 'COMMON.IOUNITS'
3850       include 'COMMON.CONTROL'
3851       dimension ggg(3)
3852       evdw2=0.0D0
3853       evdw2_14=0.0d0
3854       r0_scp=4.5d0
3855 cd    print '(a)','Enter ESCP'
3856 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3857       do i=iatscp_s,iatscp_e
3858         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3859         iteli=itel(i)
3860         xi=0.5D0*(c(1,i)+c(1,i+1))
3861         yi=0.5D0*(c(2,i)+c(2,i+1))
3862         zi=0.5D0*(c(3,i)+c(3,i+1))
3863
3864         do iint=1,nscp_gr(i)
3865
3866         do j=iscpstart(i,iint),iscpend(i,iint)
3867           if (itype(j).eq.21) cycle
3868           itypj=itype(j)
3869 C Uncomment following three lines for SC-p interactions
3870 c         xj=c(1,nres+j)-xi
3871 c         yj=c(2,nres+j)-yi
3872 c         zj=c(3,nres+j)-zi
3873 C Uncomment following three lines for Ca-p interactions
3874           xj=c(1,j)-xi
3875           yj=c(2,j)-yi
3876           zj=c(3,j)-zi
3877           rij=xj*xj+yj*yj+zj*zj
3878           r0ij=r0_scp
3879           r0ijsq=r0ij*r0ij
3880           if (rij.lt.r0ijsq) then
3881             evdwij=0.25d0*(rij-r0ijsq)**2
3882             fac=rij-r0ijsq
3883           else
3884             evdwij=0.0d0
3885             fac=0.0d0
3886           endif
3887           evdw2=evdw2+evdwij
3888 C
3889 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3890 C
3891           ggg(1)=xj*fac
3892           ggg(2)=yj*fac
3893           ggg(3)=zj*fac
3894 cgrad          if (j.lt.i) then
3895 cd          write (iout,*) 'j<i'
3896 C Uncomment following three lines for SC-p interactions
3897 c           do k=1,3
3898 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3899 c           enddo
3900 cgrad          else
3901 cd          write (iout,*) 'j>i'
3902 cgrad            do k=1,3
3903 cgrad              ggg(k)=-ggg(k)
3904 C Uncomment following line for SC-p interactions
3905 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3906 cgrad            enddo
3907 cgrad          endif
3908 cgrad          do k=1,3
3909 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3910 cgrad          enddo
3911 cgrad          kstart=min0(i+1,j)
3912 cgrad          kend=max0(i-1,j-1)
3913 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3914 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3915 cgrad          do k=kstart,kend
3916 cgrad            do l=1,3
3917 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3918 cgrad            enddo
3919 cgrad          enddo
3920           do k=1,3
3921             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3922             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3923           enddo
3924         enddo
3925
3926         enddo ! iint
3927       enddo ! i
3928       return
3929       end
3930 C-----------------------------------------------------------------------------
3931       subroutine escp(evdw2,evdw2_14)
3932 C
3933 C This subroutine calculates the excluded-volume interaction energy between
3934 C peptide-group centers and side chains and its gradient in virtual-bond and
3935 C side-chain vectors.
3936 C
3937       implicit real*8 (a-h,o-z)
3938       include 'DIMENSIONS'
3939       include 'COMMON.GEO'
3940       include 'COMMON.VAR'
3941       include 'COMMON.LOCAL'
3942       include 'COMMON.CHAIN'
3943       include 'COMMON.DERIV'
3944       include 'COMMON.INTERACT'
3945       include 'COMMON.FFIELD'
3946       include 'COMMON.IOUNITS'
3947       include 'COMMON.CONTROL'
3948       dimension ggg(3)
3949       evdw2=0.0D0
3950       evdw2_14=0.0d0
3951 cd    print '(a)','Enter ESCP'
3952 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3953       do i=iatscp_s,iatscp_e
3954         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3955         iteli=itel(i)
3956         xi=0.5D0*(c(1,i)+c(1,i+1))
3957         yi=0.5D0*(c(2,i)+c(2,i+1))
3958         zi=0.5D0*(c(3,i)+c(3,i+1))
3959
3960         do iint=1,nscp_gr(i)
3961
3962         do j=iscpstart(i,iint),iscpend(i,iint)
3963           itypj=itype(j)
3964           if (itypj.eq.21) cycle
3965 C Uncomment following three lines for SC-p interactions
3966 c         xj=c(1,nres+j)-xi
3967 c         yj=c(2,nres+j)-yi
3968 c         zj=c(3,nres+j)-zi
3969 C Uncomment following three lines for Ca-p interactions
3970           xj=c(1,j)-xi
3971           yj=c(2,j)-yi
3972           zj=c(3,j)-zi
3973           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3974           fac=rrij**expon2
3975           e1=fac*fac*aad(itypj,iteli)
3976           e2=fac*bad(itypj,iteli)
3977           if (iabs(j-i) .le. 2) then
3978             e1=scal14*e1
3979             e2=scal14*e2
3980             evdw2_14=evdw2_14+e1+e2
3981           endif
3982           evdwij=e1+e2
3983           evdw2=evdw2+evdwij
3984           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3985      &        'evdw2',i,j,evdwij
3986 C
3987 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3988 C
3989           fac=-(evdwij+e1)*rrij
3990           ggg(1)=xj*fac
3991           ggg(2)=yj*fac
3992           ggg(3)=zj*fac
3993 cgrad          if (j.lt.i) then
3994 cd          write (iout,*) 'j<i'
3995 C Uncomment following three lines for SC-p interactions
3996 c           do k=1,3
3997 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3998 c           enddo
3999 cgrad          else
4000 cd          write (iout,*) 'j>i'
4001 cgrad            do k=1,3
4002 cgrad              ggg(k)=-ggg(k)
4003 C Uncomment following line for SC-p interactions
4004 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4005 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4006 cgrad            enddo
4007 cgrad          endif
4008 cgrad          do k=1,3
4009 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4010 cgrad          enddo
4011 cgrad          kstart=min0(i+1,j)
4012 cgrad          kend=max0(i-1,j-1)
4013 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4014 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4015 cgrad          do k=kstart,kend
4016 cgrad            do l=1,3
4017 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4018 cgrad            enddo
4019 cgrad          enddo
4020           do k=1,3
4021             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4022             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4023           enddo
4024         enddo
4025
4026         enddo ! iint
4027       enddo ! i
4028       do i=1,nct
4029         do j=1,3
4030           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4031           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4032           gradx_scp(j,i)=expon*gradx_scp(j,i)
4033         enddo
4034       enddo
4035 C******************************************************************************
4036 C
4037 C                              N O T E !!!
4038 C
4039 C To save time the factor EXPON has been extracted from ALL components
4040 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4041 C use!
4042 C
4043 C******************************************************************************
4044       return
4045       end
4046 C--------------------------------------------------------------------------
4047       subroutine edis(ehpb)
4048 C
4049 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4050 C
4051       implicit real*8 (a-h,o-z)
4052       include 'DIMENSIONS'
4053       include 'COMMON.SBRIDGE'
4054       include 'COMMON.CHAIN'
4055       include 'COMMON.DERIV'
4056       include 'COMMON.VAR'
4057       include 'COMMON.INTERACT'
4058       include 'COMMON.IOUNITS'
4059       dimension ggg(3)
4060       ehpb=0.0D0
4061 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4062 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4063       if (link_end.eq.0) return
4064       do i=link_start,link_end
4065 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4066 C CA-CA distance used in regularization of structure.
4067         ii=ihpb(i)
4068         jj=jhpb(i)
4069 C iii and jjj point to the residues for which the distance is assigned.
4070         if (ii.gt.nres) then
4071           iii=ii-nres
4072           jjj=jj-nres
4073         else
4074           iii=ii
4075           jjj=jj
4076         endif
4077 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4078 c     &    dhpb(i),dhpb1(i),forcon(i)
4079 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4080 C    distance and angle dependent SS bond potential.
4081 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4082 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4083         if (.not.dyn_ss .and. i.le.nss) then
4084 C 15/02/13 CC dynamic SSbond - additional check
4085          if (ii.gt.nres
4086      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4087           call ssbond_ene(iii,jjj,eij)
4088           ehpb=ehpb+2*eij
4089          endif
4090 cd          write (iout,*) "eij",eij
4091         else
4092 C Calculate the distance between the two points and its difference from the
4093 C target distance.
4094           dd=dist(ii,jj)
4095             rdis=dd-dhpb(i)
4096 C Get the force constant corresponding to this distance.
4097             waga=forcon(i)
4098 C Calculate the contribution to energy.
4099             ehpb=ehpb+waga*rdis*rdis
4100 C
4101 C Evaluate gradient.
4102 C
4103             fac=waga*rdis/dd
4104 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4105 cd   &   ' waga=',waga,' fac=',fac
4106             do j=1,3
4107               ggg(j)=fac*(c(j,jj)-c(j,ii))
4108             enddo
4109 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4110 C If this is a SC-SC distance, we need to calculate the contributions to the
4111 C Cartesian gradient in the SC vectors (ghpbx).
4112           if (iii.lt.ii) then
4113           do j=1,3
4114             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4115             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4116           enddo
4117           endif
4118 cgrad        do j=iii,jjj-1
4119 cgrad          do k=1,3
4120 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4121 cgrad          enddo
4122 cgrad        enddo
4123           do k=1,3
4124             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4125             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4126           enddo
4127         endif
4128       enddo
4129       ehpb=0.5D0*ehpb
4130       return
4131       end
4132 C--------------------------------------------------------------------------
4133       subroutine ssbond_ene(i,j,eij)
4134 C
4135 C Calculate the distance and angle dependent SS-bond potential energy
4136 C using a free-energy function derived based on RHF/6-31G** ab initio
4137 C calculations of diethyl disulfide.
4138 C
4139 C A. Liwo and U. Kozlowska, 11/24/03
4140 C
4141       implicit real*8 (a-h,o-z)
4142       include 'DIMENSIONS'
4143       include 'COMMON.SBRIDGE'
4144       include 'COMMON.CHAIN'
4145       include 'COMMON.DERIV'
4146       include 'COMMON.LOCAL'
4147       include 'COMMON.INTERACT'
4148       include 'COMMON.VAR'
4149       include 'COMMON.IOUNITS'
4150       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4151       itypi=itype(i)
4152       xi=c(1,nres+i)
4153       yi=c(2,nres+i)
4154       zi=c(3,nres+i)
4155       dxi=dc_norm(1,nres+i)
4156       dyi=dc_norm(2,nres+i)
4157       dzi=dc_norm(3,nres+i)
4158 c      dsci_inv=dsc_inv(itypi)
4159       dsci_inv=vbld_inv(nres+i)
4160       itypj=itype(j)
4161 c      dscj_inv=dsc_inv(itypj)
4162       dscj_inv=vbld_inv(nres+j)
4163       xj=c(1,nres+j)-xi
4164       yj=c(2,nres+j)-yi
4165       zj=c(3,nres+j)-zi
4166       dxj=dc_norm(1,nres+j)
4167       dyj=dc_norm(2,nres+j)
4168       dzj=dc_norm(3,nres+j)
4169       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4170       rij=dsqrt(rrij)
4171       erij(1)=xj*rij
4172       erij(2)=yj*rij
4173       erij(3)=zj*rij
4174       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4175       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4176       om12=dxi*dxj+dyi*dyj+dzi*dzj
4177       do k=1,3
4178         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4179         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4180       enddo
4181       rij=1.0d0/rij
4182       deltad=rij-d0cm
4183       deltat1=1.0d0-om1
4184       deltat2=1.0d0+om2
4185       deltat12=om2-om1+2.0d0
4186       cosphi=om12-om1*om2
4187       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4188      &  +akct*deltad*deltat12
4189      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4190 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4191 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4192 c     &  " deltat12",deltat12," eij",eij
4193       ed=2*akcm*deltad+akct*deltat12
4194       pom1=akct*deltad
4195       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4196       eom1=-2*akth*deltat1-pom1-om2*pom2
4197       eom2= 2*akth*deltat2+pom1-om1*pom2
4198       eom12=pom2
4199       do k=1,3
4200         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4201         ghpbx(k,i)=ghpbx(k,i)-ggk
4202      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4203      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4204         ghpbx(k,j)=ghpbx(k,j)+ggk
4205      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4206      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4207         ghpbc(k,i)=ghpbc(k,i)-ggk
4208         ghpbc(k,j)=ghpbc(k,j)+ggk
4209       enddo
4210 C
4211 C Calculate the components of the gradient in DC and X
4212 C
4213 cgrad      do k=i,j-1
4214 cgrad        do l=1,3
4215 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4216 cgrad        enddo
4217 cgrad      enddo
4218       return
4219       end
4220 C--------------------------------------------------------------------------
4221       subroutine ebond(estr)
4222 c
4223 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4224 c
4225       implicit real*8 (a-h,o-z)
4226       include 'DIMENSIONS'
4227       include 'COMMON.LOCAL'
4228       include 'COMMON.GEO'
4229       include 'COMMON.INTERACT'
4230       include 'COMMON.DERIV'
4231       include 'COMMON.VAR'
4232       include 'COMMON.CHAIN'
4233       include 'COMMON.IOUNITS'
4234       include 'COMMON.NAMES'
4235       include 'COMMON.FFIELD'
4236       include 'COMMON.CONTROL'
4237       include 'COMMON.SETUP'
4238       double precision u(3),ud(3)
4239       estr=0.0d0
4240       estr1=0.0d0
4241       do i=ibondp_start,ibondp_end
4242         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4243           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4244           do j=1,3
4245           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4246      &      *dc(j,i-1)/vbld(i)
4247           enddo
4248           if (energy_dec) write(iout,*)
4249      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4250         else
4251         diff = vbld(i)-vbldp0
4252         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4253      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4254         estr=estr+diff*diff
4255         do j=1,3
4256           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4257         enddo
4258 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4259         endif
4260       enddo
4261       estr=0.5d0*AKP*estr+estr1
4262 c
4263 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4264 c
4265       do i=ibond_start,ibond_end
4266         iti=itype(i)
4267         if (iti.ne.10 .and. iti.ne.21) then
4268           nbi=nbondterm(iti)
4269           if (nbi.eq.1) then
4270             diff=vbld(i+nres)-vbldsc0(1,iti)
4271             if (energy_dec) write (iout,*)
4272      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4273      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4274             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4275             do j=1,3
4276               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4277             enddo
4278           else
4279             do j=1,nbi
4280               diff=vbld(i+nres)-vbldsc0(j,iti)
4281               ud(j)=aksc(j,iti)*diff
4282               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4283             enddo
4284             uprod=u(1)
4285             do j=2,nbi
4286               uprod=uprod*u(j)
4287             enddo
4288             usum=0.0d0
4289             usumsqder=0.0d0
4290             do j=1,nbi
4291               uprod1=1.0d0
4292               uprod2=1.0d0
4293               do k=1,nbi
4294                 if (k.ne.j) then
4295                   uprod1=uprod1*u(k)
4296                   uprod2=uprod2*u(k)*u(k)
4297                 endif
4298               enddo
4299               usum=usum+uprod1
4300               usumsqder=usumsqder+ud(j)*uprod2
4301             enddo
4302             estr=estr+uprod/usum
4303             do j=1,3
4304              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4305             enddo
4306           endif
4307         endif
4308       enddo
4309       return
4310       end
4311 #ifdef CRYST_THETA
4312 C--------------------------------------------------------------------------
4313       subroutine ebend(etheta)
4314 C
4315 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4316 C angles gamma and its derivatives in consecutive thetas and gammas.
4317 C
4318       implicit real*8 (a-h,o-z)
4319       include 'DIMENSIONS'
4320       include 'COMMON.LOCAL'
4321       include 'COMMON.GEO'
4322       include 'COMMON.INTERACT'
4323       include 'COMMON.DERIV'
4324       include 'COMMON.VAR'
4325       include 'COMMON.CHAIN'
4326       include 'COMMON.IOUNITS'
4327       include 'COMMON.NAMES'
4328       include 'COMMON.FFIELD'
4329       include 'COMMON.CONTROL'
4330       common /calcthet/ term1,term2,termm,diffak,ratak,
4331      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4332      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4333       double precision y(2),z(2)
4334       delta=0.02d0*pi
4335 c      time11=dexp(-2*time)
4336 c      time12=1.0d0
4337       etheta=0.0D0
4338 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4339       do i=ithet_start,ithet_end
4340         if (itype(i-1).eq.21) cycle
4341 C Zero the energy function and its derivative at 0 or pi.
4342         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4343         it=itype(i-1)
4344         if (i.gt.3 .and. itype(i-2).ne.21) then
4345 #ifdef OSF
4346           phii=phi(i)
4347           if (phii.ne.phii) phii=150.0
4348 #else
4349           phii=phi(i)
4350 #endif
4351           y(1)=dcos(phii)
4352           y(2)=dsin(phii)
4353         else
4354           y(1)=0.0D0
4355           y(2)=0.0D0
4356         endif
4357         if (i.lt.nres .and. itype(i).ne.21) then
4358 #ifdef OSF
4359           phii1=phi(i+1)
4360           if (phii1.ne.phii1) phii1=150.0
4361           phii1=pinorm(phii1)
4362           z(1)=cos(phii1)
4363 #else
4364           phii1=phi(i+1)
4365           z(1)=dcos(phii1)
4366 #endif
4367           z(2)=dsin(phii1)
4368         else
4369           z(1)=0.0D0
4370           z(2)=0.0D0
4371         endif
4372 C Calculate the "mean" value of theta from the part of the distribution
4373 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4374 C In following comments this theta will be referred to as t_c.
4375         thet_pred_mean=0.0d0
4376         do k=1,2
4377           athetk=athet(k,it)
4378           bthetk=bthet(k,it)
4379           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4380         enddo
4381         dthett=thet_pred_mean*ssd
4382         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4383 C Derivatives of the "mean" values in gamma1 and gamma2.
4384         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4385         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4386         if (theta(i).gt.pi-delta) then
4387           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4388      &         E_tc0)
4389           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4390           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4391           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4392      &        E_theta)
4393           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4394      &        E_tc)
4395         else if (theta(i).lt.delta) then
4396           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4397           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4398           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4399      &        E_theta)
4400           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4401           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4402      &        E_tc)
4403         else
4404           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4405      &        E_theta,E_tc)
4406         endif
4407         etheta=etheta+ethetai
4408         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4409      &      'ebend',i,ethetai
4410         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4411         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4412         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4413       enddo
4414 C Ufff.... We've done all this!!!
4415       return
4416       end
4417 C---------------------------------------------------------------------------
4418       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4419      &     E_tc)
4420       implicit real*8 (a-h,o-z)
4421       include 'DIMENSIONS'
4422       include 'COMMON.LOCAL'
4423       include 'COMMON.IOUNITS'
4424       common /calcthet/ term1,term2,termm,diffak,ratak,
4425      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4426      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4427 C Calculate the contributions to both Gaussian lobes.
4428 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4429 C The "polynomial part" of the "standard deviation" of this part of
4430 C the distribution.
4431         sig=polthet(3,it)
4432         do j=2,0,-1
4433           sig=sig*thet_pred_mean+polthet(j,it)
4434         enddo
4435 C Derivative of the "interior part" of the "standard deviation of the"
4436 C gamma-dependent Gaussian lobe in t_c.
4437         sigtc=3*polthet(3,it)
4438         do j=2,1,-1
4439           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4440         enddo
4441         sigtc=sig*sigtc
4442 C Set the parameters of both Gaussian lobes of the distribution.
4443 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4444         fac=sig*sig+sigc0(it)
4445         sigcsq=fac+fac
4446         sigc=1.0D0/sigcsq
4447 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4448         sigsqtc=-4.0D0*sigcsq*sigtc
4449 c       print *,i,sig,sigtc,sigsqtc
4450 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4451         sigtc=-sigtc/(fac*fac)
4452 C Following variable is sigma(t_c)**(-2)
4453         sigcsq=sigcsq*sigcsq
4454         sig0i=sig0(it)
4455         sig0inv=1.0D0/sig0i**2
4456         delthec=thetai-thet_pred_mean
4457         delthe0=thetai-theta0i
4458         term1=-0.5D0*sigcsq*delthec*delthec
4459         term2=-0.5D0*sig0inv*delthe0*delthe0
4460 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4461 C NaNs in taking the logarithm. We extract the largest exponent which is added
4462 C to the energy (this being the log of the distribution) at the end of energy
4463 C term evaluation for this virtual-bond angle.
4464         if (term1.gt.term2) then
4465           termm=term1
4466           term2=dexp(term2-termm)
4467           term1=1.0d0
4468         else
4469           termm=term2
4470           term1=dexp(term1-termm)
4471           term2=1.0d0
4472         endif
4473 C The ratio between the gamma-independent and gamma-dependent lobes of
4474 C the distribution is a Gaussian function of thet_pred_mean too.
4475         diffak=gthet(2,it)-thet_pred_mean
4476         ratak=diffak/gthet(3,it)**2
4477         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4478 C Let's differentiate it in thet_pred_mean NOW.
4479         aktc=ak*ratak
4480 C Now put together the distribution terms to make complete distribution.
4481         termexp=term1+ak*term2
4482         termpre=sigc+ak*sig0i
4483 C Contribution of the bending energy from this theta is just the -log of
4484 C the sum of the contributions from the two lobes and the pre-exponential
4485 C factor. Simple enough, isn't it?
4486         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4487 C NOW the derivatives!!!
4488 C 6/6/97 Take into account the deformation.
4489         E_theta=(delthec*sigcsq*term1
4490      &       +ak*delthe0*sig0inv*term2)/termexp
4491         E_tc=((sigtc+aktc*sig0i)/termpre
4492      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4493      &       aktc*term2)/termexp)
4494       return
4495       end
4496 c-----------------------------------------------------------------------------
4497       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4498       implicit real*8 (a-h,o-z)
4499       include 'DIMENSIONS'
4500       include 'COMMON.LOCAL'
4501       include 'COMMON.IOUNITS'
4502       common /calcthet/ term1,term2,termm,diffak,ratak,
4503      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4504      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4505       delthec=thetai-thet_pred_mean
4506       delthe0=thetai-theta0i
4507 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4508       t3 = thetai-thet_pred_mean
4509       t6 = t3**2
4510       t9 = term1
4511       t12 = t3*sigcsq
4512       t14 = t12+t6*sigsqtc
4513       t16 = 1.0d0
4514       t21 = thetai-theta0i
4515       t23 = t21**2
4516       t26 = term2
4517       t27 = t21*t26
4518       t32 = termexp
4519       t40 = t32**2
4520       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4521      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4522      & *(-t12*t9-ak*sig0inv*t27)
4523       return
4524       end
4525 #else
4526 C--------------------------------------------------------------------------
4527       subroutine ebend(etheta)
4528 C
4529 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4530 C angles gamma and its derivatives in consecutive thetas and gammas.
4531 C ab initio-derived potentials from
4532 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4533 C
4534       implicit real*8 (a-h,o-z)
4535       include 'DIMENSIONS'
4536       include 'COMMON.LOCAL'
4537       include 'COMMON.GEO'
4538       include 'COMMON.INTERACT'
4539       include 'COMMON.DERIV'
4540       include 'COMMON.VAR'
4541       include 'COMMON.CHAIN'
4542       include 'COMMON.IOUNITS'
4543       include 'COMMON.NAMES'
4544       include 'COMMON.FFIELD'
4545       include 'COMMON.CONTROL'
4546       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4547      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4548      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4549      & sinph1ph2(maxdouble,maxdouble)
4550       logical lprn /.false./, lprn1 /.false./
4551       etheta=0.0D0
4552       do i=ithet_start,ithet_end
4553         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4554      &(itype(i).eq.ntyp1)) cycle
4555         dethetai=0.0d0
4556         dephii=0.0d0
4557         dephii1=0.0d0
4558         theti2=0.5d0*theta(i)
4559         ityp2=ithetyp(itype(i-1))
4560         do k=1,nntheterm
4561           coskt(k)=dcos(k*theti2)
4562           sinkt(k)=dsin(k*theti2)
4563         enddo
4564 C        if (i.gt.3) then
4565         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4566 #ifdef OSF
4567           phii=phi(i)
4568           if (phii.ne.phii) phii=150.0
4569 #else
4570           phii=phi(i)
4571 #endif
4572           ityp1=ithetyp(itype(i-2))
4573           do k=1,nsingle
4574             cosph1(k)=dcos(k*phii)
4575             sinph1(k)=dsin(k*phii)
4576           enddo
4577         else
4578           phii=0.0d0
4579           ityp1=ithetyp(itype(i-2))
4580           do k=1,nsingle
4581             cosph1(k)=0.0d0
4582             sinph1(k)=0.0d0
4583           enddo
4584         endif
4585         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4586 #ifdef OSF
4587           phii1=phi(i+1)
4588           if (phii1.ne.phii1) phii1=150.0
4589           phii1=pinorm(phii1)
4590 #else
4591           phii1=phi(i+1)
4592 #endif
4593           ityp3=ithetyp(itype(i))
4594           do k=1,nsingle
4595             cosph2(k)=dcos(k*phii1)
4596             sinph2(k)=dsin(k*phii1)
4597           enddo
4598         else
4599           phii1=0.0d0
4600           ityp3=ithetyp(itype(i))
4601           do k=1,nsingle
4602             cosph2(k)=0.0d0
4603             sinph2(k)=0.0d0
4604           enddo
4605         endif
4606         ethetai=aa0thet(ityp1,ityp2,ityp3)
4607         do k=1,ndouble
4608           do l=1,k-1
4609             ccl=cosph1(l)*cosph2(k-l)
4610             ssl=sinph1(l)*sinph2(k-l)
4611             scl=sinph1(l)*cosph2(k-l)
4612             csl=cosph1(l)*sinph2(k-l)
4613             cosph1ph2(l,k)=ccl-ssl
4614             cosph1ph2(k,l)=ccl+ssl
4615             sinph1ph2(l,k)=scl+csl
4616             sinph1ph2(k,l)=scl-csl
4617           enddo
4618         enddo
4619         if (lprn) then
4620         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4621      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4622         write (iout,*) "coskt and sinkt"
4623         do k=1,nntheterm
4624           write (iout,*) k,coskt(k),sinkt(k)
4625         enddo
4626         endif
4627         do k=1,ntheterm
4628           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4629           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4630      &      *coskt(k)
4631           if (lprn)
4632      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4633      &     " ethetai",ethetai
4634         enddo
4635         if (lprn) then
4636         write (iout,*) "cosph and sinph"
4637         do k=1,nsingle
4638           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4639         enddo
4640         write (iout,*) "cosph1ph2 and sinph2ph2"
4641         do k=2,ndouble
4642           do l=1,k-1
4643             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4644      &         sinph1ph2(l,k),sinph1ph2(k,l)
4645           enddo
4646         enddo
4647         write(iout,*) "ethetai",ethetai
4648         endif
4649         do m=1,ntheterm2
4650           do k=1,nsingle
4651             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4652      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4653      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4654      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4655             ethetai=ethetai+sinkt(m)*aux
4656             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4657             dephii=dephii+k*sinkt(m)*(
4658      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4659      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4660             dephii1=dephii1+k*sinkt(m)*(
4661      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4662      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4663             if (lprn)
4664      &      write (iout,*) "m",m," k",k," bbthet",
4665      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4666      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4667      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4668      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4669           enddo
4670         enddo
4671         if (lprn)
4672      &  write(iout,*) "ethetai",ethetai
4673         do m=1,ntheterm3
4674           do k=2,ndouble
4675             do l=1,k-1
4676               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4677      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4678      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4679      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4680               ethetai=ethetai+sinkt(m)*aux
4681               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4682               dephii=dephii+l*sinkt(m)*(
4683      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4684      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4685      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4686      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4687               dephii1=dephii1+(k-l)*sinkt(m)*(
4688      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4689      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4690      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4691      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4692               if (lprn) then
4693               write (iout,*) "m",m," k",k," l",l," ffthet",
4694      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4695      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4696      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4697      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4698               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4699      &            cosph1ph2(k,l)*sinkt(m),
4700      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4701               endif
4702             enddo
4703           enddo
4704         enddo
4705 10      continue
4706         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4707      &   i,theta(i)*rad2deg,phii*rad2deg,
4708      &   phii1*rad2deg,ethetai
4709         etheta=etheta+ethetai
4710         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4711      &      'ebend',i,ethetai
4712         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4713         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4714         gloc(nphi+i-2,icg)=wang*dethetai
4715       enddo
4716       return
4717       end
4718 #endif
4719 #ifdef CRYST_SC
4720 c-----------------------------------------------------------------------------
4721       subroutine esc(escloc)
4722 C Calculate the local energy of a side chain and its derivatives in the
4723 C corresponding virtual-bond valence angles THETA and the spherical angles
4724 C ALPHA and OMEGA.
4725       implicit real*8 (a-h,o-z)
4726       include 'DIMENSIONS'
4727       include 'COMMON.GEO'
4728       include 'COMMON.LOCAL'
4729       include 'COMMON.VAR'
4730       include 'COMMON.INTERACT'
4731       include 'COMMON.DERIV'
4732       include 'COMMON.CHAIN'
4733       include 'COMMON.IOUNITS'
4734       include 'COMMON.NAMES'
4735       include 'COMMON.FFIELD'
4736       include 'COMMON.CONTROL'
4737       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4738      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4739       common /sccalc/ time11,time12,time112,theti,it,nlobit
4740       delta=0.02d0*pi
4741       escloc=0.0D0
4742 c     write (iout,'(a)') 'ESC'
4743       do i=loc_start,loc_end
4744         it=itype(i)
4745         if (it.eq.21) cycle
4746         if (it.eq.10) goto 1
4747         nlobit=nlob(it)
4748 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4749 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4750         theti=theta(i+1)-pipol
4751         x(1)=dtan(theti)
4752         x(2)=alph(i)
4753         x(3)=omeg(i)
4754
4755         if (x(2).gt.pi-delta) then
4756           xtemp(1)=x(1)
4757           xtemp(2)=pi-delta
4758           xtemp(3)=x(3)
4759           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4760           xtemp(2)=pi
4761           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4762           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4763      &        escloci,dersc(2))
4764           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4765      &        ddersc0(1),dersc(1))
4766           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4767      &        ddersc0(3),dersc(3))
4768           xtemp(2)=pi-delta
4769           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4770           xtemp(2)=pi
4771           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4772           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4773      &            dersc0(2),esclocbi,dersc02)
4774           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4775      &            dersc12,dersc01)
4776           call splinthet(x(2),0.5d0*delta,ss,ssd)
4777           dersc0(1)=dersc01
4778           dersc0(2)=dersc02
4779           dersc0(3)=0.0d0
4780           do k=1,3
4781             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4782           enddo
4783           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4784 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4785 c    &             esclocbi,ss,ssd
4786           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4787 c         escloci=esclocbi
4788 c         write (iout,*) escloci
4789         else if (x(2).lt.delta) then
4790           xtemp(1)=x(1)
4791           xtemp(2)=delta
4792           xtemp(3)=x(3)
4793           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4794           xtemp(2)=0.0d0
4795           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4796           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4797      &        escloci,dersc(2))
4798           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4799      &        ddersc0(1),dersc(1))
4800           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4801      &        ddersc0(3),dersc(3))
4802           xtemp(2)=delta
4803           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4804           xtemp(2)=0.0d0
4805           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4806           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4807      &            dersc0(2),esclocbi,dersc02)
4808           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4809      &            dersc12,dersc01)
4810           dersc0(1)=dersc01
4811           dersc0(2)=dersc02
4812           dersc0(3)=0.0d0
4813           call splinthet(x(2),0.5d0*delta,ss,ssd)
4814           do k=1,3
4815             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4816           enddo
4817           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4818 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4819 c    &             esclocbi,ss,ssd
4820           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4821 c         write (iout,*) escloci
4822         else
4823           call enesc(x,escloci,dersc,ddummy,.false.)
4824         endif
4825
4826         escloc=escloc+escloci
4827         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4828      &     'escloc',i,escloci
4829 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4830
4831         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4832      &   wscloc*dersc(1)
4833         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4834         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4835     1   continue
4836       enddo
4837       return
4838       end
4839 C---------------------------------------------------------------------------
4840       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4841       implicit real*8 (a-h,o-z)
4842       include 'DIMENSIONS'
4843       include 'COMMON.GEO'
4844       include 'COMMON.LOCAL'
4845       include 'COMMON.IOUNITS'
4846       common /sccalc/ time11,time12,time112,theti,it,nlobit
4847       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4848       double precision contr(maxlob,-1:1)
4849       logical mixed
4850 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4851         escloc_i=0.0D0
4852         do j=1,3
4853           dersc(j)=0.0D0
4854           if (mixed) ddersc(j)=0.0d0
4855         enddo
4856         x3=x(3)
4857
4858 C Because of periodicity of the dependence of the SC energy in omega we have
4859 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4860 C To avoid underflows, first compute & store the exponents.
4861
4862         do iii=-1,1
4863
4864           x(3)=x3+iii*dwapi
4865
4866           do j=1,nlobit
4867             do k=1,3
4868               z(k)=x(k)-censc(k,j,it)
4869             enddo
4870             do k=1,3
4871               Axk=0.0D0
4872               do l=1,3
4873                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4874               enddo
4875               Ax(k,j,iii)=Axk
4876             enddo
4877             expfac=0.0D0
4878             do k=1,3
4879               expfac=expfac+Ax(k,j,iii)*z(k)
4880             enddo
4881             contr(j,iii)=expfac
4882           enddo ! j
4883
4884         enddo ! iii
4885
4886         x(3)=x3
4887 C As in the case of ebend, we want to avoid underflows in exponentiation and
4888 C subsequent NaNs and INFs in energy calculation.
4889 C Find the largest exponent
4890         emin=contr(1,-1)
4891         do iii=-1,1
4892           do j=1,nlobit
4893             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4894           enddo
4895         enddo
4896         emin=0.5D0*emin
4897 cd      print *,'it=',it,' emin=',emin
4898
4899 C Compute the contribution to SC energy and derivatives
4900         do iii=-1,1
4901
4902           do j=1,nlobit
4903 #ifdef OSF
4904             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4905             if(adexp.ne.adexp) adexp=1.0
4906             expfac=dexp(adexp)
4907 #else
4908             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4909 #endif
4910 cd          print *,'j=',j,' expfac=',expfac
4911             escloc_i=escloc_i+expfac
4912             do k=1,3
4913               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4914             enddo
4915             if (mixed) then
4916               do k=1,3,2
4917                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4918      &            +gaussc(k,2,j,it))*expfac
4919               enddo
4920             endif
4921           enddo
4922
4923         enddo ! iii
4924
4925         dersc(1)=dersc(1)/cos(theti)**2
4926         ddersc(1)=ddersc(1)/cos(theti)**2
4927         ddersc(3)=ddersc(3)
4928
4929         escloci=-(dlog(escloc_i)-emin)
4930         do j=1,3
4931           dersc(j)=dersc(j)/escloc_i
4932         enddo
4933         if (mixed) then
4934           do j=1,3,2
4935             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4936           enddo
4937         endif
4938       return
4939       end
4940 C------------------------------------------------------------------------------
4941       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4942       implicit real*8 (a-h,o-z)
4943       include 'DIMENSIONS'
4944       include 'COMMON.GEO'
4945       include 'COMMON.LOCAL'
4946       include 'COMMON.IOUNITS'
4947       common /sccalc/ time11,time12,time112,theti,it,nlobit
4948       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4949       double precision contr(maxlob)
4950       logical mixed
4951
4952       escloc_i=0.0D0
4953
4954       do j=1,3
4955         dersc(j)=0.0D0
4956       enddo
4957
4958       do j=1,nlobit
4959         do k=1,2
4960           z(k)=x(k)-censc(k,j,it)
4961         enddo
4962         z(3)=dwapi
4963         do k=1,3
4964           Axk=0.0D0
4965           do l=1,3
4966             Axk=Axk+gaussc(l,k,j,it)*z(l)
4967           enddo
4968           Ax(k,j)=Axk
4969         enddo
4970         expfac=0.0D0
4971         do k=1,3
4972           expfac=expfac+Ax(k,j)*z(k)
4973         enddo
4974         contr(j)=expfac
4975       enddo ! j
4976
4977 C As in the case of ebend, we want to avoid underflows in exponentiation and
4978 C subsequent NaNs and INFs in energy calculation.
4979 C Find the largest exponent
4980       emin=contr(1)
4981       do j=1,nlobit
4982         if (emin.gt.contr(j)) emin=contr(j)
4983       enddo
4984       emin=0.5D0*emin
4985
4986 C Compute the contribution to SC energy and derivatives
4987
4988       dersc12=0.0d0
4989       do j=1,nlobit
4990         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4991         escloc_i=escloc_i+expfac
4992         do k=1,2
4993           dersc(k)=dersc(k)+Ax(k,j)*expfac
4994         enddo
4995         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4996      &            +gaussc(1,2,j,it))*expfac
4997         dersc(3)=0.0d0
4998       enddo
4999
5000       dersc(1)=dersc(1)/cos(theti)**2
5001       dersc12=dersc12/cos(theti)**2
5002       escloci=-(dlog(escloc_i)-emin)
5003       do j=1,2
5004         dersc(j)=dersc(j)/escloc_i
5005       enddo
5006       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5007       return
5008       end
5009 #else
5010 c----------------------------------------------------------------------------------
5011       subroutine esc(escloc)
5012 C Calculate the local energy of a side chain and its derivatives in the
5013 C corresponding virtual-bond valence angles THETA and the spherical angles
5014 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5015 C added by Urszula Kozlowska. 07/11/2007
5016 C
5017       implicit real*8 (a-h,o-z)
5018       include 'DIMENSIONS'
5019       include 'COMMON.GEO'
5020       include 'COMMON.LOCAL'
5021       include 'COMMON.VAR'
5022       include 'COMMON.SCROT'
5023       include 'COMMON.INTERACT'
5024       include 'COMMON.DERIV'
5025       include 'COMMON.CHAIN'
5026       include 'COMMON.IOUNITS'
5027       include 'COMMON.NAMES'
5028       include 'COMMON.FFIELD'
5029       include 'COMMON.CONTROL'
5030       include 'COMMON.VECTORS'
5031       double precision x_prime(3),y_prime(3),z_prime(3)
5032      &    , sumene,dsc_i,dp2_i,x(65),
5033      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5034      &    de_dxx,de_dyy,de_dzz,de_dt
5035       double precision s1_t,s1_6_t,s2_t,s2_6_t
5036       double precision
5037      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5038      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5039      & dt_dCi(3),dt_dCi1(3)
5040       common /sccalc/ time11,time12,time112,theti,it,nlobit
5041       delta=0.02d0*pi
5042       escloc=0.0D0
5043       do i=loc_start,loc_end
5044         if (itype(i).eq.21) cycle
5045         costtab(i+1) =dcos(theta(i+1))
5046         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5047         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5048         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5049         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5050         cosfac=dsqrt(cosfac2)
5051         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5052         sinfac=dsqrt(sinfac2)
5053         it=itype(i)
5054         if (it.eq.10) goto 1
5055 c
5056 C  Compute the axes of tghe local cartesian coordinates system; store in
5057 c   x_prime, y_prime and z_prime
5058 c
5059         do j=1,3
5060           x_prime(j) = 0.00
5061           y_prime(j) = 0.00
5062           z_prime(j) = 0.00
5063         enddo
5064 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5065 C     &   dc_norm(3,i+nres)
5066         do j = 1,3
5067           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5068           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5069         enddo
5070         do j = 1,3
5071           z_prime(j) = -uz(j,i-1)
5072         enddo
5073 c       write (2,*) "i",i
5074 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5075 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5076 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5077 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5078 c      & " xy",scalar(x_prime(1),y_prime(1)),
5079 c      & " xz",scalar(x_prime(1),z_prime(1)),
5080 c      & " yy",scalar(y_prime(1),y_prime(1)),
5081 c      & " yz",scalar(y_prime(1),z_prime(1)),
5082 c      & " zz",scalar(z_prime(1),z_prime(1))
5083 c
5084 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5085 C to local coordinate system. Store in xx, yy, zz.
5086 c
5087         xx=0.0d0
5088         yy=0.0d0
5089         zz=0.0d0
5090         do j = 1,3
5091           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5092           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5093           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5094         enddo
5095
5096         xxtab(i)=xx
5097         yytab(i)=yy
5098         zztab(i)=zz
5099 C
5100 C Compute the energy of the ith side cbain
5101 C
5102 c        write (2,*) "xx",xx," yy",yy," zz",zz
5103         it=itype(i)
5104         do j = 1,65
5105           x(j) = sc_parmin(j,it)
5106         enddo
5107 #ifdef CHECK_COORD
5108 Cc diagnostics - remove later
5109         xx1 = dcos(alph(2))
5110         yy1 = dsin(alph(2))*dcos(omeg(2))
5111         zz1 = -dsin(alph(2))*dsin(omeg(2))
5112         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5113      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5114      &    xx1,yy1,zz1
5115 C,"  --- ", xx_w,yy_w,zz_w
5116 c end diagnostics
5117 #endif
5118         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5119      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5120      &   + x(10)*yy*zz
5121         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5122      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5123      & + x(20)*yy*zz
5124         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5125      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5126      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5127      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5128      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5129      &  +x(40)*xx*yy*zz
5130         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5131      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5132      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5133      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5134      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5135      &  +x(60)*xx*yy*zz
5136         dsc_i   = 0.743d0+x(61)
5137         dp2_i   = 1.9d0+x(62)
5138         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5139      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5140         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5141      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5142         s1=(1+x(63))/(0.1d0 + dscp1)
5143         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5144         s2=(1+x(65))/(0.1d0 + dscp2)
5145         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5146         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5147      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5148 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5149 c     &   sumene4,
5150 c     &   dscp1,dscp2,sumene
5151 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5152         escloc = escloc + sumene
5153         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5154      &     'escloc',i,sumene
5155 c        write (2,*) "i",i," escloc",sumene,escloc
5156 #ifdef DEBUG
5157 C
5158 C This section to check the numerical derivatives of the energy of ith side
5159 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5160 C #define DEBUG in the code to turn it on.
5161 C
5162         write (2,*) "sumene               =",sumene
5163         aincr=1.0d-7
5164         xxsave=xx
5165         xx=xx+aincr
5166         write (2,*) xx,yy,zz
5167         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5168         de_dxx_num=(sumenep-sumene)/aincr
5169         xx=xxsave
5170         write (2,*) "xx+ sumene from enesc=",sumenep
5171         yysave=yy
5172         yy=yy+aincr
5173         write (2,*) xx,yy,zz
5174         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5175         de_dyy_num=(sumenep-sumene)/aincr
5176         yy=yysave
5177         write (2,*) "yy+ sumene from enesc=",sumenep
5178         zzsave=zz
5179         zz=zz+aincr
5180         write (2,*) xx,yy,zz
5181         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5182         de_dzz_num=(sumenep-sumene)/aincr
5183         zz=zzsave
5184         write (2,*) "zz+ sumene from enesc=",sumenep
5185         costsave=cost2tab(i+1)
5186         sintsave=sint2tab(i+1)
5187         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5188         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5189         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5190         de_dt_num=(sumenep-sumene)/aincr
5191         write (2,*) " t+ sumene from enesc=",sumenep
5192         cost2tab(i+1)=costsave
5193         sint2tab(i+1)=sintsave
5194 C End of diagnostics section.
5195 #endif
5196 C
5197 C Compute the gradient of esc
5198 C
5199         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5200         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5201         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5202         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5203         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5204         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5205         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5206         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5207         pom1=(sumene3*sint2tab(i+1)+sumene1)
5208      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5209         pom2=(sumene4*cost2tab(i+1)+sumene2)
5210      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5211         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5212         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5213      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5214      &  +x(40)*yy*zz
5215         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5216         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5217      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5218      &  +x(60)*yy*zz
5219         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5220      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5221      &        +(pom1+pom2)*pom_dx
5222 #ifdef DEBUG
5223         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5224 #endif
5225 C
5226         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5227         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5228      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5229      &  +x(40)*xx*zz
5230         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5231         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5232      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5233      &  +x(59)*zz**2 +x(60)*xx*zz
5234         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5235      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5236      &        +(pom1-pom2)*pom_dy
5237 #ifdef DEBUG
5238         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5239 #endif
5240 C
5241         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5242      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5243      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5244      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5245      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5246      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5247      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5248      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5249 #ifdef DEBUG
5250         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5251 #endif
5252 C
5253         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5254      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5255      &  +pom1*pom_dt1+pom2*pom_dt2
5256 #ifdef DEBUG
5257         write(2,*), "de_dt = ", de_dt,de_dt_num
5258 #endif
5259 c
5260 C
5261        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5262        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5263        cosfac2xx=cosfac2*xx
5264        sinfac2yy=sinfac2*yy
5265        do k = 1,3
5266          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5267      &      vbld_inv(i+1)
5268          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5269      &      vbld_inv(i)
5270          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5271          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5272 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5273 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5274 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5275 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5276          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5277          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5278          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5279          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5280          dZZ_Ci1(k)=0.0d0
5281          dZZ_Ci(k)=0.0d0
5282          do j=1,3
5283            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5284            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5285          enddo
5286
5287          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5288          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5289          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5290 c
5291          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5292          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5293        enddo
5294
5295        do k=1,3
5296          dXX_Ctab(k,i)=dXX_Ci(k)
5297          dXX_C1tab(k,i)=dXX_Ci1(k)
5298          dYY_Ctab(k,i)=dYY_Ci(k)
5299          dYY_C1tab(k,i)=dYY_Ci1(k)
5300          dZZ_Ctab(k,i)=dZZ_Ci(k)
5301          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5302          dXX_XYZtab(k,i)=dXX_XYZ(k)
5303          dYY_XYZtab(k,i)=dYY_XYZ(k)
5304          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5305        enddo
5306
5307        do k = 1,3
5308 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5309 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5310 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5311 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5312 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5313 c     &    dt_dci(k)
5314 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5315 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5316          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5317      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5318          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5319      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5320          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5321      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5322        enddo
5323 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5324 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5325
5326 C to check gradient call subroutine check_grad
5327
5328     1 continue
5329       enddo
5330       return
5331       end
5332 c------------------------------------------------------------------------------
5333       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5334       implicit none
5335       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5336      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5337       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5338      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5339      &   + x(10)*yy*zz
5340       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5341      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5342      & + x(20)*yy*zz
5343       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5344      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5345      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5346      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5347      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5348      &  +x(40)*xx*yy*zz
5349       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5350      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5351      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5352      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5353      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5354      &  +x(60)*xx*yy*zz
5355       dsc_i   = 0.743d0+x(61)
5356       dp2_i   = 1.9d0+x(62)
5357       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5358      &          *(xx*cost2+yy*sint2))
5359       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5360      &          *(xx*cost2-yy*sint2))
5361       s1=(1+x(63))/(0.1d0 + dscp1)
5362       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5363       s2=(1+x(65))/(0.1d0 + dscp2)
5364       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5365       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5366      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5367       enesc=sumene
5368       return
5369       end
5370 #endif
5371 c------------------------------------------------------------------------------
5372       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5373 C
5374 C This procedure calculates two-body contact function g(rij) and its derivative:
5375 C
5376 C           eps0ij                                     !       x < -1
5377 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5378 C            0                                         !       x > 1
5379 C
5380 C where x=(rij-r0ij)/delta
5381 C
5382 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5383 C
5384       implicit none
5385       double precision rij,r0ij,eps0ij,fcont,fprimcont
5386       double precision x,x2,x4,delta
5387 c     delta=0.02D0*r0ij
5388 c      delta=0.2D0*r0ij
5389       x=(rij-r0ij)/delta
5390       if (x.lt.-1.0D0) then
5391         fcont=eps0ij
5392         fprimcont=0.0D0
5393       else if (x.le.1.0D0) then
5394         x2=x*x
5395         x4=x2*x2
5396         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5397         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5398       else
5399         fcont=0.0D0
5400         fprimcont=0.0D0
5401       endif
5402       return
5403       end
5404 c------------------------------------------------------------------------------
5405       subroutine splinthet(theti,delta,ss,ssder)
5406       implicit real*8 (a-h,o-z)
5407       include 'DIMENSIONS'
5408       include 'COMMON.VAR'
5409       include 'COMMON.GEO'
5410       thetup=pi-delta
5411       thetlow=delta
5412       if (theti.gt.pipol) then
5413         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5414       else
5415         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5416         ssder=-ssder
5417       endif
5418       return
5419       end
5420 c------------------------------------------------------------------------------
5421       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5422       implicit none
5423       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5424       double precision ksi,ksi2,ksi3,a1,a2,a3
5425       a1=fprim0*delta/(f1-f0)
5426       a2=3.0d0-2.0d0*a1
5427       a3=a1-2.0d0
5428       ksi=(x-x0)/delta
5429       ksi2=ksi*ksi
5430       ksi3=ksi2*ksi
5431       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5432       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5433       return
5434       end
5435 c------------------------------------------------------------------------------
5436       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5437       implicit none
5438       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5439       double precision ksi,ksi2,ksi3,a1,a2,a3
5440       ksi=(x-x0)/delta
5441       ksi2=ksi*ksi
5442       ksi3=ksi2*ksi
5443       a1=fprim0x*delta
5444       a2=3*(f1x-f0x)-2*fprim0x*delta
5445       a3=fprim0x*delta-2*(f1x-f0x)
5446       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5447       return
5448       end
5449 C-----------------------------------------------------------------------------
5450 #ifdef CRYST_TOR
5451 C-----------------------------------------------------------------------------
5452       subroutine etor(etors,edihcnstr)
5453       implicit real*8 (a-h,o-z)
5454       include 'DIMENSIONS'
5455       include 'COMMON.VAR'
5456       include 'COMMON.GEO'
5457       include 'COMMON.LOCAL'
5458       include 'COMMON.TORSION'
5459       include 'COMMON.INTERACT'
5460       include 'COMMON.DERIV'
5461       include 'COMMON.CHAIN'
5462       include 'COMMON.NAMES'
5463       include 'COMMON.IOUNITS'
5464       include 'COMMON.FFIELD'
5465       include 'COMMON.TORCNSTR'
5466       include 'COMMON.CONTROL'
5467       logical lprn
5468 C Set lprn=.true. for debugging
5469       lprn=.false.
5470 c      lprn=.true.
5471       etors=0.0D0
5472       do i=iphi_start,iphi_end
5473       etors_ii=0.0D0
5474         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5475      &      .or. itype(i).eq.21) cycle
5476         itori=itortyp(itype(i-2))
5477         itori1=itortyp(itype(i-1))
5478         phii=phi(i)
5479         gloci=0.0D0
5480 C Proline-Proline pair is a special case...
5481         if (itori.eq.3 .and. itori1.eq.3) then
5482           if (phii.gt.-dwapi3) then
5483             cosphi=dcos(3*phii)
5484             fac=1.0D0/(1.0D0-cosphi)
5485             etorsi=v1(1,3,3)*fac
5486             etorsi=etorsi+etorsi
5487             etors=etors+etorsi-v1(1,3,3)
5488             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5489             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5490           endif
5491           do j=1,3
5492             v1ij=v1(j+1,itori,itori1)
5493             v2ij=v2(j+1,itori,itori1)
5494             cosphi=dcos(j*phii)
5495             sinphi=dsin(j*phii)
5496             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5497             if (energy_dec) etors_ii=etors_ii+
5498      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5499             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5500           enddo
5501         else
5502           do j=1,nterm_old
5503             v1ij=v1(j,itori,itori1)
5504             v2ij=v2(j,itori,itori1)
5505             cosphi=dcos(j*phii)
5506             sinphi=dsin(j*phii)
5507             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5508             if (energy_dec) etors_ii=etors_ii+
5509      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5510             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5511           enddo
5512         endif
5513         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5514              'etor',i,etors_ii
5515         if (lprn)
5516      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5517      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5518      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5519         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5520 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5521       enddo
5522 ! 6/20/98 - dihedral angle constraints
5523       edihcnstr=0.0d0
5524       do i=1,ndih_constr
5525         itori=idih_constr(i)
5526         phii=phi(itori)
5527         difi=phii-phi0(i)
5528         if (difi.gt.drange(i)) then
5529           difi=difi-drange(i)
5530           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5531           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5532         else if (difi.lt.-drange(i)) then
5533           difi=difi+drange(i)
5534           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5535           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5536         endif
5537 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5538 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5539       enddo
5540 !      write (iout,*) 'edihcnstr',edihcnstr
5541       return
5542       end
5543 c------------------------------------------------------------------------------
5544       subroutine etor_d(etors_d)
5545       etors_d=0.0d0
5546       return
5547       end
5548 c----------------------------------------------------------------------------
5549 #else
5550       subroutine etor(etors,edihcnstr)
5551       implicit real*8 (a-h,o-z)
5552       include 'DIMENSIONS'
5553       include 'COMMON.VAR'
5554       include 'COMMON.GEO'
5555       include 'COMMON.LOCAL'
5556       include 'COMMON.TORSION'
5557       include 'COMMON.INTERACT'
5558       include 'COMMON.DERIV'
5559       include 'COMMON.CHAIN'
5560       include 'COMMON.NAMES'
5561       include 'COMMON.IOUNITS'
5562       include 'COMMON.FFIELD'
5563       include 'COMMON.TORCNSTR'
5564       include 'COMMON.CONTROL'
5565       logical lprn
5566 C Set lprn=.true. for debugging
5567       lprn=.false.
5568 c     lprn=.true.
5569       etors=0.0D0
5570       do i=iphi_start,iphi_end
5571         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5572      &       .or. itype(i).eq.21
5573      &       .or. itype(i-3).eq.ntyp1) cycle
5574       etors_ii=0.0D0
5575         itori=itortyp(itype(i-2))
5576         itori1=itortyp(itype(i-1))
5577         phii=phi(i)
5578         gloci=0.0D0
5579 C Regular cosine and sine terms
5580         do j=1,nterm(itori,itori1)
5581           v1ij=v1(j,itori,itori1)
5582           v2ij=v2(j,itori,itori1)
5583           cosphi=dcos(j*phii)
5584           sinphi=dsin(j*phii)
5585           etors=etors+v1ij*cosphi+v2ij*sinphi
5586           if (energy_dec) etors_ii=etors_ii+
5587      &                v1ij*cosphi+v2ij*sinphi
5588           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5589         enddo
5590 C Lorentz terms
5591 C                         v1
5592 C  E = SUM ----------------------------------- - v1
5593 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5594 C
5595         cosphi=dcos(0.5d0*phii)
5596         sinphi=dsin(0.5d0*phii)
5597         do j=1,nlor(itori,itori1)
5598           vl1ij=vlor1(j,itori,itori1)
5599           vl2ij=vlor2(j,itori,itori1)
5600           vl3ij=vlor3(j,itori,itori1)
5601           pom=vl2ij*cosphi+vl3ij*sinphi
5602           pom1=1.0d0/(pom*pom+1.0d0)
5603           etors=etors+vl1ij*pom1
5604           if (energy_dec) etors_ii=etors_ii+
5605      &                vl1ij*pom1
5606           pom=-pom*pom1*pom1
5607           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5608         enddo
5609 C Subtract the constant term
5610         etors=etors-v0(itori,itori1)
5611           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5612      &         'etor',i,etors_ii-v0(itori,itori1)
5613         if (lprn)
5614      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5615      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5616      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5617         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5618 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5619       enddo
5620 ! 6/20/98 - dihedral angle constraints
5621       edihcnstr=0.0d0
5622 c      do i=1,ndih_constr
5623       do i=idihconstr_start,idihconstr_end
5624         itori=idih_constr(i)
5625         phii=phi(itori)
5626         difi=pinorm(phii-phi0(i))
5627         if (difi.gt.drange(i)) then
5628           difi=difi-drange(i)
5629           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5630           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5631         else if (difi.lt.-drange(i)) then
5632           difi=difi+drange(i)
5633           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5634           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5635         else
5636           difi=0.0
5637         endif
5638 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5639 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5640 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5641       enddo
5642 cd       write (iout,*) 'edihcnstr',edihcnstr
5643       return
5644       end
5645 c----------------------------------------------------------------------------
5646       subroutine etor_d(etors_d)
5647 C 6/23/01 Compute double torsional energy
5648       implicit real*8 (a-h,o-z)
5649       include 'DIMENSIONS'
5650       include 'COMMON.VAR'
5651       include 'COMMON.GEO'
5652       include 'COMMON.LOCAL'
5653       include 'COMMON.TORSION'
5654       include 'COMMON.INTERACT'
5655       include 'COMMON.DERIV'
5656       include 'COMMON.CHAIN'
5657       include 'COMMON.NAMES'
5658       include 'COMMON.IOUNITS'
5659       include 'COMMON.FFIELD'
5660       include 'COMMON.TORCNSTR'
5661       include 'COMMON.CONTROL'
5662       logical lprn
5663 C Set lprn=.true. for debugging
5664       lprn=.false.
5665 c     lprn=.true.
5666       etors_d=0.0D0
5667 C      write(iout,*) "a tu??"
5668       do i=iphid_start,iphid_end
5669         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5670      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21
5671      &       .or. itype(i-3).eq.ntyp1) cycle
5672         etors_d_ii=0.0D0
5673         itori=itortyp(itype(i-2))
5674         itori1=itortyp(itype(i-1))
5675         itori2=itortyp(itype(i))
5676         phii=phi(i)
5677         phii1=phi(i+1)
5678         gloci1=0.0D0
5679         gloci2=0.0D0
5680 C Regular cosine and sine terms
5681         do j=1,ntermd_1(itori,itori1,itori2)
5682           v1cij=v1c(1,j,itori,itori1,itori2)
5683           v1sij=v1s(1,j,itori,itori1,itori2)
5684           v2cij=v1c(2,j,itori,itori1,itori2)
5685           v2sij=v1s(2,j,itori,itori1,itori2)
5686           cosphi1=dcos(j*phii)
5687           sinphi1=dsin(j*phii)
5688           cosphi2=dcos(j*phii1)
5689           sinphi2=dsin(j*phii1)
5690           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5691      &     v2cij*cosphi2+v2sij*sinphi2
5692           if (energy_dec) etors_d_ii=etors_d_ii+
5693      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5694           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5695           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5696         enddo
5697         do k=2,ntermd_2(itori,itori1,itori2)
5698           do l=1,k-1
5699             v1cdij = v2c(k,l,itori,itori1,itori2)
5700             v2cdij = v2c(l,k,itori,itori1,itori2)
5701             v1sdij = v2s(k,l,itori,itori1,itori2)
5702             v2sdij = v2s(l,k,itori,itori1,itori2)
5703             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5704             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5705             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5706             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5707             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5708      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5709             if (energy_dec) etors_d_ii=etors_d_ii+
5710      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5711      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5712             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5713      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5714             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5715      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5716           enddo
5717         enddo
5718           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5719      &         'etor_d',i,etors_d_ii
5720         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5721         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5722       enddo
5723       return
5724       end
5725 #endif
5726 c------------------------------------------------------------------------------
5727       subroutine eback_sc_corr(esccor)
5728 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5729 c        conformational states; temporarily implemented as differences
5730 c        between UNRES torsional potentials (dependent on three types of
5731 c        residues) and the torsional potentials dependent on all 20 types
5732 c        of residues computed from AM1  energy surfaces of terminally-blocked
5733 c        amino-acid residues.
5734       implicit real*8 (a-h,o-z)
5735       include 'DIMENSIONS'
5736       include 'COMMON.VAR'
5737       include 'COMMON.GEO'
5738       include 'COMMON.LOCAL'
5739       include 'COMMON.TORSION'
5740       include 'COMMON.SCCOR'
5741       include 'COMMON.INTERACT'
5742       include 'COMMON.DERIV'
5743       include 'COMMON.CHAIN'
5744       include 'COMMON.NAMES'
5745       include 'COMMON.IOUNITS'
5746       include 'COMMON.FFIELD'
5747       include 'COMMON.CONTROL'
5748       logical lprn
5749 C Set lprn=.true. for debugging
5750       lprn=.false.
5751 c      lprn=.true.
5752 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5753       esccor=0.0D0
5754       do i=itau_start,itau_end
5755         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5756
5757         isccori=isccortyp(itype(i-2))
5758         isccori1=isccortyp(itype(i-1))
5759 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5760         phii=phi(i)
5761         do intertyp=1,3 !intertyp
5762          esccor_ii=0.0D0
5763 cc Added 09 May 2012 (Adasko)
5764 cc  Intertyp means interaction type of backbone mainchain correlation:
5765 c   1 = SC...Ca...Ca...Ca
5766 c   2 = Ca...Ca...Ca...SC
5767 c   3 = SC...Ca...Ca...SCi
5768         gloci=0.0D0
5769         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5770      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5771      &      (itype(i-1).eq.ntyp1)))
5772      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5773      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5774      &     .or.(itype(i).eq.ntyp1)))
5775      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5776      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5777      &      (itype(i-3).eq.ntyp1)))) cycle
5778         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5779         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5780      & cycle
5781        do j=1,nterm_sccor(isccori,isccori1)
5782           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5783           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5784           cosphi=dcos(j*tauangle(intertyp,i))
5785           sinphi=dsin(j*tauangle(intertyp,i))
5786           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5787           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5788           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5789         enddo
5790           if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
5791      &         'esccor',i,intertyp,esccor_ii
5792 cd       write (iout,*) "tau ",i,intertyp,tauangle(intertyp,i)*RAD2DEG
5793 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5794         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5795         if (lprn)
5796      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5797      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5798      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5799      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5800         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5801        enddo !intertyp
5802       enddo
5803
5804       return
5805       end
5806 c----------------------------------------------------------------------------
5807       subroutine multibody(ecorr)
5808 C This subroutine calculates multi-body contributions to energy following
5809 C the idea of Skolnick et al. If side chains I and J make a contact and
5810 C at the same time side chains I+1 and J+1 make a contact, an extra
5811 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5812       implicit real*8 (a-h,o-z)
5813       include 'DIMENSIONS'
5814       include 'COMMON.IOUNITS'
5815       include 'COMMON.DERIV'
5816       include 'COMMON.INTERACT'
5817       include 'COMMON.CONTACTS'
5818       double precision gx(3),gx1(3)
5819       logical lprn
5820
5821 C Set lprn=.true. for debugging
5822       lprn=.false.
5823
5824       if (lprn) then
5825         write (iout,'(a)') 'Contact function values:'
5826         do i=nnt,nct-2
5827           write (iout,'(i2,20(1x,i2,f10.5))')
5828      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5829         enddo
5830       endif
5831       ecorr=0.0D0
5832       do i=nnt,nct
5833         do j=1,3
5834           gradcorr(j,i)=0.0D0
5835           gradxorr(j,i)=0.0D0
5836         enddo
5837       enddo
5838       do i=nnt,nct-2
5839
5840         DO ISHIFT = 3,4
5841
5842         i1=i+ishift
5843         num_conti=num_cont(i)
5844         num_conti1=num_cont(i1)
5845         do jj=1,num_conti
5846           j=jcont(jj,i)
5847           do kk=1,num_conti1
5848             j1=jcont(kk,i1)
5849             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5850 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5851 cd   &                   ' ishift=',ishift
5852 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5853 C The system gains extra energy.
5854               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5855             endif   ! j1==j+-ishift
5856           enddo     ! kk
5857         enddo       ! jj
5858
5859         ENDDO ! ISHIFT
5860
5861       enddo         ! i
5862       return
5863       end
5864 c------------------------------------------------------------------------------
5865       double precision function esccorr(i,j,k,l,jj,kk)
5866       implicit real*8 (a-h,o-z)
5867       include 'DIMENSIONS'
5868       include 'COMMON.IOUNITS'
5869       include 'COMMON.DERIV'
5870       include 'COMMON.INTERACT'
5871       include 'COMMON.CONTACTS'
5872       double precision gx(3),gx1(3)
5873       logical lprn
5874       lprn=.false.
5875       eij=facont(jj,i)
5876       ekl=facont(kk,k)
5877 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5878 C Calculate the multi-body contribution to energy.
5879 C Calculate multi-body contributions to the gradient.
5880 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5881 cd   & k,l,(gacont(m,kk,k),m=1,3)
5882       do m=1,3
5883         gx(m) =ekl*gacont(m,jj,i)
5884         gx1(m)=eij*gacont(m,kk,k)
5885         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5886         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5887         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5888         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5889       enddo
5890       do m=i,j-1
5891         do ll=1,3
5892           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5893         enddo
5894       enddo
5895       do m=k,l-1
5896         do ll=1,3
5897           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5898         enddo
5899       enddo
5900       esccorr=-eij*ekl
5901       return
5902       end
5903 c------------------------------------------------------------------------------
5904       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5905 C This subroutine calculates multi-body contributions to hydrogen-bonding
5906       implicit real*8 (a-h,o-z)
5907       include 'DIMENSIONS'
5908       include 'COMMON.IOUNITS'
5909 #ifdef MPI
5910       include "mpif.h"
5911       parameter (max_cont=maxconts)
5912       parameter (max_dim=26)
5913       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5914       double precision zapas(max_dim,maxconts,max_fg_procs),
5915      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5916       common /przechowalnia/ zapas
5917       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5918      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5919 #endif
5920       include 'COMMON.SETUP'
5921       include 'COMMON.FFIELD'
5922       include 'COMMON.DERIV'
5923       include 'COMMON.INTERACT'
5924       include 'COMMON.CONTACTS'
5925       include 'COMMON.CONTROL'
5926       include 'COMMON.LOCAL'
5927       double precision gx(3),gx1(3),time00
5928       logical lprn,ldone
5929
5930 C Set lprn=.true. for debugging
5931       lprn=.false.
5932 #ifdef MPI
5933       n_corr=0
5934       n_corr1=0
5935       if (nfgtasks.le.1) goto 30
5936       if (lprn) then
5937         write (iout,'(a)') 'Contact function values before RECEIVE:'
5938         do i=nnt,nct-2
5939           write (iout,'(2i3,50(1x,i2,f5.2))')
5940      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5941      &    j=1,num_cont_hb(i))
5942         enddo
5943       endif
5944       call flush(iout)
5945       do i=1,ntask_cont_from
5946         ncont_recv(i)=0
5947       enddo
5948       do i=1,ntask_cont_to
5949         ncont_sent(i)=0
5950       enddo
5951 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5952 c     & ntask_cont_to
5953 C Make the list of contacts to send to send to other procesors
5954 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5955 c      call flush(iout)
5956       do i=iturn3_start,iturn3_end
5957 c        write (iout,*) "make contact list turn3",i," num_cont",
5958 c     &    num_cont_hb(i)
5959         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5960       enddo
5961       do i=iturn4_start,iturn4_end
5962 c        write (iout,*) "make contact list turn4",i," num_cont",
5963 c     &   num_cont_hb(i)
5964         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5965       enddo
5966       do ii=1,nat_sent
5967         i=iat_sent(ii)
5968 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5969 c     &    num_cont_hb(i)
5970         do j=1,num_cont_hb(i)
5971         do k=1,4
5972           jjc=jcont_hb(j,i)
5973           iproc=iint_sent_local(k,jjc,ii)
5974 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5975           if (iproc.gt.0) then
5976             ncont_sent(iproc)=ncont_sent(iproc)+1
5977             nn=ncont_sent(iproc)
5978             zapas(1,nn,iproc)=i
5979             zapas(2,nn,iproc)=jjc
5980             zapas(3,nn,iproc)=facont_hb(j,i)
5981             zapas(4,nn,iproc)=ees0p(j,i)
5982             zapas(5,nn,iproc)=ees0m(j,i)
5983             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5984             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5985             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5986             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5987             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5988             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5989             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5990             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5991             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5992             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5993             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5994             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5995             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5996             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5997             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5998             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5999             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6000             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6001             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6002             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6003             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6004           endif
6005         enddo
6006         enddo
6007       enddo
6008       if (lprn) then
6009       write (iout,*)
6010      &  "Numbers of contacts to be sent to other processors",
6011      &  (ncont_sent(i),i=1,ntask_cont_to)
6012       write (iout,*) "Contacts sent"
6013       do ii=1,ntask_cont_to
6014         nn=ncont_sent(ii)
6015         iproc=itask_cont_to(ii)
6016         write (iout,*) nn," contacts to processor",iproc,
6017      &   " of CONT_TO_COMM group"
6018         do i=1,nn
6019           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6020         enddo
6021       enddo
6022       call flush(iout)
6023       endif
6024       CorrelType=477
6025       CorrelID=fg_rank+1
6026       CorrelType1=478
6027       CorrelID1=nfgtasks+fg_rank+1
6028       ireq=0
6029 C Receive the numbers of needed contacts from other processors
6030       do ii=1,ntask_cont_from
6031         iproc=itask_cont_from(ii)
6032         ireq=ireq+1
6033         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6034      &    FG_COMM,req(ireq),IERR)
6035       enddo
6036 c      write (iout,*) "IRECV ended"
6037 c      call flush(iout)
6038 C Send the number of contacts needed by other processors
6039       do ii=1,ntask_cont_to
6040         iproc=itask_cont_to(ii)
6041         ireq=ireq+1
6042         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6043      &    FG_COMM,req(ireq),IERR)
6044       enddo
6045 c      write (iout,*) "ISEND ended"
6046 c      write (iout,*) "number of requests (nn)",ireq
6047       call flush(iout)
6048       if (ireq.gt.0)
6049      &  call MPI_Waitall(ireq,req,status_array,ierr)
6050 c      write (iout,*)
6051 c     &  "Numbers of contacts to be received from other processors",
6052 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6053 c      call flush(iout)
6054 C Receive contacts
6055       ireq=0
6056       do ii=1,ntask_cont_from
6057         iproc=itask_cont_from(ii)
6058         nn=ncont_recv(ii)
6059 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6060 c     &   " of CONT_TO_COMM group"
6061         call flush(iout)
6062         if (nn.gt.0) then
6063           ireq=ireq+1
6064           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6065      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6066 c          write (iout,*) "ireq,req",ireq,req(ireq)
6067         endif
6068       enddo
6069 C Send the contacts to processors that need them
6070       do ii=1,ntask_cont_to
6071         iproc=itask_cont_to(ii)
6072         nn=ncont_sent(ii)
6073 c        write (iout,*) nn," contacts to processor",iproc,
6074 c     &   " of CONT_TO_COMM group"
6075         if (nn.gt.0) then
6076           ireq=ireq+1
6077           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6078      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6079 c          write (iout,*) "ireq,req",ireq,req(ireq)
6080 c          do i=1,nn
6081 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6082 c          enddo
6083         endif
6084       enddo
6085 c      write (iout,*) "number of requests (contacts)",ireq
6086 c      write (iout,*) "req",(req(i),i=1,4)
6087 c      call flush(iout)
6088       if (ireq.gt.0)
6089      & call MPI_Waitall(ireq,req,status_array,ierr)
6090       do iii=1,ntask_cont_from
6091         iproc=itask_cont_from(iii)
6092         nn=ncont_recv(iii)
6093         if (lprn) then
6094         write (iout,*) "Received",nn," contacts from processor",iproc,
6095      &   " of CONT_FROM_COMM group"
6096         call flush(iout)
6097         do i=1,nn
6098           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6099         enddo
6100         call flush(iout)
6101         endif
6102         do i=1,nn
6103           ii=zapas_recv(1,i,iii)
6104 c Flag the received contacts to prevent double-counting
6105           jj=-zapas_recv(2,i,iii)
6106 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6107 c          call flush(iout)
6108           nnn=num_cont_hb(ii)+1
6109           num_cont_hb(ii)=nnn
6110           jcont_hb(nnn,ii)=jj
6111           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6112           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6113           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6114           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6115           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6116           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6117           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6118           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6119           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6120           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6121           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6122           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6123           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6124           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6125           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6126           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6127           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6128           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6129           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6130           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6131           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6132           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6133           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6134           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6135         enddo
6136       enddo
6137       call flush(iout)
6138       if (lprn) then
6139         write (iout,'(a)') 'Contact function values after receive:'
6140         do i=nnt,nct-2
6141           write (iout,'(2i3,50(1x,i3,f5.2))')
6142      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6143      &    j=1,num_cont_hb(i))
6144         enddo
6145         call flush(iout)
6146       endif
6147    30 continue
6148 #endif
6149       if (lprn) then
6150         write (iout,'(a)') 'Contact function values:'
6151         do i=nnt,nct-2
6152           write (iout,'(2i3,50(1x,i3,f5.2))')
6153      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6154      &    j=1,num_cont_hb(i))
6155         enddo
6156       endif
6157       ecorr=0.0D0
6158 C Remove the loop below after debugging !!!
6159       do i=nnt,nct
6160         do j=1,3
6161           gradcorr(j,i)=0.0D0
6162           gradxorr(j,i)=0.0D0
6163         enddo
6164       enddo
6165 C Calculate the local-electrostatic correlation terms
6166       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6167         i1=i+1
6168         num_conti=num_cont_hb(i)
6169         num_conti1=num_cont_hb(i+1)
6170         do jj=1,num_conti
6171           j=jcont_hb(jj,i)
6172           jp=iabs(j)
6173           do kk=1,num_conti1
6174             j1=jcont_hb(kk,i1)
6175             jp1=iabs(j1)
6176 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6177 c     &         ' jj=',jj,' kk=',kk
6178             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6179      &          .or. j.lt.0 .and. j1.gt.0) .and.
6180      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6181 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6182 C The system gains extra energy.
6183               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6184               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6185      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6186               n_corr=n_corr+1
6187             else if (j1.eq.j) then
6188 C Contacts I-J and I-(J+1) occur simultaneously.
6189 C The system loses extra energy.
6190 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6191             endif
6192           enddo ! kk
6193           do kk=1,num_conti
6194             j1=jcont_hb(kk,i)
6195 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6196 c    &         ' jj=',jj,' kk=',kk
6197             if (j1.eq.j+1) then
6198 C Contacts I-J and (I+1)-J occur simultaneously.
6199 C The system loses extra energy.
6200 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6201             endif ! j1==j+1
6202           enddo ! kk
6203         enddo ! jj
6204       enddo ! i
6205       return
6206       end
6207 c------------------------------------------------------------------------------
6208       subroutine add_hb_contact(ii,jj,itask)
6209       implicit real*8 (a-h,o-z)
6210       include "DIMENSIONS"
6211       include "COMMON.IOUNITS"
6212       integer max_cont
6213       integer max_dim
6214       parameter (max_cont=maxconts)
6215       parameter (max_dim=26)
6216       include "COMMON.CONTACTS"
6217       double precision zapas(max_dim,maxconts,max_fg_procs),
6218      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6219       common /przechowalnia/ zapas
6220       integer i,j,ii,jj,iproc,itask(4),nn
6221 c      write (iout,*) "itask",itask
6222       do i=1,2
6223         iproc=itask(i)
6224         if (iproc.gt.0) then
6225           do j=1,num_cont_hb(ii)
6226             jjc=jcont_hb(j,ii)
6227 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6228             if (jjc.eq.jj) then
6229               ncont_sent(iproc)=ncont_sent(iproc)+1
6230               nn=ncont_sent(iproc)
6231               zapas(1,nn,iproc)=ii
6232               zapas(2,nn,iproc)=jjc
6233               zapas(3,nn,iproc)=facont_hb(j,ii)
6234               zapas(4,nn,iproc)=ees0p(j,ii)
6235               zapas(5,nn,iproc)=ees0m(j,ii)
6236               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6237               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6238               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6239               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6240               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6241               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6242               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6243               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6244               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6245               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6246               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6247               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6248               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6249               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6250               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6251               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6252               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6253               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6254               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6255               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6256               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6257               exit
6258             endif
6259           enddo
6260         endif
6261       enddo
6262       return
6263       end
6264 c------------------------------------------------------------------------------
6265       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6266      &  n_corr1)
6267 C This subroutine calculates multi-body contributions to hydrogen-bonding
6268       implicit real*8 (a-h,o-z)
6269       include 'DIMENSIONS'
6270       include 'COMMON.IOUNITS'
6271 #ifdef MPI
6272       include "mpif.h"
6273       parameter (max_cont=maxconts)
6274       parameter (max_dim=70)
6275       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6276       double precision zapas(max_dim,maxconts,max_fg_procs),
6277      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6278       common /przechowalnia/ zapas
6279       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6280      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6281 #endif
6282       include 'COMMON.SETUP'
6283       include 'COMMON.FFIELD'
6284       include 'COMMON.DERIV'
6285       include 'COMMON.LOCAL'
6286       include 'COMMON.INTERACT'
6287       include 'COMMON.CONTACTS'
6288       include 'COMMON.CHAIN'
6289       include 'COMMON.CONTROL'
6290       double precision gx(3),gx1(3)
6291       integer num_cont_hb_old(maxres)
6292       logical lprn,ldone
6293       double precision eello4,eello5,eelo6,eello_turn6
6294       external eello4,eello5,eello6,eello_turn6
6295 C Set lprn=.true. for debugging
6296       lprn=.false.
6297       eturn6=0.0d0
6298 #ifdef MPI
6299       do i=1,nres
6300         num_cont_hb_old(i)=num_cont_hb(i)
6301       enddo
6302       n_corr=0
6303       n_corr1=0
6304       if (nfgtasks.le.1) goto 30
6305       if (lprn) then
6306         write (iout,'(a)') 'Contact function values before RECEIVE:'
6307         do i=nnt,nct-2
6308           write (iout,'(2i3,50(1x,i2,f5.2))')
6309      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6310      &    j=1,num_cont_hb(i))
6311         enddo
6312       endif
6313       call flush(iout)
6314       do i=1,ntask_cont_from
6315         ncont_recv(i)=0
6316       enddo
6317       do i=1,ntask_cont_to
6318         ncont_sent(i)=0
6319       enddo
6320 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6321 c     & ntask_cont_to
6322 C Make the list of contacts to send to send to other procesors
6323       do i=iturn3_start,iturn3_end
6324 c        write (iout,*) "make contact list turn3",i," num_cont",
6325 c     &    num_cont_hb(i)
6326         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6327       enddo
6328       do i=iturn4_start,iturn4_end
6329 c        write (iout,*) "make contact list turn4",i," num_cont",
6330 c     &   num_cont_hb(i)
6331         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6332       enddo
6333       do ii=1,nat_sent
6334         i=iat_sent(ii)
6335 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6336 c     &    num_cont_hb(i)
6337         do j=1,num_cont_hb(i)
6338         do k=1,4
6339           jjc=jcont_hb(j,i)
6340           iproc=iint_sent_local(k,jjc,ii)
6341 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6342           if (iproc.ne.0) then
6343             ncont_sent(iproc)=ncont_sent(iproc)+1
6344             nn=ncont_sent(iproc)
6345             zapas(1,nn,iproc)=i
6346             zapas(2,nn,iproc)=jjc
6347             zapas(3,nn,iproc)=d_cont(j,i)
6348             ind=3
6349             do kk=1,3
6350               ind=ind+1
6351               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6352             enddo
6353             do kk=1,2
6354               do ll=1,2
6355                 ind=ind+1
6356                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6357               enddo
6358             enddo
6359             do jj=1,5
6360               do kk=1,3
6361                 do ll=1,2
6362                   do mm=1,2
6363                     ind=ind+1
6364                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6365                   enddo
6366                 enddo
6367               enddo
6368             enddo
6369           endif
6370         enddo
6371         enddo
6372       enddo
6373       if (lprn) then
6374       write (iout,*)
6375      &  "Numbers of contacts to be sent to other processors",
6376      &  (ncont_sent(i),i=1,ntask_cont_to)
6377       write (iout,*) "Contacts sent"
6378       do ii=1,ntask_cont_to
6379         nn=ncont_sent(ii)
6380         iproc=itask_cont_to(ii)
6381         write (iout,*) nn," contacts to processor",iproc,
6382      &   " of CONT_TO_COMM group"
6383         do i=1,nn
6384           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6385         enddo
6386       enddo
6387       call flush(iout)
6388       endif
6389       CorrelType=477
6390       CorrelID=fg_rank+1
6391       CorrelType1=478
6392       CorrelID1=nfgtasks+fg_rank+1
6393       ireq=0
6394 C Receive the numbers of needed contacts from other processors
6395       do ii=1,ntask_cont_from
6396         iproc=itask_cont_from(ii)
6397         ireq=ireq+1
6398         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6399      &    FG_COMM,req(ireq),IERR)
6400       enddo
6401 c      write (iout,*) "IRECV ended"
6402 c      call flush(iout)
6403 C Send the number of contacts needed by other processors
6404       do ii=1,ntask_cont_to
6405         iproc=itask_cont_to(ii)
6406         ireq=ireq+1
6407         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6408      &    FG_COMM,req(ireq),IERR)
6409       enddo
6410 c      write (iout,*) "ISEND ended"
6411 c      write (iout,*) "number of requests (nn)",ireq
6412       call flush(iout)
6413       if (ireq.gt.0)
6414      &  call MPI_Waitall(ireq,req,status_array,ierr)
6415 c      write (iout,*)
6416 c     &  "Numbers of contacts to be received from other processors",
6417 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6418 c      call flush(iout)
6419 C Receive contacts
6420       ireq=0
6421       do ii=1,ntask_cont_from
6422         iproc=itask_cont_from(ii)
6423         nn=ncont_recv(ii)
6424 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6425 c     &   " of CONT_TO_COMM group"
6426         call flush(iout)
6427         if (nn.gt.0) then
6428           ireq=ireq+1
6429           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6430      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6431 c          write (iout,*) "ireq,req",ireq,req(ireq)
6432         endif
6433       enddo
6434 C Send the contacts to processors that need them
6435       do ii=1,ntask_cont_to
6436         iproc=itask_cont_to(ii)
6437         nn=ncont_sent(ii)
6438 c        write (iout,*) nn," contacts to processor",iproc,
6439 c     &   " of CONT_TO_COMM group"
6440         if (nn.gt.0) then
6441           ireq=ireq+1
6442           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6443      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6444 c          write (iout,*) "ireq,req",ireq,req(ireq)
6445 c          do i=1,nn
6446 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6447 c          enddo
6448         endif
6449       enddo
6450 c      write (iout,*) "number of requests (contacts)",ireq
6451 c      write (iout,*) "req",(req(i),i=1,4)
6452 c      call flush(iout)
6453       if (ireq.gt.0)
6454      & call MPI_Waitall(ireq,req,status_array,ierr)
6455       do iii=1,ntask_cont_from
6456         iproc=itask_cont_from(iii)
6457         nn=ncont_recv(iii)
6458         if (lprn) then
6459         write (iout,*) "Received",nn," contacts from processor",iproc,
6460      &   " of CONT_FROM_COMM group"
6461         call flush(iout)
6462         do i=1,nn
6463           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6464         enddo
6465         call flush(iout)
6466         endif
6467         do i=1,nn
6468           ii=zapas_recv(1,i,iii)
6469 c Flag the received contacts to prevent double-counting
6470           jj=-zapas_recv(2,i,iii)
6471 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6472 c          call flush(iout)
6473           nnn=num_cont_hb(ii)+1
6474           num_cont_hb(ii)=nnn
6475           jcont_hb(nnn,ii)=jj
6476           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6477           ind=3
6478           do kk=1,3
6479             ind=ind+1
6480             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6481           enddo
6482           do kk=1,2
6483             do ll=1,2
6484               ind=ind+1
6485               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6486             enddo
6487           enddo
6488           do jj=1,5
6489             do kk=1,3
6490               do ll=1,2
6491                 do mm=1,2
6492                   ind=ind+1
6493                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6494                 enddo
6495               enddo
6496             enddo
6497           enddo
6498         enddo
6499       enddo
6500       call flush(iout)
6501       if (lprn) then
6502         write (iout,'(a)') 'Contact function values after receive:'
6503         do i=nnt,nct-2
6504           write (iout,'(2i3,50(1x,i3,5f6.3))')
6505      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6506      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6507         enddo
6508         call flush(iout)
6509       endif
6510    30 continue
6511 #endif
6512       if (lprn) then
6513         write (iout,'(a)') 'Contact function values:'
6514         do i=nnt,nct-2
6515           write (iout,'(2i3,50(1x,i2,5f6.3))')
6516      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6517      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6518         enddo
6519       endif
6520       ecorr=0.0D0
6521       ecorr5=0.0d0
6522       ecorr6=0.0d0
6523 C Remove the loop below after debugging !!!
6524       do i=nnt,nct
6525         do j=1,3
6526           gradcorr(j,i)=0.0D0
6527           gradxorr(j,i)=0.0D0
6528         enddo
6529       enddo
6530 C Calculate the dipole-dipole interaction energies
6531       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6532       do i=iatel_s,iatel_e+1
6533         num_conti=num_cont_hb(i)
6534         do jj=1,num_conti
6535           j=jcont_hb(jj,i)
6536 #ifdef MOMENT
6537           call dipole(i,j,jj)
6538 #endif
6539         enddo
6540       enddo
6541       endif
6542 C Calculate the local-electrostatic correlation terms
6543 c                write (iout,*) "gradcorr5 in eello5 before loop"
6544 c                do iii=1,nres
6545 c                  write (iout,'(i5,3f10.5)')
6546 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6547 c                enddo
6548       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6549 c        write (iout,*) "corr loop i",i
6550         i1=i+1
6551         num_conti=num_cont_hb(i)
6552         num_conti1=num_cont_hb(i+1)
6553         do jj=1,num_conti
6554           j=jcont_hb(jj,i)
6555           jp=iabs(j)
6556           do kk=1,num_conti1
6557             j1=jcont_hb(kk,i1)
6558             jp1=iabs(j1)
6559 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6560 c     &         ' jj=',jj,' kk=',kk
6561 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6562             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6563      &          .or. j.lt.0 .and. j1.gt.0) .and.
6564      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6565 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6566 C The system gains extra energy.
6567               n_corr=n_corr+1
6568               sqd1=dsqrt(d_cont(jj,i))
6569               sqd2=dsqrt(d_cont(kk,i1))
6570               sred_geom = sqd1*sqd2
6571               IF (sred_geom.lt.cutoff_corr) THEN
6572                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6573      &            ekont,fprimcont)
6574 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6575 cd     &         ' jj=',jj,' kk=',kk
6576                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6577                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6578                 do l=1,3
6579                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6580                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6581                 enddo
6582                 n_corr1=n_corr1+1
6583 cd               write (iout,*) 'sred_geom=',sred_geom,
6584 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6585 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6586 cd               write (iout,*) "g_contij",g_contij
6587 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6588 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6589                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6590                 if (wcorr4.gt.0.0d0)
6591      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6592                   if (energy_dec.and.wcorr4.gt.0.0d0)
6593      1                 write (iout,'(a6,4i5,0pf7.3)')
6594      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6595 c                write (iout,*) "gradcorr5 before eello5"
6596 c                do iii=1,nres
6597 c                  write (iout,'(i5,3f10.5)')
6598 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6599 c                enddo
6600                 if (wcorr5.gt.0.0d0)
6601      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6602 c                write (iout,*) "gradcorr5 after eello5"
6603 c                do iii=1,nres
6604 c                  write (iout,'(i5,3f10.5)')
6605 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6606 c                enddo
6607                   if (energy_dec.and.wcorr5.gt.0.0d0)
6608      1                 write (iout,'(a6,4i5,0pf7.3)')
6609      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6610 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6611 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6612                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6613      &               .or. wturn6.eq.0.0d0))then
6614 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6615                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6616                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6617      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6618 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6619 cd     &            'ecorr6=',ecorr6
6620 cd                write (iout,'(4e15.5)') sred_geom,
6621 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6622 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6623 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6624                 else if (wturn6.gt.0.0d0
6625      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6626 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6627                   eturn6=eturn6+eello_turn6(i,jj,kk)
6628                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6629      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6630 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6631                 endif
6632               ENDIF
6633 1111          continue
6634             endif
6635           enddo ! kk
6636         enddo ! jj
6637       enddo ! i
6638       do i=1,nres
6639         num_cont_hb(i)=num_cont_hb_old(i)
6640       enddo
6641 c                write (iout,*) "gradcorr5 in eello5"
6642 c                do iii=1,nres
6643 c                  write (iout,'(i5,3f10.5)')
6644 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6645 c                enddo
6646       return
6647       end
6648 c------------------------------------------------------------------------------
6649       subroutine add_hb_contact_eello(ii,jj,itask)
6650       implicit real*8 (a-h,o-z)
6651       include "DIMENSIONS"
6652       include "COMMON.IOUNITS"
6653       integer max_cont
6654       integer max_dim
6655       parameter (max_cont=maxconts)
6656       parameter (max_dim=70)
6657       include "COMMON.CONTACTS"
6658       double precision zapas(max_dim,maxconts,max_fg_procs),
6659      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6660       common /przechowalnia/ zapas
6661       integer i,j,ii,jj,iproc,itask(4),nn
6662 c      write (iout,*) "itask",itask
6663       do i=1,2
6664         iproc=itask(i)
6665         if (iproc.gt.0) then
6666           do j=1,num_cont_hb(ii)
6667             jjc=jcont_hb(j,ii)
6668 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6669             if (jjc.eq.jj) then
6670               ncont_sent(iproc)=ncont_sent(iproc)+1
6671               nn=ncont_sent(iproc)
6672               zapas(1,nn,iproc)=ii
6673               zapas(2,nn,iproc)=jjc
6674               zapas(3,nn,iproc)=d_cont(j,ii)
6675               ind=3
6676               do kk=1,3
6677                 ind=ind+1
6678                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6679               enddo
6680               do kk=1,2
6681                 do ll=1,2
6682                   ind=ind+1
6683                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6684                 enddo
6685               enddo
6686               do jj=1,5
6687                 do kk=1,3
6688                   do ll=1,2
6689                     do mm=1,2
6690                       ind=ind+1
6691                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6692                     enddo
6693                   enddo
6694                 enddo
6695               enddo
6696               exit
6697             endif
6698           enddo
6699         endif
6700       enddo
6701       return
6702       end
6703 c------------------------------------------------------------------------------
6704       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6705       implicit real*8 (a-h,o-z)
6706       include 'DIMENSIONS'
6707       include 'COMMON.IOUNITS'
6708       include 'COMMON.DERIV'
6709       include 'COMMON.INTERACT'
6710       include 'COMMON.CONTACTS'
6711       double precision gx(3),gx1(3)
6712       logical lprn
6713       lprn=.false.
6714       eij=facont_hb(jj,i)
6715       ekl=facont_hb(kk,k)
6716       ees0pij=ees0p(jj,i)
6717       ees0pkl=ees0p(kk,k)
6718       ees0mij=ees0m(jj,i)
6719       ees0mkl=ees0m(kk,k)
6720       ekont=eij*ekl
6721       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6722 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6723 C Following 4 lines for diagnostics.
6724 cd    ees0pkl=0.0D0
6725 cd    ees0pij=1.0D0
6726 cd    ees0mkl=0.0D0
6727 cd    ees0mij=1.0D0
6728 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6729 c     & 'Contacts ',i,j,
6730 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6731 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6732 c     & 'gradcorr_long'
6733 C Calculate the multi-body contribution to energy.
6734 c      ecorr=ecorr+ekont*ees
6735 C Calculate multi-body contributions to the gradient.
6736       coeffpees0pij=coeffp*ees0pij
6737       coeffmees0mij=coeffm*ees0mij
6738       coeffpees0pkl=coeffp*ees0pkl
6739       coeffmees0mkl=coeffm*ees0mkl
6740       do ll=1,3
6741 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6742         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6743      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6744      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6745         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6746      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6747      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6748 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6749         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6750      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6751      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6752         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6753      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6754      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6755         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6756      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6757      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6758         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6759         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6760         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6761      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6762      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6763         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6764         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6765 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6766       enddo
6767 c      write (iout,*)
6768 cgrad      do m=i+1,j-1
6769 cgrad        do ll=1,3
6770 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6771 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6772 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6773 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6774 cgrad        enddo
6775 cgrad      enddo
6776 cgrad      do m=k+1,l-1
6777 cgrad        do ll=1,3
6778 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6779 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6780 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6781 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6782 cgrad        enddo
6783 cgrad      enddo
6784 c      write (iout,*) "ehbcorr",ekont*ees
6785       ehbcorr=ekont*ees
6786       return
6787       end
6788 #ifdef MOMENT
6789 C---------------------------------------------------------------------------
6790       subroutine dipole(i,j,jj)
6791       implicit real*8 (a-h,o-z)
6792       include 'DIMENSIONS'
6793       include 'COMMON.IOUNITS'
6794       include 'COMMON.CHAIN'
6795       include 'COMMON.FFIELD'
6796       include 'COMMON.DERIV'
6797       include 'COMMON.INTERACT'
6798       include 'COMMON.CONTACTS'
6799       include 'COMMON.TORSION'
6800       include 'COMMON.VAR'
6801       include 'COMMON.GEO'
6802       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6803      &  auxmat(2,2)
6804       iti1 = itortyp(itype(i+1))
6805       if (j.lt.nres-1) then
6806         itj1 = itortyp(itype(j+1))
6807       else
6808         itj1=ntortyp+1
6809       endif
6810       do iii=1,2
6811         dipi(iii,1)=Ub2(iii,i)
6812         dipderi(iii)=Ub2der(iii,i)
6813         dipi(iii,2)=b1(iii,iti1)
6814         dipj(iii,1)=Ub2(iii,j)
6815         dipderj(iii)=Ub2der(iii,j)
6816         dipj(iii,2)=b1(iii,itj1)
6817       enddo
6818       kkk=0
6819       do iii=1,2
6820         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6821         do jjj=1,2
6822           kkk=kkk+1
6823           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6824         enddo
6825       enddo
6826       do kkk=1,5
6827         do lll=1,3
6828           mmm=0
6829           do iii=1,2
6830             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6831      &        auxvec(1))
6832             do jjj=1,2
6833               mmm=mmm+1
6834               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6835             enddo
6836           enddo
6837         enddo
6838       enddo
6839       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6840       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6841       do iii=1,2
6842         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6843       enddo
6844       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6845       do iii=1,2
6846         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6847       enddo
6848       return
6849       end
6850 #endif
6851 C---------------------------------------------------------------------------
6852       subroutine calc_eello(i,j,k,l,jj,kk)
6853 C
6854 C This subroutine computes matrices and vectors needed to calculate
6855 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6856 C
6857       implicit real*8 (a-h,o-z)
6858       include 'DIMENSIONS'
6859       include 'COMMON.IOUNITS'
6860       include 'COMMON.CHAIN'
6861       include 'COMMON.DERIV'
6862       include 'COMMON.INTERACT'
6863       include 'COMMON.CONTACTS'
6864       include 'COMMON.TORSION'
6865       include 'COMMON.VAR'
6866       include 'COMMON.GEO'
6867       include 'COMMON.FFIELD'
6868       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6869      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6870       logical lprn
6871       common /kutas/ lprn
6872 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6873 cd     & ' jj=',jj,' kk=',kk
6874 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6875 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6876 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6877       do iii=1,2
6878         do jjj=1,2
6879           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6880           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6881         enddo
6882       enddo
6883       call transpose2(aa1(1,1),aa1t(1,1))
6884       call transpose2(aa2(1,1),aa2t(1,1))
6885       do kkk=1,5
6886         do lll=1,3
6887           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6888      &      aa1tder(1,1,lll,kkk))
6889           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6890      &      aa2tder(1,1,lll,kkk))
6891         enddo
6892       enddo
6893       if (l.eq.j+1) then
6894 C parallel orientation of the two CA-CA-CA frames.
6895         if (i.gt.1) then
6896           iti=itortyp(itype(i))
6897         else
6898           iti=ntortyp+1
6899         endif
6900         itk1=itortyp(itype(k+1))
6901         itj=itortyp(itype(j))
6902         if (l.lt.nres-1) then
6903           itl1=itortyp(itype(l+1))
6904         else
6905           itl1=ntortyp+1
6906         endif
6907 C A1 kernel(j+1) A2T
6908 cd        do iii=1,2
6909 cd          write (iout,'(3f10.5,5x,3f10.5)')
6910 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6911 cd        enddo
6912         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6913      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6914      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6915 C Following matrices are needed only for 6-th order cumulants
6916         IF (wcorr6.gt.0.0d0) THEN
6917         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6918      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6919      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6920         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6921      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6922      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6923      &   ADtEAderx(1,1,1,1,1,1))
6924         lprn=.false.
6925         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6926      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6927      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6928      &   ADtEA1derx(1,1,1,1,1,1))
6929         ENDIF
6930 C End 6-th order cumulants
6931 cd        lprn=.false.
6932 cd        if (lprn) then
6933 cd        write (2,*) 'In calc_eello6'
6934 cd        do iii=1,2
6935 cd          write (2,*) 'iii=',iii
6936 cd          do kkk=1,5
6937 cd            write (2,*) 'kkk=',kkk
6938 cd            do jjj=1,2
6939 cd              write (2,'(3(2f10.5),5x)')
6940 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6941 cd            enddo
6942 cd          enddo
6943 cd        enddo
6944 cd        endif
6945         call transpose2(EUgder(1,1,k),auxmat(1,1))
6946         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6947         call transpose2(EUg(1,1,k),auxmat(1,1))
6948         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6949         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6950         do iii=1,2
6951           do kkk=1,5
6952             do lll=1,3
6953               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6954      &          EAEAderx(1,1,lll,kkk,iii,1))
6955             enddo
6956           enddo
6957         enddo
6958 C A1T kernel(i+1) A2
6959         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6960      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6961      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6962 C Following matrices are needed only for 6-th order cumulants
6963         IF (wcorr6.gt.0.0d0) THEN
6964         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6965      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6966      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6967         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6968      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6969      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6970      &   ADtEAderx(1,1,1,1,1,2))
6971         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6972      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6973      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6974      &   ADtEA1derx(1,1,1,1,1,2))
6975         ENDIF
6976 C End 6-th order cumulants
6977         call transpose2(EUgder(1,1,l),auxmat(1,1))
6978         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6979         call transpose2(EUg(1,1,l),auxmat(1,1))
6980         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6981         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6982         do iii=1,2
6983           do kkk=1,5
6984             do lll=1,3
6985               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6986      &          EAEAderx(1,1,lll,kkk,iii,2))
6987             enddo
6988           enddo
6989         enddo
6990 C AEAb1 and AEAb2
6991 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6992 C They are needed only when the fifth- or the sixth-order cumulants are
6993 C indluded.
6994         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6995         call transpose2(AEA(1,1,1),auxmat(1,1))
6996         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6997         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6998         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6999         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7000         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7001         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7002         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7003         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7004         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7005         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7006         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7007         call transpose2(AEA(1,1,2),auxmat(1,1))
7008         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7009         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7010         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7011         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7012         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7013         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7014         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7015         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7016         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7017         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7018         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7019 C Calculate the Cartesian derivatives of the vectors.
7020         do iii=1,2
7021           do kkk=1,5
7022             do lll=1,3
7023               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7024               call matvec2(auxmat(1,1),b1(1,iti),
7025      &          AEAb1derx(1,lll,kkk,iii,1,1))
7026               call matvec2(auxmat(1,1),Ub2(1,i),
7027      &          AEAb2derx(1,lll,kkk,iii,1,1))
7028               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7029      &          AEAb1derx(1,lll,kkk,iii,2,1))
7030               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7031      &          AEAb2derx(1,lll,kkk,iii,2,1))
7032               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7033               call matvec2(auxmat(1,1),b1(1,itj),
7034      &          AEAb1derx(1,lll,kkk,iii,1,2))
7035               call matvec2(auxmat(1,1),Ub2(1,j),
7036      &          AEAb2derx(1,lll,kkk,iii,1,2))
7037               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7038      &          AEAb1derx(1,lll,kkk,iii,2,2))
7039               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7040      &          AEAb2derx(1,lll,kkk,iii,2,2))
7041             enddo
7042           enddo
7043         enddo
7044         ENDIF
7045 C End vectors
7046       else
7047 C Antiparallel orientation of the two CA-CA-CA frames.
7048         if (i.gt.1) then
7049           iti=itortyp(itype(i))
7050         else
7051           iti=ntortyp+1
7052         endif
7053         itk1=itortyp(itype(k+1))
7054         itl=itortyp(itype(l))
7055         itj=itortyp(itype(j))
7056         if (j.lt.nres-1) then
7057           itj1=itortyp(itype(j+1))
7058         else
7059           itj1=ntortyp+1
7060         endif
7061 C A2 kernel(j-1)T A1T
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.,EUg(1,1,j),EUgder(1,1,j),
7064      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7065 C Following matrices are needed only for 6-th order cumulants
7066         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7067      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7069      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7070      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7071         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7072      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7073      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7074      &   ADtEAderx(1,1,1,1,1,1))
7075         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7076      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7077      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7078      &   ADtEA1derx(1,1,1,1,1,1))
7079         ENDIF
7080 C End 6-th order cumulants
7081         call transpose2(EUgder(1,1,k),auxmat(1,1))
7082         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7083         call transpose2(EUg(1,1,k),auxmat(1,1))
7084         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7085         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7086         do iii=1,2
7087           do kkk=1,5
7088             do lll=1,3
7089               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7090      &          EAEAderx(1,1,lll,kkk,iii,1))
7091             enddo
7092           enddo
7093         enddo
7094 C A2T kernel(i+1)T A1
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.,EUg(1,1,k),EUgder(1,1,k),
7097      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7098 C Following matrices are needed only for 6-th order cumulants
7099         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7100      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7101         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7102      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7103      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7104         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7105      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7106      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7107      &   ADtEAderx(1,1,1,1,1,2))
7108         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7109      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7110      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7111      &   ADtEA1derx(1,1,1,1,1,2))
7112         ENDIF
7113 C End 6-th order cumulants
7114         call transpose2(EUgder(1,1,j),auxmat(1,1))
7115         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7116         call transpose2(EUg(1,1,j),auxmat(1,1))
7117         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7118         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7119         do iii=1,2
7120           do kkk=1,5
7121             do lll=1,3
7122               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7123      &          EAEAderx(1,1,lll,kkk,iii,2))
7124             enddo
7125           enddo
7126         enddo
7127 C AEAb1 and AEAb2
7128 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7129 C They are needed only when the fifth- or the sixth-order cumulants are
7130 C indluded.
7131         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7132      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7133         call transpose2(AEA(1,1,1),auxmat(1,1))
7134         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7135         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7136         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7137         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7138         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7139         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7140         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7141         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7142         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7143         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7144         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7145         call transpose2(AEA(1,1,2),auxmat(1,1))
7146         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7147         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7148         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7149         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7150         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7151         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7152         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7153         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7154         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7155         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7156         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7157 C Calculate the Cartesian derivatives of the vectors.
7158         do iii=1,2
7159           do kkk=1,5
7160             do lll=1,3
7161               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7162               call matvec2(auxmat(1,1),b1(1,iti),
7163      &          AEAb1derx(1,lll,kkk,iii,1,1))
7164               call matvec2(auxmat(1,1),Ub2(1,i),
7165      &          AEAb2derx(1,lll,kkk,iii,1,1))
7166               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7167      &          AEAb1derx(1,lll,kkk,iii,2,1))
7168               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7169      &          AEAb2derx(1,lll,kkk,iii,2,1))
7170               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7171               call matvec2(auxmat(1,1),b1(1,itl),
7172      &          AEAb1derx(1,lll,kkk,iii,1,2))
7173               call matvec2(auxmat(1,1),Ub2(1,l),
7174      &          AEAb2derx(1,lll,kkk,iii,1,2))
7175               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7176      &          AEAb1derx(1,lll,kkk,iii,2,2))
7177               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7178      &          AEAb2derx(1,lll,kkk,iii,2,2))
7179             enddo
7180           enddo
7181         enddo
7182         ENDIF
7183 C End vectors
7184       endif
7185       return
7186       end
7187 C---------------------------------------------------------------------------
7188       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7189      &  KK,KKderg,AKA,AKAderg,AKAderx)
7190       implicit none
7191       integer nderg
7192       logical transp
7193       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7194      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7195      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7196       integer iii,kkk,lll
7197       integer jjj,mmm
7198       logical lprn
7199       common /kutas/ lprn
7200       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7201       do iii=1,nderg
7202         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7203      &    AKAderg(1,1,iii))
7204       enddo
7205 cd      if (lprn) write (2,*) 'In kernel'
7206       do kkk=1,5
7207 cd        if (lprn) write (2,*) 'kkk=',kkk
7208         do lll=1,3
7209           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7210      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7211 cd          if (lprn) then
7212 cd            write (2,*) 'lll=',lll
7213 cd            write (2,*) 'iii=1'
7214 cd            do jjj=1,2
7215 cd              write (2,'(3(2f10.5),5x)')
7216 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7217 cd            enddo
7218 cd          endif
7219           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7220      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7221 cd          if (lprn) then
7222 cd            write (2,*) 'lll=',lll
7223 cd            write (2,*) 'iii=2'
7224 cd            do jjj=1,2
7225 cd              write (2,'(3(2f10.5),5x)')
7226 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7227 cd            enddo
7228 cd          endif
7229         enddo
7230       enddo
7231       return
7232       end
7233 C---------------------------------------------------------------------------
7234       double precision function eello4(i,j,k,l,jj,kk)
7235       implicit real*8 (a-h,o-z)
7236       include 'DIMENSIONS'
7237       include 'COMMON.IOUNITS'
7238       include 'COMMON.CHAIN'
7239       include 'COMMON.DERIV'
7240       include 'COMMON.INTERACT'
7241       include 'COMMON.CONTACTS'
7242       include 'COMMON.TORSION'
7243       include 'COMMON.VAR'
7244       include 'COMMON.GEO'
7245       double precision pizda(2,2),ggg1(3),ggg2(3)
7246 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7247 cd        eello4=0.0d0
7248 cd        return
7249 cd      endif
7250 cd      print *,'eello4:',i,j,k,l,jj,kk
7251 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7252 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7253 cold      eij=facont_hb(jj,i)
7254 cold      ekl=facont_hb(kk,k)
7255 cold      ekont=eij*ekl
7256       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7257 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7258       gcorr_loc(k-1)=gcorr_loc(k-1)
7259      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7260       if (l.eq.j+1) then
7261         gcorr_loc(l-1)=gcorr_loc(l-1)
7262      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7263       else
7264         gcorr_loc(j-1)=gcorr_loc(j-1)
7265      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7266       endif
7267       do iii=1,2
7268         do kkk=1,5
7269           do lll=1,3
7270             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7271      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7272 cd            derx(lll,kkk,iii)=0.0d0
7273           enddo
7274         enddo
7275       enddo
7276 cd      gcorr_loc(l-1)=0.0d0
7277 cd      gcorr_loc(j-1)=0.0d0
7278 cd      gcorr_loc(k-1)=0.0d0
7279 cd      eel4=1.0d0
7280 cd      write (iout,*)'Contacts have occurred for peptide groups',
7281 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7282 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7283       if (j.lt.nres-1) then
7284         j1=j+1
7285         j2=j-1
7286       else
7287         j1=j-1
7288         j2=j-2
7289       endif
7290       if (l.lt.nres-1) then
7291         l1=l+1
7292         l2=l-1
7293       else
7294         l1=l-1
7295         l2=l-2
7296       endif
7297       do ll=1,3
7298 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7299 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7300         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7301         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7302 cgrad        ghalf=0.5d0*ggg1(ll)
7303         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7304         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7305         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7306         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7307         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7308         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7309 cgrad        ghalf=0.5d0*ggg2(ll)
7310         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7311         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7312         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7313         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7314         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7315         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7316       enddo
7317 cgrad      do m=i+1,j-1
7318 cgrad        do ll=1,3
7319 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7320 cgrad        enddo
7321 cgrad      enddo
7322 cgrad      do m=k+1,l-1
7323 cgrad        do ll=1,3
7324 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7325 cgrad        enddo
7326 cgrad      enddo
7327 cgrad      do m=i+2,j2
7328 cgrad        do ll=1,3
7329 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7330 cgrad        enddo
7331 cgrad      enddo
7332 cgrad      do m=k+2,l2
7333 cgrad        do ll=1,3
7334 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7335 cgrad        enddo
7336 cgrad      enddo
7337 cd      do iii=1,nres-3
7338 cd        write (2,*) iii,gcorr_loc(iii)
7339 cd      enddo
7340       eello4=ekont*eel4
7341 cd      write (2,*) 'ekont',ekont
7342 cd      write (iout,*) 'eello4',ekont*eel4
7343       return
7344       end
7345 C---------------------------------------------------------------------------
7346       double precision function eello5(i,j,k,l,jj,kk)
7347       implicit real*8 (a-h,o-z)
7348       include 'DIMENSIONS'
7349       include 'COMMON.IOUNITS'
7350       include 'COMMON.CHAIN'
7351       include 'COMMON.DERIV'
7352       include 'COMMON.INTERACT'
7353       include 'COMMON.CONTACTS'
7354       include 'COMMON.TORSION'
7355       include 'COMMON.VAR'
7356       include 'COMMON.GEO'
7357       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7358       double precision ggg1(3),ggg2(3)
7359 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7360 C                                                                              C
7361 C                            Parallel chains                                   C
7362 C                                                                              C
7363 C          o             o                   o             o                   C
7364 C         /l\           / \             \   / \           / \   /              C
7365 C        /   \         /   \             \ /   \         /   \ /               C
7366 C       j| o |l1       | o |              o| o |         | o |o                C
7367 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7368 C      \i/   \         /   \ /             /   \         /   \                 C
7369 C       o    k1             o                                                  C
7370 C         (I)          (II)                (III)          (IV)                 C
7371 C                                                                              C
7372 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7373 C                                                                              C
7374 C                            Antiparallel chains                               C
7375 C                                                                              C
7376 C          o             o                   o             o                   C
7377 C         /j\           / \             \   / \           / \   /              C
7378 C        /   \         /   \             \ /   \         /   \ /               C
7379 C      j1| o |l        | o |              o| o |         | o |o                C
7380 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7381 C      \i/   \         /   \ /             /   \         /   \                 C
7382 C       o     k1            o                                                  C
7383 C         (I)          (II)                (III)          (IV)                 C
7384 C                                                                              C
7385 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7386 C                                                                              C
7387 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7388 C                                                                              C
7389 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7390 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7391 cd        eello5=0.0d0
7392 cd        return
7393 cd      endif
7394 cd      write (iout,*)
7395 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7396 cd     &   ' and',k,l
7397       itk=itortyp(itype(k))
7398       itl=itortyp(itype(l))
7399       itj=itortyp(itype(j))
7400       eello5_1=0.0d0
7401       eello5_2=0.0d0
7402       eello5_3=0.0d0
7403       eello5_4=0.0d0
7404 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7405 cd     &   eel5_3_num,eel5_4_num)
7406       do iii=1,2
7407         do kkk=1,5
7408           do lll=1,3
7409             derx(lll,kkk,iii)=0.0d0
7410           enddo
7411         enddo
7412       enddo
7413 cd      eij=facont_hb(jj,i)
7414 cd      ekl=facont_hb(kk,k)
7415 cd      ekont=eij*ekl
7416 cd      write (iout,*)'Contacts have occurred for peptide groups',
7417 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7418 cd      goto 1111
7419 C Contribution from the graph I.
7420 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7421 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7422       call transpose2(EUg(1,1,k),auxmat(1,1))
7423       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7424       vv(1)=pizda(1,1)-pizda(2,2)
7425       vv(2)=pizda(1,2)+pizda(2,1)
7426       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7427      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7428 C Explicit gradient in virtual-dihedral angles.
7429       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7430      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7431      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7432       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7433       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7434       vv(1)=pizda(1,1)-pizda(2,2)
7435       vv(2)=pizda(1,2)+pizda(2,1)
7436       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7437      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7438      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7439       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7440       vv(1)=pizda(1,1)-pizda(2,2)
7441       vv(2)=pizda(1,2)+pizda(2,1)
7442       if (l.eq.j+1) then
7443         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7444      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7445      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7446       else
7447         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7448      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7449      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7450       endif
7451 C Cartesian gradient
7452       do iii=1,2
7453         do kkk=1,5
7454           do lll=1,3
7455             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7456      &        pizda(1,1))
7457             vv(1)=pizda(1,1)-pizda(2,2)
7458             vv(2)=pizda(1,2)+pizda(2,1)
7459             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7460      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7461      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7462           enddo
7463         enddo
7464       enddo
7465 c      goto 1112
7466 c1111  continue
7467 C Contribution from graph II
7468       call transpose2(EE(1,1,itk),auxmat(1,1))
7469       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7470       vv(1)=pizda(1,1)+pizda(2,2)
7471       vv(2)=pizda(2,1)-pizda(1,2)
7472       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7473      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7474 C Explicit gradient in virtual-dihedral angles.
7475       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7476      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7477       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7478       vv(1)=pizda(1,1)+pizda(2,2)
7479       vv(2)=pizda(2,1)-pizda(1,2)
7480       if (l.eq.j+1) then
7481         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7482      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7483      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7484       else
7485         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7486      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7487      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7488       endif
7489 C Cartesian gradient
7490       do iii=1,2
7491         do kkk=1,5
7492           do lll=1,3
7493             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7494      &        pizda(1,1))
7495             vv(1)=pizda(1,1)+pizda(2,2)
7496             vv(2)=pizda(2,1)-pizda(1,2)
7497             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7498      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7499      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7500           enddo
7501         enddo
7502       enddo
7503 cd      goto 1112
7504 cd1111  continue
7505       if (l.eq.j+1) then
7506 cd        goto 1110
7507 C Parallel orientation
7508 C Contribution from graph III
7509         call transpose2(EUg(1,1,l),auxmat(1,1))
7510         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7511         vv(1)=pizda(1,1)-pizda(2,2)
7512         vv(2)=pizda(1,2)+pizda(2,1)
7513         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7514      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7515 C Explicit gradient in virtual-dihedral angles.
7516         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7517      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7518      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7519         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7520         vv(1)=pizda(1,1)-pizda(2,2)
7521         vv(2)=pizda(1,2)+pizda(2,1)
7522         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7523      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7524      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7525         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7526         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7527         vv(1)=pizda(1,1)-pizda(2,2)
7528         vv(2)=pizda(1,2)+pizda(2,1)
7529         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7530      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7531      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7532 C Cartesian gradient
7533         do iii=1,2
7534           do kkk=1,5
7535             do lll=1,3
7536               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7537      &          pizda(1,1))
7538               vv(1)=pizda(1,1)-pizda(2,2)
7539               vv(2)=pizda(1,2)+pizda(2,1)
7540               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7541      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7542      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7543             enddo
7544           enddo
7545         enddo
7546 cd        goto 1112
7547 C Contribution from graph IV
7548 cd1110    continue
7549         call transpose2(EE(1,1,itl),auxmat(1,1))
7550         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7551         vv(1)=pizda(1,1)+pizda(2,2)
7552         vv(2)=pizda(2,1)-pizda(1,2)
7553         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7554      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7555 C Explicit gradient in virtual-dihedral angles.
7556         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7557      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7558         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7559         vv(1)=pizda(1,1)+pizda(2,2)
7560         vv(2)=pizda(2,1)-pizda(1,2)
7561         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7562      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7563      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7564 C Cartesian gradient
7565         do iii=1,2
7566           do kkk=1,5
7567             do lll=1,3
7568               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7569      &          pizda(1,1))
7570               vv(1)=pizda(1,1)+pizda(2,2)
7571               vv(2)=pizda(2,1)-pizda(1,2)
7572               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7573      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7574      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7575             enddo
7576           enddo
7577         enddo
7578       else
7579 C Antiparallel orientation
7580 C Contribution from graph III
7581 c        goto 1110
7582         call transpose2(EUg(1,1,j),auxmat(1,1))
7583         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7584         vv(1)=pizda(1,1)-pizda(2,2)
7585         vv(2)=pizda(1,2)+pizda(2,1)
7586         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7587      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7588 C Explicit gradient in virtual-dihedral angles.
7589         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7590      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7591      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7592         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7593         vv(1)=pizda(1,1)-pizda(2,2)
7594         vv(2)=pizda(1,2)+pizda(2,1)
7595         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7596      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7597      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7598         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7599         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7600         vv(1)=pizda(1,1)-pizda(2,2)
7601         vv(2)=pizda(1,2)+pizda(2,1)
7602         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7603      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7604      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7605 C Cartesian gradient
7606         do iii=1,2
7607           do kkk=1,5
7608             do lll=1,3
7609               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7610      &          pizda(1,1))
7611               vv(1)=pizda(1,1)-pizda(2,2)
7612               vv(2)=pizda(1,2)+pizda(2,1)
7613               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7614      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7615      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7616             enddo
7617           enddo
7618         enddo
7619 cd        goto 1112
7620 C Contribution from graph IV
7621 1110    continue
7622         call transpose2(EE(1,1,itj),auxmat(1,1))
7623         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7624         vv(1)=pizda(1,1)+pizda(2,2)
7625         vv(2)=pizda(2,1)-pizda(1,2)
7626         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7627      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7628 C Explicit gradient in virtual-dihedral angles.
7629         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7630      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7631         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7632         vv(1)=pizda(1,1)+pizda(2,2)
7633         vv(2)=pizda(2,1)-pizda(1,2)
7634         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7635      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7636      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7637 C Cartesian gradient
7638         do iii=1,2
7639           do kkk=1,5
7640             do lll=1,3
7641               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7642      &          pizda(1,1))
7643               vv(1)=pizda(1,1)+pizda(2,2)
7644               vv(2)=pizda(2,1)-pizda(1,2)
7645               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7646      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7647      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7648             enddo
7649           enddo
7650         enddo
7651       endif
7652 1112  continue
7653       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7654 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7655 cd        write (2,*) 'ijkl',i,j,k,l
7656 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7657 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7658 cd      endif
7659 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7660 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7661 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7662 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7663       if (j.lt.nres-1) then
7664         j1=j+1
7665         j2=j-1
7666       else
7667         j1=j-1
7668         j2=j-2
7669       endif
7670       if (l.lt.nres-1) then
7671         l1=l+1
7672         l2=l-1
7673       else
7674         l1=l-1
7675         l2=l-2
7676       endif
7677 cd      eij=1.0d0
7678 cd      ekl=1.0d0
7679 cd      ekont=1.0d0
7680 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7681 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7682 C        summed up outside the subrouine as for the other subroutines
7683 C        handling long-range interactions. The old code is commented out
7684 C        with "cgrad" to keep track of changes.
7685       do ll=1,3
7686 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7687 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7688         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7689         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7690 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7691 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7692 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7693 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7694 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7695 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7696 c     &   gradcorr5ij,
7697 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7698 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7699 cgrad        ghalf=0.5d0*ggg1(ll)
7700 cd        ghalf=0.0d0
7701         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7702         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7703         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7704         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7705         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7706         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7707 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7708 cgrad        ghalf=0.5d0*ggg2(ll)
7709 cd        ghalf=0.0d0
7710         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7711         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7712         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7713         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7714         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7715         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7716       enddo
7717 cd      goto 1112
7718 cgrad      do m=i+1,j-1
7719 cgrad        do ll=1,3
7720 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7721 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7722 cgrad        enddo
7723 cgrad      enddo
7724 cgrad      do m=k+1,l-1
7725 cgrad        do ll=1,3
7726 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7727 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7728 cgrad        enddo
7729 cgrad      enddo
7730 c1112  continue
7731 cgrad      do m=i+2,j2
7732 cgrad        do ll=1,3
7733 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7734 cgrad        enddo
7735 cgrad      enddo
7736 cgrad      do m=k+2,l2
7737 cgrad        do ll=1,3
7738 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7739 cgrad        enddo
7740 cgrad      enddo
7741 cd      do iii=1,nres-3
7742 cd        write (2,*) iii,g_corr5_loc(iii)
7743 cd      enddo
7744       eello5=ekont*eel5
7745 cd      write (2,*) 'ekont',ekont
7746 cd      write (iout,*) 'eello5',ekont*eel5
7747       return
7748       end
7749 c--------------------------------------------------------------------------
7750       double precision function eello6(i,j,k,l,jj,kk)
7751       implicit real*8 (a-h,o-z)
7752       include 'DIMENSIONS'
7753       include 'COMMON.IOUNITS'
7754       include 'COMMON.CHAIN'
7755       include 'COMMON.DERIV'
7756       include 'COMMON.INTERACT'
7757       include 'COMMON.CONTACTS'
7758       include 'COMMON.TORSION'
7759       include 'COMMON.VAR'
7760       include 'COMMON.GEO'
7761       include 'COMMON.FFIELD'
7762       double precision ggg1(3),ggg2(3)
7763 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7764 cd        eello6=0.0d0
7765 cd        return
7766 cd      endif
7767 cd      write (iout,*)
7768 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7769 cd     &   ' and',k,l
7770       eello6_1=0.0d0
7771       eello6_2=0.0d0
7772       eello6_3=0.0d0
7773       eello6_4=0.0d0
7774       eello6_5=0.0d0
7775       eello6_6=0.0d0
7776 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7777 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7778       do iii=1,2
7779         do kkk=1,5
7780           do lll=1,3
7781             derx(lll,kkk,iii)=0.0d0
7782           enddo
7783         enddo
7784       enddo
7785 cd      eij=facont_hb(jj,i)
7786 cd      ekl=facont_hb(kk,k)
7787 cd      ekont=eij*ekl
7788 cd      eij=1.0d0
7789 cd      ekl=1.0d0
7790 cd      ekont=1.0d0
7791       if (l.eq.j+1) then
7792         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7793         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7794         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7795         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7796         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7797         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7798       else
7799         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7800         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7801         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7802         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7803         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7804           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7805         else
7806           eello6_5=0.0d0
7807         endif
7808         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7809       endif
7810 C If turn contributions are considered, they will be handled separately.
7811       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7812 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7813 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7814 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7815 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7816 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7817 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7818 cd      goto 1112
7819       if (j.lt.nres-1) then
7820         j1=j+1
7821         j2=j-1
7822       else
7823         j1=j-1
7824         j2=j-2
7825       endif
7826       if (l.lt.nres-1) then
7827         l1=l+1
7828         l2=l-1
7829       else
7830         l1=l-1
7831         l2=l-2
7832       endif
7833       do ll=1,3
7834 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7835 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7836 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7837 cgrad        ghalf=0.5d0*ggg1(ll)
7838 cd        ghalf=0.0d0
7839         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7840         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7841         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7842         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7843         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7844         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7845         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7846         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7847 cgrad        ghalf=0.5d0*ggg2(ll)
7848 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7849 cd        ghalf=0.0d0
7850         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7851         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7852         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7853         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7854         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7855         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7856       enddo
7857 cd      goto 1112
7858 cgrad      do m=i+1,j-1
7859 cgrad        do ll=1,3
7860 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7861 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7862 cgrad        enddo
7863 cgrad      enddo
7864 cgrad      do m=k+1,l-1
7865 cgrad        do ll=1,3
7866 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7867 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7868 cgrad        enddo
7869 cgrad      enddo
7870 cgrad1112  continue
7871 cgrad      do m=i+2,j2
7872 cgrad        do ll=1,3
7873 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7874 cgrad        enddo
7875 cgrad      enddo
7876 cgrad      do m=k+2,l2
7877 cgrad        do ll=1,3
7878 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7879 cgrad        enddo
7880 cgrad      enddo
7881 cd      do iii=1,nres-3
7882 cd        write (2,*) iii,g_corr6_loc(iii)
7883 cd      enddo
7884       eello6=ekont*eel6
7885 cd      write (2,*) 'ekont',ekont
7886 cd      write (iout,*) 'eello6',ekont*eel6
7887       return
7888       end
7889 c--------------------------------------------------------------------------
7890       double precision function eello6_graph1(i,j,k,l,imat,swap)
7891       implicit real*8 (a-h,o-z)
7892       include 'DIMENSIONS'
7893       include 'COMMON.IOUNITS'
7894       include 'COMMON.CHAIN'
7895       include 'COMMON.DERIV'
7896       include 'COMMON.INTERACT'
7897       include 'COMMON.CONTACTS'
7898       include 'COMMON.TORSION'
7899       include 'COMMON.VAR'
7900       include 'COMMON.GEO'
7901       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7902       logical swap
7903       logical lprn
7904       common /kutas/ lprn
7905 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7906 C                                                                              C
7907 C      Parallel       Antiparallel                                             C
7908 C                                                                              C
7909 C          o             o                                                     C
7910 C         /l\           /j\                                                    C
7911 C        /   \         /   \                                                   C
7912 C       /| o |         | o |\                                                  C
7913 C     \ j|/k\|  /   \  |/k\|l /                                                C
7914 C      \ /   \ /     \ /   \ /                                                 C
7915 C       o     o       o     o                                                  C
7916 C       i             i                                                        C
7917 C                                                                              C
7918 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7919       itk=itortyp(itype(k))
7920       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7921       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7922       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7923       call transpose2(EUgC(1,1,k),auxmat(1,1))
7924       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7925       vv1(1)=pizda1(1,1)-pizda1(2,2)
7926       vv1(2)=pizda1(1,2)+pizda1(2,1)
7927       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7928       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7929       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7930       s5=scalar2(vv(1),Dtobr2(1,i))
7931 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7932       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7933       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7934      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7935      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7936      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7937      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7938      & +scalar2(vv(1),Dtobr2der(1,i)))
7939       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7940       vv1(1)=pizda1(1,1)-pizda1(2,2)
7941       vv1(2)=pizda1(1,2)+pizda1(2,1)
7942       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7943       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7944       if (l.eq.j+1) then
7945         g_corr6_loc(l-1)=g_corr6_loc(l-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       else
7951         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7952      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7953      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7954      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7955      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7956       endif
7957       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7958       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7959       vv1(1)=pizda1(1,1)-pizda1(2,2)
7960       vv1(2)=pizda1(1,2)+pizda1(2,1)
7961       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7962      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7963      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7964      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7965       do iii=1,2
7966         if (swap) then
7967           ind=3-iii
7968         else
7969           ind=iii
7970         endif
7971         do kkk=1,5
7972           do lll=1,3
7973             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7974             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7975             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7976             call transpose2(EUgC(1,1,k),auxmat(1,1))
7977             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7978      &        pizda1(1,1))
7979             vv1(1)=pizda1(1,1)-pizda1(2,2)
7980             vv1(2)=pizda1(1,2)+pizda1(2,1)
7981             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7982             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7983      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7984             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7985      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7986             s5=scalar2(vv(1),Dtobr2(1,i))
7987             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7988           enddo
7989         enddo
7990       enddo
7991       return
7992       end
7993 c----------------------------------------------------------------------------
7994       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7995       implicit real*8 (a-h,o-z)
7996       include 'DIMENSIONS'
7997       include 'COMMON.IOUNITS'
7998       include 'COMMON.CHAIN'
7999       include 'COMMON.DERIV'
8000       include 'COMMON.INTERACT'
8001       include 'COMMON.CONTACTS'
8002       include 'COMMON.TORSION'
8003       include 'COMMON.VAR'
8004       include 'COMMON.GEO'
8005       logical swap
8006       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8007      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8008       logical lprn
8009       common /kutas/ lprn
8010 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8011 C                                                                              C
8012 C      Parallel       Antiparallel                                             C
8013 C                                                                              C
8014 C          o             o                                                     C
8015 C     \   /l\           /j\   /                                                C
8016 C      \ /   \         /   \ /                                                 C
8017 C       o| o |         | o |o                                                  C
8018 C     \ j|/k\|      \  |/k\|l                                                  C
8019 C      \ /   \       \ /   \                                                   C
8020 C       o             o                                                        C
8021 C       i             i                                                        C
8022 C                                                                              C
8023 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8024 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8025 C AL 7/4/01 s1 would occur in the sixth-order moment,
8026 C           but not in a cluster cumulant
8027 #ifdef MOMENT
8028       s1=dip(1,jj,i)*dip(1,kk,k)
8029 #endif
8030       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8031       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8032       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8033       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8034       call transpose2(EUg(1,1,k),auxmat(1,1))
8035       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8036       vv(1)=pizda(1,1)-pizda(2,2)
8037       vv(2)=pizda(1,2)+pizda(2,1)
8038       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8039 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8040 #ifdef MOMENT
8041       eello6_graph2=-(s1+s2+s3+s4)
8042 #else
8043       eello6_graph2=-(s2+s3+s4)
8044 #endif
8045 c      eello6_graph2=-s3
8046 C Derivatives in gamma(i-1)
8047       if (i.gt.1) then
8048 #ifdef MOMENT
8049         s1=dipderg(1,jj,i)*dip(1,kk,k)
8050 #endif
8051         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8052         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8053         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8054         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8055 #ifdef MOMENT
8056         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8057 #else
8058         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8059 #endif
8060 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8061       endif
8062 C Derivatives in gamma(k-1)
8063 #ifdef MOMENT
8064       s1=dip(1,jj,i)*dipderg(1,kk,k)
8065 #endif
8066       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8067       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8068       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8069       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8070       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8071       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8072       vv(1)=pizda(1,1)-pizda(2,2)
8073       vv(2)=pizda(1,2)+pizda(2,1)
8074       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8075 #ifdef MOMENT
8076       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8077 #else
8078       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8079 #endif
8080 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8081 C Derivatives in gamma(j-1) or gamma(l-1)
8082       if (j.gt.1) then
8083 #ifdef MOMENT
8084         s1=dipderg(3,jj,i)*dip(1,kk,k)
8085 #endif
8086         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8087         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8088         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8089         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8090         vv(1)=pizda(1,1)-pizda(2,2)
8091         vv(2)=pizda(1,2)+pizda(2,1)
8092         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8093 #ifdef MOMENT
8094         if (swap) then
8095           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8096         else
8097           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8098         endif
8099 #endif
8100         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8101 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8102       endif
8103 C Derivatives in gamma(l-1) or gamma(j-1)
8104       if (l.gt.1) then
8105 #ifdef MOMENT
8106         s1=dip(1,jj,i)*dipderg(3,kk,k)
8107 #endif
8108         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8109         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8110         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8111         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8112         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8113         vv(1)=pizda(1,1)-pizda(2,2)
8114         vv(2)=pizda(1,2)+pizda(2,1)
8115         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8116 #ifdef MOMENT
8117         if (swap) then
8118           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8119         else
8120           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8121         endif
8122 #endif
8123         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8124 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8125       endif
8126 C Cartesian derivatives.
8127       if (lprn) then
8128         write (2,*) 'In eello6_graph2'
8129         do iii=1,2
8130           write (2,*) 'iii=',iii
8131           do kkk=1,5
8132             write (2,*) 'kkk=',kkk
8133             do jjj=1,2
8134               write (2,'(3(2f10.5),5x)')
8135      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8136             enddo
8137           enddo
8138         enddo
8139       endif
8140       do iii=1,2
8141         do kkk=1,5
8142           do lll=1,3
8143 #ifdef MOMENT
8144             if (iii.eq.1) then
8145               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8146             else
8147               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8148             endif
8149 #endif
8150             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8151      &        auxvec(1))
8152             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8153             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8154      &        auxvec(1))
8155             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8156             call transpose2(EUg(1,1,k),auxmat(1,1))
8157             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8158      &        pizda(1,1))
8159             vv(1)=pizda(1,1)-pizda(2,2)
8160             vv(2)=pizda(1,2)+pizda(2,1)
8161             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8162 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8163 #ifdef MOMENT
8164             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8165 #else
8166             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8167 #endif
8168             if (swap) then
8169               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8170             else
8171               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8172             endif
8173           enddo
8174         enddo
8175       enddo
8176       return
8177       end
8178 c----------------------------------------------------------------------------
8179       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8180       implicit real*8 (a-h,o-z)
8181       include 'DIMENSIONS'
8182       include 'COMMON.IOUNITS'
8183       include 'COMMON.CHAIN'
8184       include 'COMMON.DERIV'
8185       include 'COMMON.INTERACT'
8186       include 'COMMON.CONTACTS'
8187       include 'COMMON.TORSION'
8188       include 'COMMON.VAR'
8189       include 'COMMON.GEO'
8190       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8191       logical swap
8192 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8193 C                                                                              C
8194 C      Parallel       Antiparallel                                             C
8195 C                                                                              C
8196 C          o             o                                                     C
8197 C         /l\   /   \   /j\                                                    C
8198 C        /   \ /     \ /   \                                                   C
8199 C       /| o |o       o| o |\                                                  C
8200 C       j|/k\|  /      |/k\|l /                                                C
8201 C        /   \ /       /   \ /                                                 C
8202 C       /     o       /     o                                                  C
8203 C       i             i                                                        C
8204 C                                                                              C
8205 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8206 C
8207 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8208 C           energy moment and not to the cluster cumulant.
8209       iti=itortyp(itype(i))
8210       if (j.lt.nres-1) then
8211         itj1=itortyp(itype(j+1))
8212       else
8213         itj1=ntortyp+1
8214       endif
8215       itk=itortyp(itype(k))
8216       itk1=itortyp(itype(k+1))
8217       if (l.lt.nres-1) then
8218         itl1=itortyp(itype(l+1))
8219       else
8220         itl1=ntortyp+1
8221       endif
8222 #ifdef MOMENT
8223       s1=dip(4,jj,i)*dip(4,kk,k)
8224 #endif
8225       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8226       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8227       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8228       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8229       call transpose2(EE(1,1,itk),auxmat(1,1))
8230       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8231       vv(1)=pizda(1,1)+pizda(2,2)
8232       vv(2)=pizda(2,1)-pizda(1,2)
8233       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8234 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8235 cd     & "sum",-(s2+s3+s4)
8236 #ifdef MOMENT
8237       eello6_graph3=-(s1+s2+s3+s4)
8238 #else
8239       eello6_graph3=-(s2+s3+s4)
8240 #endif
8241 c      eello6_graph3=-s4
8242 C Derivatives in gamma(k-1)
8243       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8244       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8245       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8246       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8247 C Derivatives in gamma(l-1)
8248       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8249       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8250       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8251       vv(1)=pizda(1,1)+pizda(2,2)
8252       vv(2)=pizda(2,1)-pizda(1,2)
8253       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8254       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8255 C Cartesian derivatives.
8256       do iii=1,2
8257         do kkk=1,5
8258           do lll=1,3
8259 #ifdef MOMENT
8260             if (iii.eq.1) then
8261               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8262             else
8263               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8264             endif
8265 #endif
8266             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8267      &        auxvec(1))
8268             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8269             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8270      &        auxvec(1))
8271             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8272             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8273      &        pizda(1,1))
8274             vv(1)=pizda(1,1)+pizda(2,2)
8275             vv(2)=pizda(2,1)-pizda(1,2)
8276             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8277 #ifdef MOMENT
8278             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8279 #else
8280             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8281 #endif
8282             if (swap) then
8283               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8284             else
8285               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8286             endif
8287 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8288           enddo
8289         enddo
8290       enddo
8291       return
8292       end
8293 c----------------------------------------------------------------------------
8294       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8295       implicit real*8 (a-h,o-z)
8296       include 'DIMENSIONS'
8297       include 'COMMON.IOUNITS'
8298       include 'COMMON.CHAIN'
8299       include 'COMMON.DERIV'
8300       include 'COMMON.INTERACT'
8301       include 'COMMON.CONTACTS'
8302       include 'COMMON.TORSION'
8303       include 'COMMON.VAR'
8304       include 'COMMON.GEO'
8305       include 'COMMON.FFIELD'
8306       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8307      & auxvec1(2),auxmat1(2,2)
8308       logical swap
8309 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8310 C                                                                              C
8311 C      Parallel       Antiparallel                                             C
8312 C                                                                              C
8313 C          o             o                                                     C
8314 C         /l\   /   \   /j\                                                    C
8315 C        /   \ /     \ /   \                                                   C
8316 C       /| o |o       o| o |\                                                  C
8317 C     \ j|/k\|      \  |/k\|l                                                  C
8318 C      \ /   \       \ /   \                                                   C
8319 C       o     \       o     \                                                  C
8320 C       i             i                                                        C
8321 C                                                                              C
8322 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8323 C
8324 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8325 C           energy moment and not to the cluster cumulant.
8326 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8327       iti=itortyp(itype(i))
8328       itj=itortyp(itype(j))
8329       if (j.lt.nres-1) then
8330         itj1=itortyp(itype(j+1))
8331       else
8332         itj1=ntortyp+1
8333       endif
8334       itk=itortyp(itype(k))
8335       if (k.lt.nres-1) then
8336         itk1=itortyp(itype(k+1))
8337       else
8338         itk1=ntortyp+1
8339       endif
8340       itl=itortyp(itype(l))
8341       if (l.lt.nres-1) then
8342         itl1=itortyp(itype(l+1))
8343       else
8344         itl1=ntortyp+1
8345       endif
8346 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8347 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8348 cd     & ' itl',itl,' itl1',itl1
8349 #ifdef MOMENT
8350       if (imat.eq.1) then
8351         s1=dip(3,jj,i)*dip(3,kk,k)
8352       else
8353         s1=dip(2,jj,j)*dip(2,kk,l)
8354       endif
8355 #endif
8356       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8357       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8358       if (j.eq.l+1) then
8359         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8360         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8361       else
8362         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8363         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8364       endif
8365       call transpose2(EUg(1,1,k),auxmat(1,1))
8366       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8367       vv(1)=pizda(1,1)-pizda(2,2)
8368       vv(2)=pizda(2,1)+pizda(1,2)
8369       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8370 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8371 #ifdef MOMENT
8372       eello6_graph4=-(s1+s2+s3+s4)
8373 #else
8374       eello6_graph4=-(s2+s3+s4)
8375 #endif
8376 C Derivatives in gamma(i-1)
8377       if (i.gt.1) then
8378 #ifdef MOMENT
8379         if (imat.eq.1) then
8380           s1=dipderg(2,jj,i)*dip(3,kk,k)
8381         else
8382           s1=dipderg(4,jj,j)*dip(2,kk,l)
8383         endif
8384 #endif
8385         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8386         if (j.eq.l+1) then
8387           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8388           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8389         else
8390           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8391           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8392         endif
8393         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8394         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8395 cd          write (2,*) 'turn6 derivatives'
8396 #ifdef MOMENT
8397           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8398 #else
8399           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8400 #endif
8401         else
8402 #ifdef MOMENT
8403           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8404 #else
8405           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8406 #endif
8407         endif
8408       endif
8409 C Derivatives in gamma(k-1)
8410 #ifdef MOMENT
8411       if (imat.eq.1) then
8412         s1=dip(3,jj,i)*dipderg(2,kk,k)
8413       else
8414         s1=dip(2,jj,j)*dipderg(4,kk,l)
8415       endif
8416 #endif
8417       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8418       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8419       if (j.eq.l+1) then
8420         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8421         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8422       else
8423         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8424         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8425       endif
8426       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8427       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8428       vv(1)=pizda(1,1)-pizda(2,2)
8429       vv(2)=pizda(2,1)+pizda(1,2)
8430       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8431       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8432 #ifdef MOMENT
8433         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8434 #else
8435         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8436 #endif
8437       else
8438 #ifdef MOMENT
8439         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8440 #else
8441         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8442 #endif
8443       endif
8444 C Derivatives in gamma(j-1) or gamma(l-1)
8445       if (l.eq.j+1 .and. l.gt.1) then
8446         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8447         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8448         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8449         vv(1)=pizda(1,1)-pizda(2,2)
8450         vv(2)=pizda(2,1)+pizda(1,2)
8451         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8452         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8453       else if (j.gt.1) then
8454         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8455         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8456         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8457         vv(1)=pizda(1,1)-pizda(2,2)
8458         vv(2)=pizda(2,1)+pizda(1,2)
8459         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8460         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8461           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8462         else
8463           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8464         endif
8465       endif
8466 C Cartesian derivatives.
8467       do iii=1,2
8468         do kkk=1,5
8469           do lll=1,3
8470 #ifdef MOMENT
8471             if (iii.eq.1) then
8472               if (imat.eq.1) then
8473                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8474               else
8475                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8476               endif
8477             else
8478               if (imat.eq.1) then
8479                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8480               else
8481                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8482               endif
8483             endif
8484 #endif
8485             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8486      &        auxvec(1))
8487             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8488             if (j.eq.l+1) then
8489               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8490      &          b1(1,itj1),auxvec(1))
8491               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8492             else
8493               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8494      &          b1(1,itl1),auxvec(1))
8495               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8496             endif
8497             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8498      &        pizda(1,1))
8499             vv(1)=pizda(1,1)-pizda(2,2)
8500             vv(2)=pizda(2,1)+pizda(1,2)
8501             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8502             if (swap) then
8503               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8504 #ifdef MOMENT
8505                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8506      &             -(s1+s2+s4)
8507 #else
8508                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8509      &             -(s2+s4)
8510 #endif
8511                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8512               else
8513 #ifdef MOMENT
8514                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8515 #else
8516                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8517 #endif
8518                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8519               endif
8520             else
8521 #ifdef MOMENT
8522               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8523 #else
8524               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8525 #endif
8526               if (l.eq.j+1) then
8527                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8528               else
8529                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8530               endif
8531             endif
8532           enddo
8533         enddo
8534       enddo
8535       return
8536       end
8537 c----------------------------------------------------------------------------
8538       double precision function eello_turn6(i,jj,kk)
8539       implicit real*8 (a-h,o-z)
8540       include 'DIMENSIONS'
8541       include 'COMMON.IOUNITS'
8542       include 'COMMON.CHAIN'
8543       include 'COMMON.DERIV'
8544       include 'COMMON.INTERACT'
8545       include 'COMMON.CONTACTS'
8546       include 'COMMON.TORSION'
8547       include 'COMMON.VAR'
8548       include 'COMMON.GEO'
8549       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8550      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8551      &  ggg1(3),ggg2(3)
8552       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8553      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8554 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8555 C           the respective energy moment and not to the cluster cumulant.
8556       s1=0.0d0
8557       s8=0.0d0
8558       s13=0.0d0
8559 c
8560       eello_turn6=0.0d0
8561       j=i+4
8562       k=i+1
8563       l=i+3
8564       iti=itortyp(itype(i))
8565       itk=itortyp(itype(k))
8566       itk1=itortyp(itype(k+1))
8567       itl=itortyp(itype(l))
8568       itj=itortyp(itype(j))
8569 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8570 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8571 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8572 cd        eello6=0.0d0
8573 cd        return
8574 cd      endif
8575 cd      write (iout,*)
8576 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8577 cd     &   ' and',k,l
8578 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8579       do iii=1,2
8580         do kkk=1,5
8581           do lll=1,3
8582             derx_turn(lll,kkk,iii)=0.0d0
8583           enddo
8584         enddo
8585       enddo
8586 cd      eij=1.0d0
8587 cd      ekl=1.0d0
8588 cd      ekont=1.0d0
8589       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8590 cd      eello6_5=0.0d0
8591 cd      write (2,*) 'eello6_5',eello6_5
8592 #ifdef MOMENT
8593       call transpose2(AEA(1,1,1),auxmat(1,1))
8594       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8595       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8596       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8597 #endif
8598       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8599       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8600       s2 = scalar2(b1(1,itk),vtemp1(1))
8601 #ifdef MOMENT
8602       call transpose2(AEA(1,1,2),atemp(1,1))
8603       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8604       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8605       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8606 #endif
8607       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8608       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8609       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8610 #ifdef MOMENT
8611       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8612       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8613       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8614       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8615       ss13 = scalar2(b1(1,itk),vtemp4(1))
8616       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8617 #endif
8618 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8619 c      s1=0.0d0
8620 c      s2=0.0d0
8621 c      s8=0.0d0
8622 c      s12=0.0d0
8623 c      s13=0.0d0
8624       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8625 C Derivatives in gamma(i+2)
8626       s1d =0.0d0
8627       s8d =0.0d0
8628 #ifdef MOMENT
8629       call transpose2(AEA(1,1,1),auxmatd(1,1))
8630       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8631       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8632       call transpose2(AEAderg(1,1,2),atempd(1,1))
8633       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8634       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8635 #endif
8636       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8637       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8638       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8639 c      s1d=0.0d0
8640 c      s2d=0.0d0
8641 c      s8d=0.0d0
8642 c      s12d=0.0d0
8643 c      s13d=0.0d0
8644       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8645 C Derivatives in gamma(i+3)
8646 #ifdef MOMENT
8647       call transpose2(AEA(1,1,1),auxmatd(1,1))
8648       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8649       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8650       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8651 #endif
8652       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8653       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8654       s2d = scalar2(b1(1,itk),vtemp1d(1))
8655 #ifdef MOMENT
8656       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8657       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8658 #endif
8659       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8660 #ifdef MOMENT
8661       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8662       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8663       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8664 #endif
8665 c      s1d=0.0d0
8666 c      s2d=0.0d0
8667 c      s8d=0.0d0
8668 c      s12d=0.0d0
8669 c      s13d=0.0d0
8670 #ifdef MOMENT
8671       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8672      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8673 #else
8674       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8675      &               -0.5d0*ekont*(s2d+s12d)
8676 #endif
8677 C Derivatives in gamma(i+4)
8678       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8679       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8680       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8681 #ifdef MOMENT
8682       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8683       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8684       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8685 #endif
8686 c      s1d=0.0d0
8687 c      s2d=0.0d0
8688 c      s8d=0.0d0
8689 C      s12d=0.0d0
8690 c      s13d=0.0d0
8691 #ifdef MOMENT
8692       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8693 #else
8694       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8695 #endif
8696 C Derivatives in gamma(i+5)
8697 #ifdef MOMENT
8698       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8699       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8700       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8701 #endif
8702       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8703       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8704       s2d = scalar2(b1(1,itk),vtemp1d(1))
8705 #ifdef MOMENT
8706       call transpose2(AEA(1,1,2),atempd(1,1))
8707       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8708       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8709 #endif
8710       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8711       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8712 #ifdef MOMENT
8713       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8714       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8715       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8716 #endif
8717 c      s1d=0.0d0
8718 c      s2d=0.0d0
8719 c      s8d=0.0d0
8720 c      s12d=0.0d0
8721 c      s13d=0.0d0
8722 #ifdef MOMENT
8723       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8724      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8725 #else
8726       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8727      &               -0.5d0*ekont*(s2d+s12d)
8728 #endif
8729 C Cartesian derivatives
8730       do iii=1,2
8731         do kkk=1,5
8732           do lll=1,3
8733 #ifdef MOMENT
8734             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8735             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8736             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8737 #endif
8738             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8739             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8740      &          vtemp1d(1))
8741             s2d = scalar2(b1(1,itk),vtemp1d(1))
8742 #ifdef MOMENT
8743             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8744             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8745             s8d = -(atempd(1,1)+atempd(2,2))*
8746      &           scalar2(cc(1,1,itl),vtemp2(1))
8747 #endif
8748             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8749      &           auxmatd(1,1))
8750             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8751             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8752 c      s1d=0.0d0
8753 c      s2d=0.0d0
8754 c      s8d=0.0d0
8755 c      s12d=0.0d0
8756 c      s13d=0.0d0
8757 #ifdef MOMENT
8758             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8759      &        - 0.5d0*(s1d+s2d)
8760 #else
8761             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8762      &        - 0.5d0*s2d
8763 #endif
8764 #ifdef MOMENT
8765             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8766      &        - 0.5d0*(s8d+s12d)
8767 #else
8768             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8769      &        - 0.5d0*s12d
8770 #endif
8771           enddo
8772         enddo
8773       enddo
8774 #ifdef MOMENT
8775       do kkk=1,5
8776         do lll=1,3
8777           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8778      &      achuj_tempd(1,1))
8779           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8780           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8781           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8782           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8783           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8784      &      vtemp4d(1))
8785           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8786           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8787           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8788         enddo
8789       enddo
8790 #endif
8791 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8792 cd     &  16*eel_turn6_num
8793 cd      goto 1112
8794       if (j.lt.nres-1) then
8795         j1=j+1
8796         j2=j-1
8797       else
8798         j1=j-1
8799         j2=j-2
8800       endif
8801       if (l.lt.nres-1) then
8802         l1=l+1
8803         l2=l-1
8804       else
8805         l1=l-1
8806         l2=l-2
8807       endif
8808       do ll=1,3
8809 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8810 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8811 cgrad        ghalf=0.5d0*ggg1(ll)
8812 cd        ghalf=0.0d0
8813         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8814         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8815         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8816      &    +ekont*derx_turn(ll,2,1)
8817         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8818         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8819      &    +ekont*derx_turn(ll,4,1)
8820         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8821         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8822         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8823 cgrad        ghalf=0.5d0*ggg2(ll)
8824 cd        ghalf=0.0d0
8825         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8826      &    +ekont*derx_turn(ll,2,2)
8827         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8828         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8829      &    +ekont*derx_turn(ll,4,2)
8830         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8831         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8832         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8833       enddo
8834 cd      goto 1112
8835 cgrad      do m=i+1,j-1
8836 cgrad        do ll=1,3
8837 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8838 cgrad        enddo
8839 cgrad      enddo
8840 cgrad      do m=k+1,l-1
8841 cgrad        do ll=1,3
8842 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8843 cgrad        enddo
8844 cgrad      enddo
8845 cgrad1112  continue
8846 cgrad      do m=i+2,j2
8847 cgrad        do ll=1,3
8848 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8849 cgrad        enddo
8850 cgrad      enddo
8851 cgrad      do m=k+2,l2
8852 cgrad        do ll=1,3
8853 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8854 cgrad        enddo
8855 cgrad      enddo
8856 cd      do iii=1,nres-3
8857 cd        write (2,*) iii,g_corr6_loc(iii)
8858 cd      enddo
8859       eello_turn6=ekont*eel_turn6
8860 cd      write (2,*) 'ekont',ekont
8861 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8862       return
8863       end
8864
8865 C-----------------------------------------------------------------------------
8866       double precision function scalar(u,v)
8867 !DIR$ INLINEALWAYS scalar
8868 #ifndef OSF
8869 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8870 #endif
8871       implicit none
8872       double precision u(3),v(3)
8873 cd      double precision sc
8874 cd      integer i
8875 cd      sc=0.0d0
8876 cd      do i=1,3
8877 cd        sc=sc+u(i)*v(i)
8878 cd      enddo
8879 cd      scalar=sc
8880
8881       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8882       return
8883       end
8884 crc-------------------------------------------------
8885       SUBROUTINE MATVEC2(A1,V1,V2)
8886 !DIR$ INLINEALWAYS MATVEC2
8887 #ifndef OSF
8888 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8889 #endif
8890       implicit real*8 (a-h,o-z)
8891       include 'DIMENSIONS'
8892       DIMENSION A1(2,2),V1(2),V2(2)
8893 c      DO 1 I=1,2
8894 c        VI=0.0
8895 c        DO 3 K=1,2
8896 c    3     VI=VI+A1(I,K)*V1(K)
8897 c        Vaux(I)=VI
8898 c    1 CONTINUE
8899
8900       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8901       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8902
8903       v2(1)=vaux1
8904       v2(2)=vaux2
8905       END
8906 C---------------------------------------
8907       SUBROUTINE MATMAT2(A1,A2,A3)
8908 #ifndef OSF
8909 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8910 #endif
8911       implicit real*8 (a-h,o-z)
8912       include 'DIMENSIONS'
8913       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8914 c      DIMENSION AI3(2,2)
8915 c        DO  J=1,2
8916 c          A3IJ=0.0
8917 c          DO K=1,2
8918 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8919 c          enddo
8920 c          A3(I,J)=A3IJ
8921 c       enddo
8922 c      enddo
8923
8924       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8925       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8926       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8927       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8928
8929       A3(1,1)=AI3_11
8930       A3(2,1)=AI3_21
8931       A3(1,2)=AI3_12
8932       A3(2,2)=AI3_22
8933       END
8934
8935 c-------------------------------------------------------------------------
8936       double precision function scalar2(u,v)
8937 !DIR$ INLINEALWAYS scalar2
8938       implicit none
8939       double precision u(2),v(2)
8940       double precision sc
8941       integer i
8942       scalar2=u(1)*v(1)+u(2)*v(2)
8943       return
8944       end
8945
8946 C-----------------------------------------------------------------------------
8947
8948       subroutine transpose2(a,at)
8949 !DIR$ INLINEALWAYS transpose2
8950 #ifndef OSF
8951 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8952 #endif
8953       implicit none
8954       double precision a(2,2),at(2,2)
8955       at(1,1)=a(1,1)
8956       at(1,2)=a(2,1)
8957       at(2,1)=a(1,2)
8958       at(2,2)=a(2,2)
8959       return
8960       end
8961 c--------------------------------------------------------------------------
8962       subroutine transpose(n,a,at)
8963       implicit none
8964       integer n,i,j
8965       double precision a(n,n),at(n,n)
8966       do i=1,n
8967         do j=1,n
8968           at(j,i)=a(i,j)
8969         enddo
8970       enddo
8971       return
8972       end
8973 C---------------------------------------------------------------------------
8974       subroutine prodmat3(a1,a2,kk,transp,prod)
8975 !DIR$ INLINEALWAYS prodmat3
8976 #ifndef OSF
8977 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8978 #endif
8979       implicit none
8980       integer i,j
8981       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8982       logical transp
8983 crc      double precision auxmat(2,2),prod_(2,2)
8984
8985       if (transp) then
8986 crc        call transpose2(kk(1,1),auxmat(1,1))
8987 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8988 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8989
8990            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8991      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8992            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8993      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8994            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8995      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8996            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8997      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8998
8999       else
9000 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9001 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9002
9003            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9004      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9005            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9006      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9007            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9008      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9009            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9010      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9011
9012       endif
9013 c      call transpose2(a2(1,1),a2t(1,1))
9014
9015 crc      print *,transp
9016 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9017 crc      print *,((prod(i,j),i=1,2),j=1,2)
9018
9019       return
9020       end
9021