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       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c      print *," Processor",myrank," calls SUM_ENERGY"
 300       call sum_energy(energia,.true.)
 301 c      print *," Processor",myrank," left SUM_ENERGY"
 302 #ifdef TIMING
 303       time_sumene=time_sumene+MPI_Wtime()-time00
 304 #endif
 305       return
 306       end
 307 c-------------------------------------------------------------------------------
 308       subroutine sum_energy(energia,reduce)
 309       implicit real*8 (a-h,o-z)
 310       include 'DIMENSIONS'
 311 #ifndef ISNAN
 312       external proc_proc
 313 #ifdef WINPGI
 314 cMS$ATTRIBUTES C ::  proc_proc
 315 #endif
 316 #endif
 317 #ifdef MPI
 318       include "mpif.h"
 319 #endif
 320       include 'COMMON.SETUP'
 321       include 'COMMON.IOUNITS'
 322       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 323       include 'COMMON.FFIELD'
 324       include 'COMMON.DERIV'
 325       include 'COMMON.INTERACT'
 326       include 'COMMON.SBRIDGE'
 327       include 'COMMON.CHAIN'
 328       include 'COMMON.VAR'
 329       include 'COMMON.CONTROL'
 330       include 'COMMON.TIME1'
 331       logical reduce
 332 #ifdef MPI
 333       if (nfgtasks.gt.1 .and. reduce) then
 334 #ifdef DEBUG
 335         write (iout,*) "energies before REDUCE"
 336         call enerprint(energia)
 337         call flush(iout)
 338 #endif
 339         do i=0,n_ene
 340           enebuff(i)=energia(i)
 341         enddo
 342         time00=MPI_Wtime()
 343         call MPI_Barrier(FG_COMM,IERR)
 344         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 345         time00=MPI_Wtime()
 346         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 347      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 348 #ifdef DEBUG
 349         write (iout,*) "energies after REDUCE"
 350         call enerprint(energia)
 351         call flush(iout)
 352 #endif
 353         time_Reduce=time_Reduce+MPI_Wtime()-time00
 354       endif
 355       if (fg_rank.eq.0) then
 356 #endif
 357       evdw=energia(1)
 358 #ifdef SCP14
 359       evdw2=energia(2)+energia(18)
 360       evdw2_14=energia(18)
 361 #else
 362       evdw2=energia(2)
 363 #endif
 364 #ifdef SPLITELE
 365       ees=energia(3)
 366       evdw1=energia(16)
 367 #else
 368       ees=energia(3)
 369       evdw1=0.0d0
 370 #endif
 371       ecorr=energia(4)
 372       ecorr5=energia(5)
 373       ecorr6=energia(6)
 374       eel_loc=energia(7)
 375       eello_turn3=energia(8)
 376       eello_turn4=energia(9)
 377       eturn6=energia(10)
 378       ebe=energia(11)
 379       escloc=energia(12)
 380       etors=energia(13)
 381       etors_d=energia(14)
 382       ehpb=energia(15)
 383       edihcnstr=energia(19)
 384       estr=energia(17)
 385       Uconst=energia(20)
 386       esccor=energia(21)
 387 #ifdef SPLITELE
 388       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 389      & +wang*ebe+wtor*etors+wscloc*escloc
 390      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 391      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 392      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 393      & +wbond*estr+Uconst+wsccor*esccor
 394 #else
 395       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 396      & +wang*ebe+wtor*etors+wscloc*escloc
 397      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 398      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 399      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 400      & +wbond*estr+Uconst+wsccor*esccor
 401 #endif
 402       energia(0)=etot
 403 c detecting NaNQ
 404 #ifdef ISNAN
 405 #ifdef AIX
 406       if (isnan(etot).ne.0) energia(0)=1.0d+99
 407 #else
 408       if (isnan(etot)) energia(0)=1.0d+99
 409 #endif
 410 #else
 411       i=0
 412 #ifdef WINPGI
 413       idumm=proc_proc(etot,i)
 414 #else
 415       call proc_proc(etot,i)
 416 #endif
 417       if(i.eq.1)energia(0)=1.0d+99
 418 #endif
 419 #ifdef MPI
 420       endif
 421 #endif
 422       return
 423       end
 424 c-------------------------------------------------------------------------------
 425       subroutine sum_gradient
 426       implicit real*8 (a-h,o-z)
 427       include 'DIMENSIONS'
 428 #ifndef ISNAN
 429       external proc_proc
 430 #ifdef WINPGI
 431 cMS$ATTRIBUTES C ::  proc_proc
 432 #endif
 433 #endif
 434 #ifdef MPI
 435       include 'mpif.h'
 436       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 437      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 438 #endif
 439       include 'COMMON.SETUP'
 440       include 'COMMON.IOUNITS'
 441       include 'COMMON.FFIELD'
 442       include 'COMMON.DERIV'
 443       include 'COMMON.INTERACT'
 444       include 'COMMON.SBRIDGE'
 445       include 'COMMON.CHAIN'
 446       include 'COMMON.VAR'
 447       include 'COMMON.CONTROL'
 448       include 'COMMON.TIME1'
 449       include 'COMMON.MAXGRAD'
 450       include 'COMMON.SCCOR'
 451 #ifdef TIMING
 452       time01=MPI_Wtime()
 453 #endif
 454 #ifdef DEBUG
 455       write (iout,*) "sum_gradient gvdwc, gvdwx"
 456       do i=1,nres
 457         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 458      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 459       enddo
 460       call flush(iout)
 461 #endif
 462 #ifdef MPI
 463 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 464         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 465      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 466 #endif
 467 C
 468 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 469 C            in virtual-bond-vector coordinates
 470 C
 471 #ifdef DEBUG
 472 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 473 c      do i=1,nres-1
 474 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 475 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 476 c      enddo
 477 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 478 c      do i=1,nres-1
 479 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 480 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 481 c      enddo
 482       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 483       do i=1,nres
 484         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 485      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 486      &   g_corr5_loc(i)
 487       enddo
 488       call flush(iout)
 489 #endif
 490 #ifdef SPLITELE
 491       do i=1,nct
 492         do j=1,3
 493           gradbufc(j,i)=wsc*gvdwc(j,i)+
 494      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 495      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 496      &                wel_loc*gel_loc_long(j,i)+
 497      &                wcorr*gradcorr_long(j,i)+
 498      &                wcorr5*gradcorr5_long(j,i)+
 499      &                wcorr6*gradcorr6_long(j,i)+
 500      &                wturn6*gcorr6_turn_long(j,i)+
 501      &                wstrain*ghpbc(j,i)
 502         enddo
 503       enddo
 504 #else
 505       do i=1,nct
 506         do j=1,3
 507           gradbufc(j,i)=wsc*gvdwc(j,i)+
 508      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 509      &                welec*gelc_long(j,i)+
 510      &                wbond*gradb(j,i)+
 511      &                wel_loc*gel_loc_long(j,i)+
 512      &                wcorr*gradcorr_long(j,i)+
 513      &                wcorr5*gradcorr5_long(j,i)+
 514      &                wcorr6*gradcorr6_long(j,i)+
 515      &                wturn6*gcorr6_turn_long(j,i)+
 516      &                wstrain*ghpbc(j,i)
 517         enddo
 518       enddo
 519 #endif
 520 #ifdef MPI
 521       if (nfgtasks.gt.1) then
 522       time00=MPI_Wtime()
 523 #ifdef DEBUG
 524       write (iout,*) "gradbufc before allreduce"
 525       do i=1,nres
 526         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 527       enddo
 528       call flush(iout)
 529 #endif
 530       do i=1,nres
 531         do j=1,3
 532           gradbufc_sum(j,i)=gradbufc(j,i)
 533         enddo
 534       enddo
 535 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 536 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 537 c      time_reduce=time_reduce+MPI_Wtime()-time00
 538 #ifdef DEBUG
 539 c      write (iout,*) "gradbufc_sum after allreduce"
 540 c      do i=1,nres
 541 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 542 c      enddo
 543 c      call flush(iout)
 544 #endif
 545 #ifdef TIMING
 546 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 547 #endif
 548       do i=nnt,nres
 549         do k=1,3
 550           gradbufc(k,i)=0.0d0
 551         enddo
 552       enddo
 553 #ifdef DEBUG
 554       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 555       write (iout,*) (i," jgrad_start",jgrad_start(i),
 556      &                  " jgrad_end  ",jgrad_end(i),
 557      &                  i=igrad_start,igrad_end)
 558 #endif
 559 c
 560 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 561 c do not parallelize this part.
 562 c
 563 c      do i=igrad_start,igrad_end
 564 c        do j=jgrad_start(i),jgrad_end(i)
 565 c          do k=1,3
 566 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 567 c          enddo
 568 c        enddo
 569 c      enddo
 570       do j=1,3
 571         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 572       enddo
 573       do i=nres-2,nnt,-1
 574         do j=1,3
 575           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 576         enddo
 577       enddo
 578 #ifdef DEBUG
 579       write (iout,*) "gradbufc after summing"
 580       do i=1,nres
 581         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 582       enddo
 583       call flush(iout)
 584 #endif
 585       else
 586 #endif
 587 #ifdef DEBUG
 588       write (iout,*) "gradbufc"
 589       do i=1,nres
 590         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 591       enddo
 592       call flush(iout)
 593 #endif
 594       do i=1,nres
 595         do j=1,3
 596           gradbufc_sum(j,i)=gradbufc(j,i)
 597           gradbufc(j,i)=0.0d0
 598         enddo
 599       enddo
 600       do j=1,3
 601         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 602       enddo
 603       do i=nres-2,nnt,-1
 604         do j=1,3
 605           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 606         enddo
 607       enddo
 608 c      do i=nnt,nres-1
 609 c        do k=1,3
 610 c          gradbufc(k,i)=0.0d0
 611 c        enddo
 612 c        do j=i+1,nres
 613 c          do k=1,3
 614 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 615 c          enddo
 616 c        enddo
 617 c      enddo
 618 #ifdef DEBUG
 619       write (iout,*) "gradbufc after summing"
 620       do i=1,nres
 621         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 622       enddo
 623       call flush(iout)
 624 #endif
 625 #ifdef MPI
 626       endif
 627 #endif
 628       do k=1,3
 629         gradbufc(k,nres)=0.0d0
 630       enddo
 631       do i=1,nct
 632         do j=1,3
 633 #ifdef SPLITELE
 634           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 635      &                wel_loc*gel_loc(j,i)+
 636      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 637      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 638      &                wel_loc*gel_loc_long(j,i)+
 639      &                wcorr*gradcorr_long(j,i)+
 640      &                wcorr5*gradcorr5_long(j,i)+
 641      &                wcorr6*gradcorr6_long(j,i)+
 642      &                wturn6*gcorr6_turn_long(j,i))+
 643      &                wbond*gradb(j,i)+
 644      &                wcorr*gradcorr(j,i)+
 645      &                wturn3*gcorr3_turn(j,i)+
 646      &                wturn4*gcorr4_turn(j,i)+
 647      &                wcorr5*gradcorr5(j,i)+
 648      &                wcorr6*gradcorr6(j,i)+
 649      &                wturn6*gcorr6_turn(j,i)+
 650      &                wsccor*gsccorc(j,i)
 651      &               +wscloc*gscloc(j,i)
 652 #else
 653           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 654      &                wel_loc*gel_loc(j,i)+
 655      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 656      &                welec*gelc_long(j,i)
 657      &                wel_loc*gel_loc_long(j,i)+
 658      &                wcorr*gcorr_long(j,i)+
 659      &                wcorr5*gradcorr5_long(j,i)+
 660      &                wcorr6*gradcorr6_long(j,i)+
 661      &                wturn6*gcorr6_turn_long(j,i))+
 662      &                wbond*gradb(j,i)+
 663      &                wcorr*gradcorr(j,i)+
 664      &                wturn3*gcorr3_turn(j,i)+
 665      &                wturn4*gcorr4_turn(j,i)+
 666      &                wcorr5*gradcorr5(j,i)+
 667      &                wcorr6*gradcorr6(j,i)+
 668      &                wturn6*gcorr6_turn(j,i)+
 669      &                wsccor*gsccorc(j,i)
 670      &               +wscloc*gscloc(j,i)
 671 #endif
 672           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 673      &                  wbond*gradbx(j,i)+
 674      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 675      &                  wsccor*gsccorx(j,i)
 676      &                 +wscloc*gsclocx(j,i)
 677         enddo
 678       enddo
 679 #ifdef DEBUG
 680       write (iout,*) "gloc before adding corr"
 681       do i=1,4*nres
 682         write (iout,*) i,gloc(i,icg)
 683       enddo
 684 #endif
 685       do i=1,nres-3
 686         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 687      &   +wcorr5*g_corr5_loc(i)
 688      &   +wcorr6*g_corr6_loc(i)
 689      &   +wturn4*gel_loc_turn4(i)
 690      &   +wturn3*gel_loc_turn3(i)
 691      &   +wturn6*gel_loc_turn6(i)
 692      &   +wel_loc*gel_loc_loc(i)
 693       enddo
 694 #ifdef DEBUG
 695       write (iout,*) "gloc after adding corr"
 696       do i=1,4*nres
 697         write (iout,*) i,gloc(i,icg)
 698       enddo
 699 #endif
 700 #ifdef MPI
 701       if (nfgtasks.gt.1) then
 702         do j=1,3
 703           do i=1,nres
 704             gradbufc(j,i)=gradc(j,i,icg)
 705             gradbufx(j,i)=gradx(j,i,icg)
 706           enddo
 707         enddo
 708         do i=1,4*nres
 709           glocbuf(i)=gloc(i,icg)
 710         enddo
 711 #define DEBUG
 712 #ifdef DEBUG
 713       write (iout,*) "gloc_sc before reduce"
 714       do i=1,nres
 715        do j=1,1
 716         write (iout,*) i,j,gloc_sc(j,i,icg)
 717        enddo
 718       enddo
 719 #endif
 720 #undef DEBUG
 721         do i=1,nres
 722          do j=1,3
 723           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 724          enddo
 725         enddo
 726         time00=MPI_Wtime()
 727         call MPI_Barrier(FG_COMM,IERR)
 728         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 729         time00=MPI_Wtime()
 730         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 731      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 732         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         time_reduce=time_reduce+MPI_Wtime()-time00
 737         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 738      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 739         time_reduce=time_reduce+MPI_Wtime()-time00
 740 #define DEBUG
 741 #ifdef DEBUG
 742       write (iout,*) "gloc_sc after reduce"
 743       do i=1,nres
 744        do j=1,1
 745         write (iout,*) i,j,gloc_sc(j,i,icg)
 746        enddo
 747       enddo
 748 #endif
 749 #undef DEBUG
 750 #ifdef DEBUG
 751       write (iout,*) "gloc after reduce"
 752       do i=1,4*nres
 753         write (iout,*) i,gloc(i,icg)
 754       enddo
 755 #endif
 756       endif
 757 #endif
 758       if (gnorm_check) then
 759 c
 760 c Compute the maximum elements of the gradient
 761 c
 762       gvdwc_max=0.0d0
 763       gvdwc_scp_max=0.0d0
 764       gelc_max=0.0d0
 765       gvdwpp_max=0.0d0
 766       gradb_max=0.0d0
 767       ghpbc_max=0.0d0
 768       gradcorr_max=0.0d0
 769       gel_loc_max=0.0d0
 770       gcorr3_turn_max=0.0d0
 771       gcorr4_turn_max=0.0d0
 772       gradcorr5_max=0.0d0
 773       gradcorr6_max=0.0d0
 774       gcorr6_turn_max=0.0d0
 775       gsccorc_max=0.0d0
 776       gscloc_max=0.0d0
 777       gvdwx_max=0.0d0
 778       gradx_scp_max=0.0d0
 779       ghpbx_max=0.0d0
 780       gradxorr_max=0.0d0
 781       gsccorx_max=0.0d0
 782       gsclocx_max=0.0d0
 783       do i=1,nct
 784         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 785         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 786         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 787         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 788      &   gvdwc_scp_max=gvdwc_scp_norm
 789         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 790         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 791         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 792         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 793         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 794         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 795         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 796         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 797         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 798         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 799         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 800         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 801         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 802      &    gcorr3_turn(1,i)))
 803         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 804      &    gcorr3_turn_max=gcorr3_turn_norm
 805         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 806      &    gcorr4_turn(1,i)))
 807         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 808      &    gcorr4_turn_max=gcorr4_turn_norm
 809         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 810         if (gradcorr5_norm.gt.gradcorr5_max)
 811      &    gradcorr5_max=gradcorr5_norm
 812         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 813         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 814         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 815      &    gcorr6_turn(1,i)))
 816         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 817      &    gcorr6_turn_max=gcorr6_turn_norm
 818         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 819         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 820         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 821         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 822         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 823         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 824         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 825         if (gradx_scp_norm.gt.gradx_scp_max)
 826      &    gradx_scp_max=gradx_scp_norm
 827         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 828         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 829         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 830         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 831         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 832         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 833         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 834         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 835       enddo
 836       if (gradout) then
 837 #ifdef AIX
 838         open(istat,file=statname,position="append")
 839 #else
 840         open(istat,file=statname,access="append")
 841 #endif
 842         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 843      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 844      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 845      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 846      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 847      &     gsccorx_max,gsclocx_max
 848         close(istat)
 849         if (gvdwc_max.gt.1.0d4) then
 850           write (iout,*) "gvdwc gvdwx gradb gradbx"
 851           do i=nnt,nct
 852             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 853      &        gradb(j,i),gradbx(j,i),j=1,3)
 854           enddo
 855           call pdbout(0.0d0,'cipiszcze',iout)
 856           call flush(iout)
 857         endif
 858       endif
 859       endif
 860 #ifdef DEBUG
 861       write (iout,*) "gradc gradx gloc"
 862       do i=1,nres
 863         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 864      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 865       enddo
 866 #endif
 867 #ifdef TIMING
 868       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 869 #endif
 870       return
 871       end
 872 c-------------------------------------------------------------------------------
 873       subroutine rescale_weights(t_bath)
 874       implicit real*8 (a-h,o-z)
 875       include 'DIMENSIONS'
 876       include 'COMMON.IOUNITS'
 877       include 'COMMON.FFIELD'
 878       include 'COMMON.SBRIDGE'
 879       double precision kfac /2.4d0/
 880       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 881 c      facT=temp0/t_bath
 882 c      facT=2*temp0/(t_bath+temp0)
 883       if (rescale_mode.eq.0) then
 884         facT=1.0d0
 885         facT2=1.0d0
 886         facT3=1.0d0
 887         facT4=1.0d0
 888         facT5=1.0d0
 889       else if (rescale_mode.eq.1) then
 890         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 891         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 892         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 893         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 894         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 895       else if (rescale_mode.eq.2) then
 896         x=t_bath/temp0
 897         x2=x*x
 898         x3=x2*x
 899         x4=x3*x
 900         x5=x4*x
 901         facT=licznik/dlog(dexp(x)+dexp(-x))
 902         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 903         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 904         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 905         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 906       else
 907         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 908         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 909 #ifdef MPI
 910        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 911 #endif
 912        stop 555
 913       endif
 914       welec=weights(3)*fact
 915       wcorr=weights(4)*fact3
 916       wcorr5=weights(5)*fact4
 917       wcorr6=weights(6)*fact5
 918       wel_loc=weights(7)*fact2
 919       wturn3=weights(8)*fact2
 920       wturn4=weights(9)*fact3
 921       wturn6=weights(10)*fact5
 922       wtor=weights(13)*fact
 923       wtor_d=weights(14)*fact2
 924       wsccor=weights(21)*fact
 925
 926       return
 927       end
 928 C------------------------------------------------------------------------
 929       subroutine enerprint(energia)
 930       implicit real*8 (a-h,o-z)
 931       include 'DIMENSIONS'
 932       include 'COMMON.IOUNITS'
 933       include 'COMMON.FFIELD'
 934       include 'COMMON.SBRIDGE'
 935       include 'COMMON.MD'
 936       double precision energia(0:n_ene)
 937       etot=energia(0)
 938       evdw=energia(1)
 939       evdw2=energia(2)
 940 #ifdef SCP14
 941       evdw2=energia(2)+energia(18)
 942 #else
 943       evdw2=energia(2)
 944 #endif
 945       ees=energia(3)
 946 #ifdef SPLITELE
 947       evdw1=energia(16)
 948 #endif
 949       ecorr=energia(4)
 950       ecorr5=energia(5)
 951       ecorr6=energia(6)
 952       eel_loc=energia(7)
 953       eello_turn3=energia(8)
 954       eello_turn4=energia(9)
 955       eello_turn6=energia(10)
 956       ebe=energia(11)
 957       escloc=energia(12)
 958       etors=energia(13)
 959       etors_d=energia(14)
 960       ehpb=energia(15)
 961       edihcnstr=energia(19)
 962       estr=energia(17)
 963       Uconst=energia(20)
 964       esccor=energia(21)
 965 #ifdef SPLITELE
 966       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 967      &  estr,wbond,ebe,wang,
 968      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 969      &  ecorr,wcorr,
 970      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 971      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 972      &  edihcnstr,ebr*nss,
 973      &  Uconst,etot
 974    10 format (/'Virtual-chain energies:'//
 975      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 976      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 977      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 978      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 979      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 980      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 981      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 982      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 983      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 984      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 985      & ' (SS bridges & dist. cnstr.)'/
 986      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 987      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 988      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 990      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 991      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 992      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 993      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 994      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 995      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 996      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 997      & 'ETOT=  ',1pE16.6,' (total)')
 998 #else
 999       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1000      &  estr,wbond,ebe,wang,
1001      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1002      &  ecorr,wcorr,
1003      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1004      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1005      &  ebr*nss,Uconst,etot
1006    10 format (/'Virtual-chain energies:'//
1007      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1008      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1009      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1010      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1011      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1012      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1013      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1014      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1015      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1016      & ' (SS bridges & dist. cnstr.)'/
1017      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1018      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1019      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1021      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1022      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1023      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1024      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1025      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1026      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1027      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1028      & 'ETOT=  ',1pE16.6,' (total)')
1029 #endif
1030       return
1031       end
1032 C-----------------------------------------------------------------------
1033       subroutine elj(evdw)
1034 C
1035 C This subroutine calculates the interaction energy of nonbonded side chains
1036 C assuming the LJ potential of interaction.
1037 C
1038       implicit real*8 (a-h,o-z)
1039       include 'DIMENSIONS'
1040       parameter (accur=1.0d-10)
1041       include 'COMMON.GEO'
1042       include 'COMMON.VAR'
1043       include 'COMMON.LOCAL'
1044       include 'COMMON.CHAIN'
1045       include 'COMMON.DERIV'
1046       include 'COMMON.INTERACT'
1047       include 'COMMON.TORSION'
1048       include 'COMMON.SBRIDGE'
1049       include 'COMMON.NAMES'
1050       include 'COMMON.IOUNITS'
1051       include 'COMMON.CONTACTS'
1052       dimension gg(3)
1053 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1054       evdw=0.0D0
1055       do i=iatsc_s,iatsc_e
1056         itypi=iabs(itype(i))
1057         if (itypi.eq.ntyp1) cycle
1058         itypi1=iabs(itype(i+1))
1059         xi=c(1,nres+i)
1060         yi=c(2,nres+i)
1061         zi=c(3,nres+i)
1062 C Change 12/1/95
1063         num_conti=0
1064 C
1065 C Calculate SC interaction energy.
1066 C
1067         do iint=1,nint_gr(i)
1068 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1069 cd   &                  'iend=',iend(i,iint)
1070           do j=istart(i,iint),iend(i,iint)
1071             itypj=iabs(itype(j))
1072             if (itypj.eq.ntyp1) cycle
1073             xj=c(1,nres+j)-xi
1074             yj=c(2,nres+j)-yi
1075             zj=c(3,nres+j)-zi
1076 C Change 12/1/95 to calculate four-body interactions
1077             rij=xj*xj+yj*yj+zj*zj
1078             rrij=1.0D0/rij
1079 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1080             eps0ij=eps(itypi,itypj)
1081             fac=rrij**expon2
1082             e1=fac*fac*aa(itypi,itypj)
1083             e2=fac*bb(itypi,itypj)
1084             evdwij=e1+e2
1085 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1086 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1087 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1088 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1089 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1090 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1091             evdw=evdw+evdwij
1092 C
1093 C Calculate the components of the gradient in DC and X
1094 C
1095             fac=-rrij*(e1+evdwij)
1096             gg(1)=xj*fac
1097             gg(2)=yj*fac
1098             gg(3)=zj*fac
1099             do k=1,3
1100               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1101               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1102               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1103               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1104             enddo
1105 cgrad            do k=i,j-1
1106 cgrad              do l=1,3
1107 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1108 cgrad              enddo
1109 cgrad            enddo
1110 C
1111 C 12/1/95, revised on 5/20/97
1112 C
1113 C Calculate the contact function. The ith column of the array JCONT will
1114 C contain the numbers of atoms that make contacts with the atom I (of numbers
1115 C greater than I). The arrays FACONT and GACONT will contain the values of
1116 C the contact function and its derivative.
1117 C
1118 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1119 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1120 C Uncomment next line, if the correlation interactions are contact function only
1121             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1122               rij=dsqrt(rij)
1123               sigij=sigma(itypi,itypj)
1124               r0ij=rs0(itypi,itypj)
1125 C
1126 C Check whether the SC's are not too far to make a contact.
1127 C
1128               rcut=1.5d0*r0ij
1129               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1130 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1131 C
1132               if (fcont.gt.0.0D0) then
1133 C If the SC-SC distance if close to sigma, apply spline.
1134 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1135 cAdam &             fcont1,fprimcont1)
1136 cAdam           fcont1=1.0d0-fcont1
1137 cAdam           if (fcont1.gt.0.0d0) then
1138 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1139 cAdam             fcont=fcont*fcont1
1140 cAdam           endif
1141 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1142 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1143 cga             do k=1,3
1144 cga               gg(k)=gg(k)*eps0ij
1145 cga             enddo
1146 cga             eps0ij=-evdwij*eps0ij
1147 C Uncomment for AL's type of SC correlation interactions.
1148 cadam           eps0ij=-evdwij
1149                 num_conti=num_conti+1
1150                 jcont(num_conti,i)=j
1151                 facont(num_conti,i)=fcont*eps0ij
1152                 fprimcont=eps0ij*fprimcont/rij
1153                 fcont=expon*fcont
1154 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1155 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1156 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1157 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1158                 gacont(1,num_conti,i)=-fprimcont*xj
1159                 gacont(2,num_conti,i)=-fprimcont*yj
1160                 gacont(3,num_conti,i)=-fprimcont*zj
1161 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1162 cd              write (iout,'(2i3,3f10.5)')
1163 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1164               endif
1165             endif
1166           enddo      ! j
1167         enddo        ! iint
1168 C Change 12/1/95
1169         num_cont(i)=num_conti
1170       enddo          ! i
1171       do i=1,nct
1172         do j=1,3
1173           gvdwc(j,i)=expon*gvdwc(j,i)
1174           gvdwx(j,i)=expon*gvdwx(j,i)
1175         enddo
1176       enddo
1177 C******************************************************************************
1178 C
1179 C                              N O T E !!!
1180 C
1181 C To save time, the factor of EXPON has been extracted from ALL components
1182 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1183 C use!
1184 C
1185 C******************************************************************************
1186       return
1187       end
1188 C-----------------------------------------------------------------------------
1189       subroutine eljk(evdw)
1190 C
1191 C This subroutine calculates the interaction energy of nonbonded side chains
1192 C assuming the LJK potential of interaction.
1193 C
1194       implicit real*8 (a-h,o-z)
1195       include 'DIMENSIONS'
1196       include 'COMMON.GEO'
1197       include 'COMMON.VAR'
1198       include 'COMMON.LOCAL'
1199       include 'COMMON.CHAIN'
1200       include 'COMMON.DERIV'
1201       include 'COMMON.INTERACT'
1202       include 'COMMON.IOUNITS'
1203       include 'COMMON.NAMES'
1204       dimension gg(3)
1205       logical scheck
1206 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1207       evdw=0.0D0
1208       do i=iatsc_s,iatsc_e
1209         itypi=iabs(itype(i))
1210         if (itypi.eq.ntyp1) cycle
1211         itypi1=iabs(itype(i+1))
1212         xi=c(1,nres+i)
1213         yi=c(2,nres+i)
1214         zi=c(3,nres+i)
1215 C
1216 C Calculate SC interaction energy.
1217 C
1218         do iint=1,nint_gr(i)
1219           do j=istart(i,iint),iend(i,iint)
1220             itypj=iabs(itype(j))
1221             if (itypj.eq.ntyp1) cycle
1222             xj=c(1,nres+j)-xi
1223             yj=c(2,nres+j)-yi
1224             zj=c(3,nres+j)-zi
1225             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1226             fac_augm=rrij**expon
1227             e_augm=augm(itypi,itypj)*fac_augm
1228             r_inv_ij=dsqrt(rrij)
1229             rij=1.0D0/r_inv_ij
1230             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1231             fac=r_shift_inv**expon
1232             e1=fac*fac*aa(itypi,itypj)
1233             e2=fac*bb(itypi,itypj)
1234             evdwij=e_augm+e1+e2
1235 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1236 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1237 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1238 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1239 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1240 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1241 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1242             evdw=evdw+evdwij
1243 C
1244 C Calculate the components of the gradient in DC and X
1245 C
1246             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1247             gg(1)=xj*fac
1248             gg(2)=yj*fac
1249             gg(3)=zj*fac
1250             do k=1,3
1251               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1252               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1253               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1254               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1255             enddo
1256 cgrad            do k=i,j-1
1257 cgrad              do l=1,3
1258 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1259 cgrad              enddo
1260 cgrad            enddo
1261           enddo      ! j
1262         enddo        ! iint
1263       enddo          ! i
1264       do i=1,nct
1265         do j=1,3
1266           gvdwc(j,i)=expon*gvdwc(j,i)
1267           gvdwx(j,i)=expon*gvdwx(j,i)
1268         enddo
1269       enddo
1270       return
1271       end
1272 C-----------------------------------------------------------------------------
1273       subroutine ebp(evdw)
1274 C
1275 C This subroutine calculates the interaction energy of nonbonded side chains
1276 C assuming the Berne-Pechukas potential of interaction.
1277 C
1278       implicit real*8 (a-h,o-z)
1279       include 'DIMENSIONS'
1280       include 'COMMON.GEO'
1281       include 'COMMON.VAR'
1282       include 'COMMON.LOCAL'
1283       include 'COMMON.CHAIN'
1284       include 'COMMON.DERIV'
1285       include 'COMMON.NAMES'
1286       include 'COMMON.INTERACT'
1287       include 'COMMON.IOUNITS'
1288       include 'COMMON.CALC'
1289       common /srutu/ icall
1290 c     double precision rrsave(maxdim)
1291       logical lprn
1292       evdw=0.0D0
1293 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1294       evdw=0.0D0
1295 c     if (icall.eq.0) then
1296 c       lprn=.true.
1297 c     else
1298         lprn=.false.
1299 c     endif
1300       ind=0
1301       do i=iatsc_s,iatsc_e
1302         itypi=iabs(itype(i))
1303         if (itypi.eq.ntyp1) cycle
1304         itypi1=iabs(itype(i+1))
1305         xi=c(1,nres+i)
1306         yi=c(2,nres+i)
1307         zi=c(3,nres+i)
1308         dxi=dc_norm(1,nres+i)
1309         dyi=dc_norm(2,nres+i)
1310         dzi=dc_norm(3,nres+i)
1311 c        dsci_inv=dsc_inv(itypi)
1312         dsci_inv=vbld_inv(i+nres)
1313 C
1314 C Calculate SC interaction energy.
1315 C
1316         do iint=1,nint_gr(i)
1317           do j=istart(i,iint),iend(i,iint)
1318             ind=ind+1
1319             itypj=iabs(itype(j))
1320             if (itypj.eq.ntyp1) cycle
1321 c            dscj_inv=dsc_inv(itypj)
1322             dscj_inv=vbld_inv(j+nres)
1323             chi1=chi(itypi,itypj)
1324             chi2=chi(itypj,itypi)
1325             chi12=chi1*chi2
1326             chip1=chip(itypi)
1327             chip2=chip(itypj)
1328             chip12=chip1*chip2
1329             alf1=alp(itypi)
1330             alf2=alp(itypj)
1331             alf12=0.5D0*(alf1+alf2)
1332 C For diagnostics only!!!
1333 c           chi1=0.0D0
1334 c           chi2=0.0D0
1335 c           chi12=0.0D0
1336 c           chip1=0.0D0
1337 c           chip2=0.0D0
1338 c           chip12=0.0D0
1339 c           alf1=0.0D0
1340 c           alf2=0.0D0
1341 c           alf12=0.0D0
1342             xj=c(1,nres+j)-xi
1343             yj=c(2,nres+j)-yi
1344             zj=c(3,nres+j)-zi
1345             dxj=dc_norm(1,nres+j)
1346             dyj=dc_norm(2,nres+j)
1347             dzj=dc_norm(3,nres+j)
1348             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1349 cd          if (icall.eq.0) then
1350 cd            rrsave(ind)=rrij
1351 cd          else
1352 cd            rrij=rrsave(ind)
1353 cd          endif
1354             rij=dsqrt(rrij)
1355 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1356             call sc_angular
1357 C Calculate whole angle-dependent part of epsilon and contributions
1358 C to its derivatives
1359             fac=(rrij*sigsq)**expon2
1360             e1=fac*fac*aa(itypi,itypj)
1361             e2=fac*bb(itypi,itypj)
1362             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1363             eps2der=evdwij*eps3rt
1364             eps3der=evdwij*eps2rt
1365             evdwij=evdwij*eps2rt*eps3rt
1366             evdw=evdw+evdwij
1367             if (lprn) then
1368             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1369             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1370 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1371 cd     &        restyp(itypi),i,restyp(itypj),j,
1372 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1373 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1374 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1375 cd     &        evdwij
1376             endif
1377 C Calculate gradient components.
1378             e1=e1*eps1*eps2rt**2*eps3rt**2
1379             fac=-expon*(e1+evdwij)
1380             sigder=fac/sigsq
1381             fac=rrij*fac
1382 C Calculate radial part of the gradient
1383             gg(1)=xj*fac
1384             gg(2)=yj*fac
1385             gg(3)=zj*fac
1386 C Calculate the angular part of the gradient and sum add the contributions
1387 C to the appropriate components of the Cartesian gradient.
1388             call sc_grad
1389           enddo      ! j
1390         enddo        ! iint
1391       enddo          ! i
1392 c     stop
1393       return
1394       end
1395 C-----------------------------------------------------------------------------
1396       subroutine egb(evdw)
1397 C
1398 C This subroutine calculates the interaction energy of nonbonded side chains
1399 C assuming the Gay-Berne potential of interaction.
1400 C
1401       implicit real*8 (a-h,o-z)
1402       include 'DIMENSIONS'
1403       include 'COMMON.GEO'
1404       include 'COMMON.VAR'
1405       include 'COMMON.LOCAL'
1406       include 'COMMON.CHAIN'
1407       include 'COMMON.DERIV'
1408       include 'COMMON.NAMES'
1409       include 'COMMON.INTERACT'
1410       include 'COMMON.IOUNITS'
1411       include 'COMMON.CALC'
1412       include 'COMMON.CONTROL'
1413       logical lprn
1414       evdw=0.0D0
1415 ccccc      energy_dec=.false.
1416 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1417       evdw=0.0D0
1418       lprn=.false.
1419 c     if (icall.eq.0) lprn=.false.
1420       ind=0
1421       do i=iatsc_s,iatsc_e
1422         itypi=iabs(itype(i))
1423         if (itypi.eq.ntyp1) cycle
1424         itypi1=iabs(itype(i+1))
1425         xi=c(1,nres+i)
1426         yi=c(2,nres+i)
1427         zi=c(3,nres+i)
1428         dxi=dc_norm(1,nres+i)
1429         dyi=dc_norm(2,nres+i)
1430         dzi=dc_norm(3,nres+i)
1431 c        dsci_inv=dsc_inv(itypi)
1432         dsci_inv=vbld_inv(i+nres)
1433 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1434 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1435 C
1436 C Calculate SC interaction energy.
1437 C
1438         do iint=1,nint_gr(i)
1439           do j=istart(i,iint),iend(i,iint)
1440             ind=ind+1
1441             itypj=iabs(itype(j))
1442             if (itypj.eq.ntyp1) cycle
1443 c            dscj_inv=dsc_inv(itypj)
1444             dscj_inv=vbld_inv(j+nres)
1445 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1446 c     &       1.0d0/vbld(j+nres)
1447 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1448             sig0ij=sigma(itypi,itypj)
1449             chi1=chi(itypi,itypj)
1450             chi2=chi(itypj,itypi)
1451             chi12=chi1*chi2
1452             chip1=chip(itypi)
1453             chip2=chip(itypj)
1454             chip12=chip1*chip2
1455             alf1=alp(itypi)
1456             alf2=alp(itypj)
1457             alf12=0.5D0*(alf1+alf2)
1458 C For diagnostics only!!!
1459 c           chi1=0.0D0
1460 c           chi2=0.0D0
1461 c           chi12=0.0D0
1462 c           chip1=0.0D0
1463 c           chip2=0.0D0
1464 c           chip12=0.0D0
1465 c           alf1=0.0D0
1466 c           alf2=0.0D0
1467 c           alf12=0.0D0
1468             xj=c(1,nres+j)-xi
1469             yj=c(2,nres+j)-yi
1470             zj=c(3,nres+j)-zi
1471             dxj=dc_norm(1,nres+j)
1472             dyj=dc_norm(2,nres+j)
1473             dzj=dc_norm(3,nres+j)
1474 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1475 c            write (iout,*) "j",j," dc_norm",
1476 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1477             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1478             rij=dsqrt(rrij)
1479 C Calculate angle-dependent terms of energy and contributions to their
1480 C derivatives.
1481             call sc_angular
1482             sigsq=1.0D0/sigsq
1483             sig=sig0ij*dsqrt(sigsq)
1484             rij_shift=1.0D0/rij-sig+sig0ij
1485 c for diagnostics; uncomment
1486 c            rij_shift=1.2*sig0ij
1487 C I hate to put IF's in the loops, but here don't have another choice!!!!
1488             if (rij_shift.le.0.0D0) then
1489               evdw=1.0D20
1490 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1491 cd     &        restyp(itypi),i,restyp(itypj),j,
1492 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1493               return
1494             endif
1495             sigder=-sig*sigsq
1496 c---------------------------------------------------------------
1497             rij_shift=1.0D0/rij_shift
1498             fac=rij_shift**expon
1499             e1=fac*fac*aa(itypi,itypj)
1500             e2=fac*bb(itypi,itypj)
1501             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1502             eps2der=evdwij*eps3rt
1503             eps3der=evdwij*eps2rt
1504 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1505 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1506             evdwij=evdwij*eps2rt*eps3rt
1507             evdw=evdw+evdwij
1508             if (lprn) then
1509             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1510             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1511             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1512      &        restyp(itypi),i,restyp(itypj),j,
1513      &        epsi,sigm,chi1,chi2,chip1,chip2,
1514      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1515      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1516      &        evdwij
1517             endif
1518
1519             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1520      &                        'evdw',i,j,evdwij
1521
1522 C Calculate gradient components.
1523             e1=e1*eps1*eps2rt**2*eps3rt**2
1524             fac=-expon*(e1+evdwij)*rij_shift
1525             sigder=fac*sigder
1526             fac=rij*fac
1527 c            fac=0.0d0
1528 C Calculate the radial part of the gradient
1529             gg(1)=xj*fac
1530             gg(2)=yj*fac
1531             gg(3)=zj*fac
1532 C Calculate angular part of the gradient.
1533             call sc_grad
1534           enddo      ! j
1535         enddo        ! iint
1536       enddo          ! i
1537 c      write (iout,*) "Number of loop steps in EGB:",ind
1538 cccc      energy_dec=.false.
1539       return
1540       end
1541 C-----------------------------------------------------------------------------
1542       subroutine egbv(evdw)
1543 C
1544 C This subroutine calculates the interaction energy of nonbonded side chains
1545 C assuming the Gay-Berne-Vorobjev potential of interaction.
1546 C
1547       implicit real*8 (a-h,o-z)
1548       include 'DIMENSIONS'
1549       include 'COMMON.GEO'
1550       include 'COMMON.VAR'
1551       include 'COMMON.LOCAL'
1552       include 'COMMON.CHAIN'
1553       include 'COMMON.DERIV'
1554       include 'COMMON.NAMES'
1555       include 'COMMON.INTERACT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.CALC'
1558       common /srutu/ icall
1559       logical lprn
1560       evdw=0.0D0
1561 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1562       evdw=0.0D0
1563       lprn=.false.
1564 c     if (icall.eq.0) lprn=.true.
1565       ind=0
1566       do i=iatsc_s,iatsc_e
1567         itypi=iabs(itype(i))
1568         if (itypi.eq.ntyp1) cycle
1569         itypi1=iabs(itype(i+1))
1570         xi=c(1,nres+i)
1571         yi=c(2,nres+i)
1572         zi=c(3,nres+i)
1573         dxi=dc_norm(1,nres+i)
1574         dyi=dc_norm(2,nres+i)
1575         dzi=dc_norm(3,nres+i)
1576 c        dsci_inv=dsc_inv(itypi)
1577         dsci_inv=vbld_inv(i+nres)
1578 C
1579 C Calculate SC interaction energy.
1580 C
1581         do iint=1,nint_gr(i)
1582           do j=istart(i,iint),iend(i,iint)
1583             ind=ind+1
1584             itypj=iabs(itype(j))
1585             if (itypj.eq.ntyp1) cycle
1586 c            dscj_inv=dsc_inv(itypj)
1587             dscj_inv=vbld_inv(j+nres)
1588             sig0ij=sigma(itypi,itypj)
1589             r0ij=r0(itypi,itypj)
1590             chi1=chi(itypi,itypj)
1591             chi2=chi(itypj,itypi)
1592             chi12=chi1*chi2
1593             chip1=chip(itypi)
1594             chip2=chip(itypj)
1595             chip12=chip1*chip2
1596             alf1=alp(itypi)
1597             alf2=alp(itypj)
1598             alf12=0.5D0*(alf1+alf2)
1599 C For diagnostics only!!!
1600 c           chi1=0.0D0
1601 c           chi2=0.0D0
1602 c           chi12=0.0D0
1603 c           chip1=0.0D0
1604 c           chip2=0.0D0
1605 c           chip12=0.0D0
1606 c           alf1=0.0D0
1607 c           alf2=0.0D0
1608 c           alf12=0.0D0
1609             xj=c(1,nres+j)-xi
1610             yj=c(2,nres+j)-yi
1611             zj=c(3,nres+j)-zi
1612             dxj=dc_norm(1,nres+j)
1613             dyj=dc_norm(2,nres+j)
1614             dzj=dc_norm(3,nres+j)
1615             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1616             rij=dsqrt(rrij)
1617 C Calculate angle-dependent terms of energy and contributions to their
1618 C derivatives.
1619             call sc_angular
1620             sigsq=1.0D0/sigsq
1621             sig=sig0ij*dsqrt(sigsq)
1622             rij_shift=1.0D0/rij-sig+r0ij
1623 C I hate to put IF's in the loops, but here don't have another choice!!!!
1624             if (rij_shift.le.0.0D0) then
1625               evdw=1.0D20
1626               return
1627             endif
1628             sigder=-sig*sigsq
1629 c---------------------------------------------------------------
1630             rij_shift=1.0D0/rij_shift
1631             fac=rij_shift**expon
1632             e1=fac*fac*aa(itypi,itypj)
1633             e2=fac*bb(itypi,itypj)
1634             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1635             eps2der=evdwij*eps3rt
1636             eps3der=evdwij*eps2rt
1637             fac_augm=rrij**expon
1638             e_augm=augm(itypi,itypj)*fac_augm
1639             evdwij=evdwij*eps2rt*eps3rt
1640             evdw=evdw+evdwij+e_augm
1641             if (lprn) then
1642             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1643             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1644             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1645      &        restyp(itypi),i,restyp(itypj),j,
1646      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1647      &        chi1,chi2,chip1,chip2,
1648      &        eps1,eps2rt**2,eps3rt**2,
1649      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1650      &        evdwij+e_augm
1651             endif
1652 C Calculate gradient components.
1653             e1=e1*eps1*eps2rt**2*eps3rt**2
1654             fac=-expon*(e1+evdwij)*rij_shift
1655             sigder=fac*sigder
1656             fac=rij*fac-2*expon*rrij*e_augm
1657 C Calculate the radial part of the gradient
1658             gg(1)=xj*fac
1659             gg(2)=yj*fac
1660             gg(3)=zj*fac
1661 C Calculate angular part of the gradient.
1662             call sc_grad
1663           enddo      ! j
1664         enddo        ! iint
1665       enddo          ! i
1666       end
1667 C-----------------------------------------------------------------------------
1668       subroutine sc_angular
1669 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1670 C om12. Called by ebp, egb, and egbv.
1671       implicit none
1672       include 'COMMON.CALC'
1673       include 'COMMON.IOUNITS'
1674       erij(1)=xj*rij
1675       erij(2)=yj*rij
1676       erij(3)=zj*rij
1677       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1678       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1679       om12=dxi*dxj+dyi*dyj+dzi*dzj
1680       chiom12=chi12*om12
1681 C Calculate eps1(om12) and its derivative in om12
1682       faceps1=1.0D0-om12*chiom12
1683       faceps1_inv=1.0D0/faceps1
1684       eps1=dsqrt(faceps1_inv)
1685 C Following variable is eps1*deps1/dom12
1686       eps1_om12=faceps1_inv*chiom12
1687 c diagnostics only
1688 c      faceps1_inv=om12
1689 c      eps1=om12
1690 c      eps1_om12=1.0d0
1691 c      write (iout,*) "om12",om12," eps1",eps1
1692 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1693 C and om12.
1694       om1om2=om1*om2
1695       chiom1=chi1*om1
1696       chiom2=chi2*om2
1697       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1698       sigsq=1.0D0-facsig*faceps1_inv
1699       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1700       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1701       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1702 c diagnostics only
1703 c      sigsq=1.0d0
1704 c      sigsq_om1=0.0d0
1705 c      sigsq_om2=0.0d0
1706 c      sigsq_om12=0.0d0
1707 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1708 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1709 c     &    " eps1",eps1
1710 C Calculate eps2 and its derivatives in om1, om2, and om12.
1711       chipom1=chip1*om1
1712       chipom2=chip2*om2
1713       chipom12=chip12*om12
1714       facp=1.0D0-om12*chipom12
1715       facp_inv=1.0D0/facp
1716       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1717 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1718 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1719 C Following variable is the square root of eps2
1720       eps2rt=1.0D0-facp1*facp_inv
1721 C Following three variables are the derivatives of the square root of eps
1722 C in om1, om2, and om12.
1723       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1724       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1725       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1726 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1727       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1728 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1729 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1730 c     &  " eps2rt_om12",eps2rt_om12
1731 C Calculate whole angle-dependent part of epsilon and contributions
1732 C to its derivatives
1733       return
1734       end
1735 C----------------------------------------------------------------------------
1736       subroutine sc_grad
1737       implicit real*8 (a-h,o-z)
1738       include 'DIMENSIONS'
1739       include 'COMMON.CHAIN'
1740       include 'COMMON.DERIV'
1741       include 'COMMON.CALC'
1742       include 'COMMON.IOUNITS'
1743       double precision dcosom1(3),dcosom2(3)
1744       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1745       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1746       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1747      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1748 c diagnostics only
1749 c      eom1=0.0d0
1750 c      eom2=0.0d0
1751 c      eom12=evdwij*eps1_om12
1752 c end diagnostics
1753 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1754 c     &  " sigder",sigder
1755 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1756 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1757       do k=1,3
1758         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1759         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1760       enddo
1761       do k=1,3
1762         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1763       enddo
1764 c      write (iout,*) "gg",(gg(k),k=1,3)
1765       do k=1,3
1766         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1767      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1768      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1769         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1770      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1771      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1772 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1773 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1774 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1775 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1776       enddo
1777 C
1778 C Calculate the components of the gradient in DC and X
1779 C
1780 cgrad      do k=i,j-1
1781 cgrad        do l=1,3
1782 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1783 cgrad        enddo
1784 cgrad      enddo
1785       do l=1,3
1786         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1787         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1788       enddo
1789       return
1790       end
1791 C-----------------------------------------------------------------------
1792       subroutine e_softsphere(evdw)
1793 C
1794 C This subroutine calculates the interaction energy of nonbonded side chains
1795 C assuming the LJ potential of interaction.
1796 C
1797       implicit real*8 (a-h,o-z)
1798       include 'DIMENSIONS'
1799       parameter (accur=1.0d-10)
1800       include 'COMMON.GEO'
1801       include 'COMMON.VAR'
1802       include 'COMMON.LOCAL'
1803       include 'COMMON.CHAIN'
1804       include 'COMMON.DERIV'
1805       include 'COMMON.INTERACT'
1806       include 'COMMON.TORSION'
1807       include 'COMMON.SBRIDGE'
1808       include 'COMMON.NAMES'
1809       include 'COMMON.IOUNITS'
1810       include 'COMMON.CONTACTS'
1811       dimension gg(3)
1812 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1813       evdw=0.0D0
1814       do i=iatsc_s,iatsc_e
1815         itypi=iabs(itype(i))
1816         if (itypi.eq.ntyp1) cycle
1817         itypi1=iabs(itype(i+1))
1818         xi=c(1,nres+i)
1819         yi=c(2,nres+i)
1820         zi=c(3,nres+i)
1821 C
1822 C Calculate SC interaction energy.
1823 C
1824         do iint=1,nint_gr(i)
1825 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1826 cd   &                  'iend=',iend(i,iint)
1827           do j=istart(i,iint),iend(i,iint)
1828             itypj=iabs(itype(j))
1829             if (itypj.eq.ntyp1) cycle
1830             xj=c(1,nres+j)-xi
1831             yj=c(2,nres+j)-yi
1832             zj=c(3,nres+j)-zi
1833             rij=xj*xj+yj*yj+zj*zj
1834 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1835             r0ij=r0(itypi,itypj)
1836             r0ijsq=r0ij*r0ij
1837 c            print *,i,j,r0ij,dsqrt(rij)
1838             if (rij.lt.r0ijsq) then
1839               evdwij=0.25d0*(rij-r0ijsq)**2
1840               fac=rij-r0ijsq
1841             else
1842               evdwij=0.0d0
1843               fac=0.0d0
1844             endif
1845             evdw=evdw+evdwij
1846 C
1847 C Calculate the components of the gradient in DC and X
1848 C
1849             gg(1)=xj*fac
1850             gg(2)=yj*fac
1851             gg(3)=zj*fac
1852             do k=1,3
1853               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1854               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1855               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1856               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1857             enddo
1858 cgrad            do k=i,j-1
1859 cgrad              do l=1,3
1860 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1861 cgrad              enddo
1862 cgrad            enddo
1863           enddo ! j
1864         enddo ! iint
1865       enddo ! i
1866       return
1867       end
1868 C--------------------------------------------------------------------------
1869       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1870      &              eello_turn4)
1871 C
1872 C Soft-sphere potential of p-p interaction
1873 C
1874       implicit real*8 (a-h,o-z)
1875       include 'DIMENSIONS'
1876       include 'COMMON.CONTROL'
1877       include 'COMMON.IOUNITS'
1878       include 'COMMON.GEO'
1879       include 'COMMON.VAR'
1880       include 'COMMON.LOCAL'
1881       include 'COMMON.CHAIN'
1882       include 'COMMON.DERIV'
1883       include 'COMMON.INTERACT'
1884       include 'COMMON.CONTACTS'
1885       include 'COMMON.TORSION'
1886       include 'COMMON.VECTORS'
1887       include 'COMMON.FFIELD'
1888       dimension ggg(3)
1889 cd      write(iout,*) 'In EELEC_soft_sphere'
1890       ees=0.0D0
1891       evdw1=0.0D0
1892       eel_loc=0.0d0
1893       eello_turn3=0.0d0
1894       eello_turn4=0.0d0
1895       ind=0
1896       do i=iatel_s,iatel_e
1897         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1898         dxi=dc(1,i)
1899         dyi=dc(2,i)
1900         dzi=dc(3,i)
1901         xmedi=c(1,i)+0.5d0*dxi
1902         ymedi=c(2,i)+0.5d0*dyi
1903         zmedi=c(3,i)+0.5d0*dzi
1904         num_conti=0
1905 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1906         do j=ielstart(i),ielend(i)
1907           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1908           ind=ind+1
1909           iteli=itel(i)
1910           itelj=itel(j)
1911           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1912           r0ij=rpp(iteli,itelj)
1913           r0ijsq=r0ij*r0ij
1914           dxj=dc(1,j)
1915           dyj=dc(2,j)
1916           dzj=dc(3,j)
1917           xj=c(1,j)+0.5D0*dxj-xmedi
1918           yj=c(2,j)+0.5D0*dyj-ymedi
1919           zj=c(3,j)+0.5D0*dzj-zmedi
1920           rij=xj*xj+yj*yj+zj*zj
1921           if (rij.lt.r0ijsq) then
1922             evdw1ij=0.25d0*(rij-r0ijsq)**2
1923             fac=rij-r0ijsq
1924           else
1925             evdw1ij=0.0d0
1926             fac=0.0d0
1927           endif
1928           evdw1=evdw1+evdw1ij
1929 C
1930 C Calculate contributions to the Cartesian gradient.
1931 C
1932           ggg(1)=fac*xj
1933           ggg(2)=fac*yj
1934           ggg(3)=fac*zj
1935           do k=1,3
1936             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1937             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1938           enddo
1939 *
1940 * Loop over residues i+1 thru j-1.
1941 *
1942 cgrad          do k=i+1,j-1
1943 cgrad            do l=1,3
1944 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1945 cgrad            enddo
1946 cgrad          enddo
1947         enddo ! j
1948       enddo   ! i
1949 cgrad      do i=nnt,nct-1
1950 cgrad        do k=1,3
1951 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1952 cgrad        enddo
1953 cgrad        do j=i+1,nct-1
1954 cgrad          do k=1,3
1955 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1956 cgrad          enddo
1957 cgrad        enddo
1958 cgrad      enddo
1959       return
1960       end
1961 c------------------------------------------------------------------------------
1962       subroutine vec_and_deriv
1963       implicit real*8 (a-h,o-z)
1964       include 'DIMENSIONS'
1965 #ifdef MPI
1966       include 'mpif.h'
1967 #endif
1968       include 'COMMON.IOUNITS'
1969       include 'COMMON.GEO'
1970       include 'COMMON.VAR'
1971       include 'COMMON.LOCAL'
1972       include 'COMMON.CHAIN'
1973       include 'COMMON.VECTORS'
1974       include 'COMMON.SETUP'
1975       include 'COMMON.TIME1'
1976       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1977 C Compute the local reference systems. For reference system (i), the
1978 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1979 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1980 #ifdef PARVEC
1981       do i=ivec_start,ivec_end
1982 #else
1983       do i=1,nres-1
1984 #endif
1985           if (i.eq.nres-1) then
1986 C Case of the last full residue
1987 C Compute the Z-axis
1988             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1989             costh=dcos(pi-theta(nres))
1990             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1991             do k=1,3
1992               uz(k,i)=fac*uz(k,i)
1993             enddo
1994 C Compute the derivatives of uz
1995             uzder(1,1,1)= 0.0d0
1996             uzder(2,1,1)=-dc_norm(3,i-1)
1997             uzder(3,1,1)= dc_norm(2,i-1)
1998             uzder(1,2,1)= dc_norm(3,i-1)
1999             uzder(2,2,1)= 0.0d0
2000             uzder(3,2,1)=-dc_norm(1,i-1)
2001             uzder(1,3,1)=-dc_norm(2,i-1)
2002             uzder(2,3,1)= dc_norm(1,i-1)
2003             uzder(3,3,1)= 0.0d0
2004             uzder(1,1,2)= 0.0d0
2005             uzder(2,1,2)= dc_norm(3,i)
2006             uzder(3,1,2)=-dc_norm(2,i)
2007             uzder(1,2,2)=-dc_norm(3,i)
2008             uzder(2,2,2)= 0.0d0
2009             uzder(3,2,2)= dc_norm(1,i)
2010             uzder(1,3,2)= dc_norm(2,i)
2011             uzder(2,3,2)=-dc_norm(1,i)
2012             uzder(3,3,2)= 0.0d0
2013 C Compute the Y-axis
2014             facy=fac
2015             do k=1,3
2016               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2017             enddo
2018 C Compute the derivatives of uy
2019             do j=1,3
2020               do k=1,3
2021                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2022      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2023                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2024               enddo
2025               uyder(j,j,1)=uyder(j,j,1)-costh
2026               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2027             enddo
2028             do j=1,2
2029               do k=1,3
2030                 do l=1,3
2031                   uygrad(l,k,j,i)=uyder(l,k,j)
2032                   uzgrad(l,k,j,i)=uzder(l,k,j)
2033                 enddo
2034               enddo
2035             enddo
2036             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2037             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2038             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2039             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2040           else
2041 C Other residues
2042 C Compute the Z-axis
2043             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2044             costh=dcos(pi-theta(i+2))
2045             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2046             do k=1,3
2047               uz(k,i)=fac*uz(k,i)
2048             enddo
2049 C Compute the derivatives of uz
2050             uzder(1,1,1)= 0.0d0
2051             uzder(2,1,1)=-dc_norm(3,i+1)
2052             uzder(3,1,1)= dc_norm(2,i+1)
2053             uzder(1,2,1)= dc_norm(3,i+1)
2054             uzder(2,2,1)= 0.0d0
2055             uzder(3,2,1)=-dc_norm(1,i+1)
2056             uzder(1,3,1)=-dc_norm(2,i+1)
2057             uzder(2,3,1)= dc_norm(1,i+1)
2058             uzder(3,3,1)= 0.0d0
2059             uzder(1,1,2)= 0.0d0
2060             uzder(2,1,2)= dc_norm(3,i)
2061             uzder(3,1,2)=-dc_norm(2,i)
2062             uzder(1,2,2)=-dc_norm(3,i)
2063             uzder(2,2,2)= 0.0d0
2064             uzder(3,2,2)= dc_norm(1,i)
2065             uzder(1,3,2)= dc_norm(2,i)
2066             uzder(2,3,2)=-dc_norm(1,i)
2067             uzder(3,3,2)= 0.0d0
2068 C Compute the Y-axis
2069             facy=fac
2070             do k=1,3
2071               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2072             enddo
2073 C Compute the derivatives of uy
2074             do j=1,3
2075               do k=1,3
2076                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2077      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2078                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2079               enddo
2080               uyder(j,j,1)=uyder(j,j,1)-costh
2081               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2082             enddo
2083             do j=1,2
2084               do k=1,3
2085                 do l=1,3
2086                   uygrad(l,k,j,i)=uyder(l,k,j)
2087                   uzgrad(l,k,j,i)=uzder(l,k,j)
2088                 enddo
2089               enddo
2090             enddo
2091             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2092             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2093             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2094             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2095           endif
2096       enddo
2097       do i=1,nres-1
2098         vbld_inv_temp(1)=vbld_inv(i+1)
2099         if (i.lt.nres-1) then
2100           vbld_inv_temp(2)=vbld_inv(i+2)
2101           else
2102           vbld_inv_temp(2)=vbld_inv(i)
2103           endif
2104         do j=1,2
2105           do k=1,3
2106             do l=1,3
2107               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2108               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2109             enddo
2110           enddo
2111         enddo
2112       enddo
2113 #if defined(PARVEC) && defined(MPI)
2114       if (nfgtasks1.gt.1) then
2115         time00=MPI_Wtime()
2116 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2117 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2118 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2119         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2120      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2121      &   FG_COMM1,IERR)
2122         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2123      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2124      &   FG_COMM1,IERR)
2125         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2126      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2127      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2128         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2129      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2130      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2131         time_gather=time_gather+MPI_Wtime()-time00
2132       endif
2133 c      if (fg_rank.eq.0) then
2134 c        write (iout,*) "Arrays UY and UZ"
2135 c        do i=1,nres-1
2136 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2137 c     &     (uz(k,i),k=1,3)
2138 c        enddo
2139 c      endif
2140 #endif
2141       return
2142       end
2143 C-----------------------------------------------------------------------------
2144       subroutine check_vecgrad
2145       implicit real*8 (a-h,o-z)
2146       include 'DIMENSIONS'
2147       include 'COMMON.IOUNITS'
2148       include 'COMMON.GEO'
2149       include 'COMMON.VAR'
2150       include 'COMMON.LOCAL'
2151       include 'COMMON.CHAIN'
2152       include 'COMMON.VECTORS'
2153       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2154       dimension uyt(3,maxres),uzt(3,maxres)
2155       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2156       double precision delta /1.0d-7/
2157       call vec_and_deriv
2158 cd      do i=1,nres
2159 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2160 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2161 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2162 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2163 cd     &     (dc_norm(if90,i),if90=1,3)
2164 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2165 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2166 cd          write(iout,'(a)')
2167 cd      enddo
2168       do i=1,nres
2169         do j=1,2
2170           do k=1,3
2171             do l=1,3
2172               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2173               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2174             enddo
2175           enddo
2176         enddo
2177       enddo
2178       call vec_and_deriv
2179       do i=1,nres
2180         do j=1,3
2181           uyt(j,i)=uy(j,i)
2182           uzt(j,i)=uz(j,i)
2183         enddo
2184       enddo
2185       do i=1,nres
2186 cd        write (iout,*) 'i=',i
2187         do k=1,3
2188           erij(k)=dc_norm(k,i)
2189         enddo
2190         do j=1,3
2191           do k=1,3
2192             dc_norm(k,i)=erij(k)
2193           enddo
2194           dc_norm(j,i)=dc_norm(j,i)+delta
2195 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2196 c          do k=1,3
2197 c            dc_norm(k,i)=dc_norm(k,i)/fac
2198 c          enddo
2199 c          write (iout,*) (dc_norm(k,i),k=1,3)
2200 c          write (iout,*) (erij(k),k=1,3)
2201           call vec_and_deriv
2202           do k=1,3
2203             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2204             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2205             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2206             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2207           enddo
2208 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2209 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2210 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2211         enddo
2212         do k=1,3
2213           dc_norm(k,i)=erij(k)
2214         enddo
2215 cd        do k=1,3
2216 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2217 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2218 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2219 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2220 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2221 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2222 cd          write (iout,'(a)')
2223 cd        enddo
2224       enddo
2225       return
2226       end
2227 C--------------------------------------------------------------------------
2228       subroutine set_matrices
2229       implicit real*8 (a-h,o-z)
2230       include 'DIMENSIONS'
2231 #ifdef MPI
2232       include "mpif.h"
2233       include "COMMON.SETUP"
2234       integer IERR
2235       integer status(MPI_STATUS_SIZE)
2236 #endif
2237       include 'COMMON.IOUNITS'
2238       include 'COMMON.GEO'
2239       include 'COMMON.VAR'
2240       include 'COMMON.LOCAL'
2241       include 'COMMON.CHAIN'
2242       include 'COMMON.DERIV'
2243       include 'COMMON.INTERACT'
2244       include 'COMMON.CONTACTS'
2245       include 'COMMON.TORSION'
2246       include 'COMMON.VECTORS'
2247       include 'COMMON.FFIELD'
2248       double precision auxvec(2),auxmat(2,2)
2249 C
2250 C Compute the virtual-bond-torsional-angle dependent quantities needed
2251 C to calculate the el-loc multibody terms of various order.
2252 C
2253 #ifdef PARMAT
2254       do i=ivec_start+2,ivec_end+2
2255 #else
2256       do i=3,nres+1
2257 #endif
2258         if (i .lt. nres+1) then
2259           sin1=dsin(phi(i))
2260           cos1=dcos(phi(i))
2261           sintab(i-2)=sin1
2262           costab(i-2)=cos1
2263           obrot(1,i-2)=cos1
2264           obrot(2,i-2)=sin1
2265           sin2=dsin(2*phi(i))
2266           cos2=dcos(2*phi(i))
2267           sintab2(i-2)=sin2
2268           costab2(i-2)=cos2
2269           obrot2(1,i-2)=cos2
2270           obrot2(2,i-2)=sin2
2271           Ug(1,1,i-2)=-cos1
2272           Ug(1,2,i-2)=-sin1
2273           Ug(2,1,i-2)=-sin1
2274           Ug(2,2,i-2)= cos1
2275           Ug2(1,1,i-2)=-cos2
2276           Ug2(1,2,i-2)=-sin2
2277           Ug2(2,1,i-2)=-sin2
2278           Ug2(2,2,i-2)= cos2
2279         else
2280           costab(i-2)=1.0d0
2281           sintab(i-2)=0.0d0
2282           obrot(1,i-2)=1.0d0
2283           obrot(2,i-2)=0.0d0
2284           obrot2(1,i-2)=0.0d0
2285           obrot2(2,i-2)=0.0d0
2286           Ug(1,1,i-2)=1.0d0
2287           Ug(1,2,i-2)=0.0d0
2288           Ug(2,1,i-2)=0.0d0
2289           Ug(2,2,i-2)=1.0d0
2290           Ug2(1,1,i-2)=0.0d0
2291           Ug2(1,2,i-2)=0.0d0
2292           Ug2(2,1,i-2)=0.0d0
2293           Ug2(2,2,i-2)=0.0d0
2294         endif
2295         if (i .gt. 3 .and. i .lt. nres+1) then
2296           obrot_der(1,i-2)=-sin1
2297           obrot_der(2,i-2)= cos1
2298           Ugder(1,1,i-2)= sin1
2299           Ugder(1,2,i-2)=-cos1
2300           Ugder(2,1,i-2)=-cos1
2301           Ugder(2,2,i-2)=-sin1
2302           dwacos2=cos2+cos2
2303           dwasin2=sin2+sin2
2304           obrot2_der(1,i-2)=-dwasin2
2305           obrot2_der(2,i-2)= dwacos2
2306           Ug2der(1,1,i-2)= dwasin2
2307           Ug2der(1,2,i-2)=-dwacos2
2308           Ug2der(2,1,i-2)=-dwacos2
2309           Ug2der(2,2,i-2)=-dwasin2
2310         else
2311           obrot_der(1,i-2)=0.0d0
2312           obrot_der(2,i-2)=0.0d0
2313           Ugder(1,1,i-2)=0.0d0
2314           Ugder(1,2,i-2)=0.0d0
2315           Ugder(2,1,i-2)=0.0d0
2316           Ugder(2,2,i-2)=0.0d0
2317           obrot2_der(1,i-2)=0.0d0
2318           obrot2_der(2,i-2)=0.0d0
2319           Ug2der(1,1,i-2)=0.0d0
2320           Ug2der(1,2,i-2)=0.0d0
2321           Ug2der(2,1,i-2)=0.0d0
2322           Ug2der(2,2,i-2)=0.0d0
2323         endif
2324 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2325         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2326           iti = itortyp(itype(i-2))
2327         else
2328           iti=ntortyp+1
2329         endif
2330 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2331         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2332           iti1 = itortyp(itype(i-1))
2333         else
2334           iti1=ntortyp+1
2335         endif
2336 cd        write (iout,*) '*******i',i,' iti1',iti
2337 cd        write (iout,*) 'b1',b1(:,iti)
2338 cd        write (iout,*) 'b2',b2(:,iti)
2339 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2340 c        if (i .gt. iatel_s+2) then
2341         if (i .gt. nnt+2) then
2342           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2343           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2344           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2345      &    then
2346           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2347           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2348           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2349           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2350           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2351           endif
2352         else
2353           do k=1,2
2354             Ub2(k,i-2)=0.0d0
2355             Ctobr(k,i-2)=0.0d0
2356             Dtobr2(k,i-2)=0.0d0
2357             do l=1,2
2358               EUg(l,k,i-2)=0.0d0
2359               CUg(l,k,i-2)=0.0d0
2360               DUg(l,k,i-2)=0.0d0
2361               DtUg2(l,k,i-2)=0.0d0
2362             enddo
2363           enddo
2364         endif
2365         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2366         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2367         do k=1,2
2368           muder(k,i-2)=Ub2der(k,i-2)
2369         enddo
2370 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2371         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2372           iti1 = itortyp(itype(i-1))
2373         else
2374           iti1=ntortyp+1
2375         endif
2376         do k=1,2
2377           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2378         enddo
2379 cd        write (iout,*) 'mu ',mu(:,i-2)
2380 cd        write (iout,*) 'mu1',mu1(:,i-2)
2381 cd        write (iout,*) 'mu2',mu2(:,i-2)
2382         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2383      &  then
2384         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2385         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2386         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2387         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2388         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2389 C Vectors and matrices dependent on a single virtual-bond dihedral.
2390         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2391         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2392         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2393         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2394         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2395         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2396         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2397         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2398         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2399         endif
2400       enddo
2401 C Matrices dependent on two consecutive virtual-bond dihedrals.
2402 C The order of matrices is from left to right.
2403       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2404      &then
2405 c      do i=max0(ivec_start,2),ivec_end
2406       do i=2,nres-1
2407         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2408         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2409         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2410         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2411         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2412         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2413         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2414         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2415       enddo
2416       endif
2417 #if defined(MPI) && defined(PARMAT)
2418 #ifdef DEBUG
2419 c      if (fg_rank.eq.0) then
2420         write (iout,*) "Arrays UG and UGDER before GATHER"
2421         do i=1,nres-1
2422           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2423      &     ((ug(l,k,i),l=1,2),k=1,2),
2424      &     ((ugder(l,k,i),l=1,2),k=1,2)
2425         enddo
2426         write (iout,*) "Arrays UG2 and UG2DER"
2427         do i=1,nres-1
2428           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2429      &     ((ug2(l,k,i),l=1,2),k=1,2),
2430      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2431         enddo
2432         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2433         do i=1,nres-1
2434           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2435      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2436      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2437         enddo
2438         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2439         do i=1,nres-1
2440           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2441      &     costab(i),sintab(i),costab2(i),sintab2(i)
2442         enddo
2443         write (iout,*) "Array MUDER"
2444         do i=1,nres-1
2445           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2446         enddo
2447 c      endif
2448 #endif
2449       if (nfgtasks.gt.1) then
2450         time00=MPI_Wtime()
2451 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2452 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2453 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2454 #ifdef MATGATHER
2455         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2456      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2457      &   FG_COMM1,IERR)
2458         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2459      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2460      &   FG_COMM1,IERR)
2461         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2462      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2463      &   FG_COMM1,IERR)
2464         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2465      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2466      &   FG_COMM1,IERR)
2467         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2468      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2469      &   FG_COMM1,IERR)
2470         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2471      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2472      &   FG_COMM1,IERR)
2473         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2474      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2475      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2476         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2477      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2478      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2479         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2480      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2481      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2482         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2483      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2484      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2485         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2486      &  then
2487         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2488      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2489      &   FG_COMM1,IERR)
2490         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2491      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2492      &   FG_COMM1,IERR)
2493         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2494      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2495      &   FG_COMM1,IERR)
2496        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2497      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2498      &   FG_COMM1,IERR)
2499         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2500      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2501      &   FG_COMM1,IERR)
2502         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2503      &   ivec_count(fg_rank1),
2504      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2505      &   FG_COMM1,IERR)
2506         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2507      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2508      &   FG_COMM1,IERR)
2509         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2510      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2511      &   FG_COMM1,IERR)
2512         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2513      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2514      &   FG_COMM1,IERR)
2515         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2516      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2517      &   FG_COMM1,IERR)
2518         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2519      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2528      &   ivec_count(fg_rank1),
2529      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2530      &   FG_COMM1,IERR)
2531         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2532      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2533      &   FG_COMM1,IERR)
2534        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2535      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2536      &   FG_COMM1,IERR)
2537         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2538      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2539      &   FG_COMM1,IERR)
2540        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2541      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2542      &   FG_COMM1,IERR)
2543         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2544      &   ivec_count(fg_rank1),
2545      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2548      &   ivec_count(fg_rank1),
2549      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2550      &   FG_COMM1,IERR)
2551         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2552      &   ivec_count(fg_rank1),
2553      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2554      &   MPI_MAT2,FG_COMM1,IERR)
2555         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2556      &   ivec_count(fg_rank1),
2557      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2558      &   MPI_MAT2,FG_COMM1,IERR)
2559         endif
2560 #else
2561 c Passes matrix info through the ring
2562       isend=fg_rank1
2563       irecv=fg_rank1-1
2564       if (irecv.lt.0) irecv=nfgtasks1-1
2565       iprev=irecv
2566       inext=fg_rank1+1
2567       if (inext.ge.nfgtasks1) inext=0
2568       do i=1,nfgtasks1-1
2569 c        write (iout,*) "isend",isend," irecv",irecv
2570 c        call flush(iout)
2571         lensend=lentyp(isend)
2572         lenrecv=lentyp(irecv)
2573 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2574 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2575 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2576 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2577 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2578 c        write (iout,*) "Gather ROTAT1"
2579 c        call flush(iout)
2580 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2581 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2582 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2583 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2584 c        write (iout,*) "Gather ROTAT2"
2585 c        call flush(iout)
2586         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2587      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2588      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2589      &   iprev,4400+irecv,FG_COMM,status,IERR)
2590 c        write (iout,*) "Gather ROTAT_OLD"
2591 c        call flush(iout)
2592         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2593      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2594      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2595      &   iprev,5500+irecv,FG_COMM,status,IERR)
2596 c        write (iout,*) "Gather PRECOMP11"
2597 c        call flush(iout)
2598         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2599      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2600      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2601      &   iprev,6600+irecv,FG_COMM,status,IERR)
2602 c        write (iout,*) "Gather PRECOMP12"
2603 c        call flush(iout)
2604         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2605      &  then
2606         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2607      &   MPI_ROTAT2(lensend),inext,7700+isend,
2608      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2609      &   iprev,7700+irecv,FG_COMM,status,IERR)
2610 c        write (iout,*) "Gather PRECOMP21"
2611 c        call flush(iout)
2612         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2613      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2614      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2615      &   iprev,8800+irecv,FG_COMM,status,IERR)
2616 c        write (iout,*) "Gather PRECOMP22"
2617 c        call flush(iout)
2618         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2619      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2620      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2621      &   MPI_PRECOMP23(lenrecv),
2622      &   iprev,9900+irecv,FG_COMM,status,IERR)
2623 c        write (iout,*) "Gather PRECOMP23"
2624 c        call flush(iout)
2625         endif
2626         isend=irecv
2627         irecv=irecv-1
2628         if (irecv.lt.0) irecv=nfgtasks1-1
2629       enddo
2630 #endif
2631         time_gather=time_gather+MPI_Wtime()-time00
2632       endif
2633 #ifdef DEBUG
2634 c      if (fg_rank.eq.0) then
2635         write (iout,*) "Arrays UG and UGDER"
2636         do i=1,nres-1
2637           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2638      &     ((ug(l,k,i),l=1,2),k=1,2),
2639      &     ((ugder(l,k,i),l=1,2),k=1,2)
2640         enddo
2641         write (iout,*) "Arrays UG2 and UG2DER"
2642         do i=1,nres-1
2643           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2644      &     ((ug2(l,k,i),l=1,2),k=1,2),
2645      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2646         enddo
2647         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2648         do i=1,nres-1
2649           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2650      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2651      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2652         enddo
2653         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2654         do i=1,nres-1
2655           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2656      &     costab(i),sintab(i),costab2(i),sintab2(i)
2657         enddo
2658         write (iout,*) "Array MUDER"
2659         do i=1,nres-1
2660           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2661         enddo
2662 c      endif
2663 #endif
2664 #endif
2665 cd      do i=1,nres
2666 cd        iti = itortyp(itype(i))
2667 cd        write (iout,*) i
2668 cd        do j=1,2
2669 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2670 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2671 cd        enddo
2672 cd      enddo
2673       return
2674       end
2675 C--------------------------------------------------------------------------
2676       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2677 C
2678 C This subroutine calculates the average interaction energy and its gradient
2679 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2680 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2681 C The potential depends both on the distance of peptide-group centers and on
2682 C the orientation of the CA-CA virtual bonds.
2683 C
2684       implicit real*8 (a-h,o-z)
2685 #ifdef MPI
2686       include 'mpif.h'
2687 #endif
2688       include 'DIMENSIONS'
2689       include 'COMMON.CONTROL'
2690       include 'COMMON.SETUP'
2691       include 'COMMON.IOUNITS'
2692       include 'COMMON.GEO'
2693       include 'COMMON.VAR'
2694       include 'COMMON.LOCAL'
2695       include 'COMMON.CHAIN'
2696       include 'COMMON.DERIV'
2697       include 'COMMON.INTERACT'
2698       include 'COMMON.CONTACTS'
2699       include 'COMMON.TORSION'
2700       include 'COMMON.VECTORS'
2701       include 'COMMON.FFIELD'
2702       include 'COMMON.TIME1'
2703       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2704      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2705       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2706      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2707       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2708      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2709      &    num_conti,j1,j2
2710 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2711 #ifdef MOMENT
2712       double precision scal_el /1.0d0/
2713 #else
2714       double precision scal_el /0.5d0/
2715 #endif
2716 C 12/13/98
2717 C 13-go grudnia roku pamietnego...
2718       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2719      &                   0.0d0,1.0d0,0.0d0,
2720      &                   0.0d0,0.0d0,1.0d0/
2721 cd      write(iout,*) 'In EELEC'
2722 cd      do i=1,nloctyp
2723 cd        write(iout,*) 'Type',i
2724 cd        write(iout,*) 'B1',B1(:,i)
2725 cd        write(iout,*) 'B2',B2(:,i)
2726 cd        write(iout,*) 'CC',CC(:,:,i)
2727 cd        write(iout,*) 'DD',DD(:,:,i)
2728 cd        write(iout,*) 'EE',EE(:,:,i)
2729 cd      enddo
2730 cd      call check_vecgrad
2731 cd      stop
2732       if (icheckgrad.eq.1) then
2733         do i=1,nres-1
2734           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2735           do k=1,3
2736             dc_norm(k,i)=dc(k,i)*fac
2737           enddo
2738 c          write (iout,*) 'i',i,' fac',fac
2739         enddo
2740       endif
2741       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2742      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2743      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2744 c        call vec_and_deriv
2745 #ifdef TIMING
2746         time01=MPI_Wtime()
2747 #endif
2748         call set_matrices
2749 #ifdef TIMING
2750         time_mat=time_mat+MPI_Wtime()-time01
2751 #endif
2752       endif
2753 cd      do i=1,nres-1
2754 cd        write (iout,*) 'i=',i
2755 cd        do k=1,3
2756 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2757 cd        enddo
2758 cd        do k=1,3
2759 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2760 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2761 cd        enddo
2762 cd      enddo
2763       t_eelecij=0.0d0
2764       ees=0.0D0
2765       evdw1=0.0D0
2766       eel_loc=0.0d0
2767       eello_turn3=0.0d0
2768       eello_turn4=0.0d0
2769       ind=0
2770       do i=1,nres
2771         num_cont_hb(i)=0
2772       enddo
2773 cd      print '(a)','Enter EELEC'
2774 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2775       do i=1,nres
2776         gel_loc_loc(i)=0.0d0
2777         gcorr_loc(i)=0.0d0
2778       enddo
2779 c
2780 c
2781 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2782 C
2783 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2784 C
2785       do i=iturn3_start,iturn3_end
2786         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2787      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2788         dxi=dc(1,i)
2789         dyi=dc(2,i)
2790         dzi=dc(3,i)
2791         dx_normi=dc_norm(1,i)
2792         dy_normi=dc_norm(2,i)
2793         dz_normi=dc_norm(3,i)
2794         xmedi=c(1,i)+0.5d0*dxi
2795         ymedi=c(2,i)+0.5d0*dyi
2796         zmedi=c(3,i)+0.5d0*dzi
2797         num_conti=0
2798         call eelecij(i,i+2,ees,evdw1,eel_loc)
2799         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2800         num_cont_hb(i)=num_conti
2801       enddo
2802       do i=iturn4_start,iturn4_end
2803         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2804      &    .or. itype(i+3).eq.ntyp1
2805      &    .or. itype(i+4).eq.ntyp1) cycle
2806         dxi=dc(1,i)
2807         dyi=dc(2,i)
2808         dzi=dc(3,i)
2809         dx_normi=dc_norm(1,i)
2810         dy_normi=dc_norm(2,i)
2811         dz_normi=dc_norm(3,i)
2812         xmedi=c(1,i)+0.5d0*dxi
2813         ymedi=c(2,i)+0.5d0*dyi
2814         zmedi=c(3,i)+0.5d0*dzi
2815         num_conti=num_cont_hb(i)
2816         call eelecij(i,i+3,ees,evdw1,eel_loc)
2817         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2818      &   call eturn4(i,eello_turn4)
2819         num_cont_hb(i)=num_conti
2820       enddo   ! i
2821 c
2822 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2823 c
2824       do i=iatel_s,iatel_e
2825         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2826         dxi=dc(1,i)
2827         dyi=dc(2,i)
2828         dzi=dc(3,i)
2829         dx_normi=dc_norm(1,i)
2830         dy_normi=dc_norm(2,i)
2831         dz_normi=dc_norm(3,i)
2832         xmedi=c(1,i)+0.5d0*dxi
2833         ymedi=c(2,i)+0.5d0*dyi
2834         zmedi=c(3,i)+0.5d0*dzi
2835 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2836         num_conti=num_cont_hb(i)
2837         do j=ielstart(i),ielend(i)
2838 c          write (iout,*) i,j,itype(i),itype(j)
2839           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2840           call eelecij(i,j,ees,evdw1,eel_loc)
2841         enddo ! j
2842         num_cont_hb(i)=num_conti
2843       enddo   ! i
2844 c      write (iout,*) "Number of loop steps in EELEC:",ind
2845 cd      do i=1,nres
2846 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2847 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2848 cd      enddo
2849 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2850 ccc      eel_loc=eel_loc+eello_turn3
2851 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2852       return
2853       end
2854 C-------------------------------------------------------------------------------
2855       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2856       implicit real*8 (a-h,o-z)
2857       include 'DIMENSIONS'
2858 #ifdef MPI
2859       include "mpif.h"
2860 #endif
2861       include 'COMMON.CONTROL'
2862       include 'COMMON.IOUNITS'
2863       include 'COMMON.GEO'
2864       include 'COMMON.VAR'
2865       include 'COMMON.LOCAL'
2866       include 'COMMON.CHAIN'
2867       include 'COMMON.DERIV'
2868       include 'COMMON.INTERACT'
2869       include 'COMMON.CONTACTS'
2870       include 'COMMON.TORSION'
2871       include 'COMMON.VECTORS'
2872       include 'COMMON.FFIELD'
2873       include 'COMMON.TIME1'
2874       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2875      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2876       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2877      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2878       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2879      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2880      &    num_conti,j1,j2
2881 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2882 #ifdef MOMENT
2883       double precision scal_el /1.0d0/
2884 #else
2885       double precision scal_el /0.5d0/
2886 #endif
2887 C 12/13/98
2888 C 13-go grudnia roku pamietnego...
2889       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2890      &                   0.0d0,1.0d0,0.0d0,
2891      &                   0.0d0,0.0d0,1.0d0/
2892 c          time00=MPI_Wtime()
2893 cd      write (iout,*) "eelecij",i,j
2894 c          ind=ind+1
2895           iteli=itel(i)
2896           itelj=itel(j)
2897           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2898           aaa=app(iteli,itelj)
2899           bbb=bpp(iteli,itelj)
2900           ael6i=ael6(iteli,itelj)
2901           ael3i=ael3(iteli,itelj)
2902           dxj=dc(1,j)
2903           dyj=dc(2,j)
2904           dzj=dc(3,j)
2905           dx_normj=dc_norm(1,j)
2906           dy_normj=dc_norm(2,j)
2907           dz_normj=dc_norm(3,j)
2908           xj=c(1,j)+0.5D0*dxj-xmedi
2909           yj=c(2,j)+0.5D0*dyj-ymedi
2910           zj=c(3,j)+0.5D0*dzj-zmedi
2911           rij=xj*xj+yj*yj+zj*zj
2912           rrmij=1.0D0/rij
2913           rij=dsqrt(rij)
2914           rmij=1.0D0/rij
2915           r3ij=rrmij*rmij
2916           r6ij=r3ij*r3ij
2917           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2918           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2919           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2920           fac=cosa-3.0D0*cosb*cosg
2921           ev1=aaa*r6ij*r6ij
2922 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2923           if (j.eq.i+2) ev1=scal_el*ev1
2924           ev2=bbb*r6ij
2925           fac3=ael6i*r6ij
2926           fac4=ael3i*r3ij
2927           evdwij=ev1+ev2
2928           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2929           el2=fac4*fac
2930           eesij=el1+el2
2931 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2932           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2933           ees=ees+eesij
2934           evdw1=evdw1+evdwij
2935 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2936 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2937 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2938 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2939
2940           if (energy_dec) then
2941               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2942      &'evdw1',i,j,evdwij
2943      &,iteli,itelj,aaa,evdw1
2944               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2945           endif
2946
2947 C
2948 C Calculate contributions to the Cartesian gradient.
2949 C
2950 #ifdef SPLITELE
2951           facvdw=-6*rrmij*(ev1+evdwij)
2952           facel=-3*rrmij*(el1+eesij)
2953           fac1=fac
2954           erij(1)=xj*rmij
2955           erij(2)=yj*rmij
2956           erij(3)=zj*rmij
2957 *
2958 * Radial derivatives. First process both termini of the fragment (i,j)
2959 *
2960           ggg(1)=facel*xj
2961           ggg(2)=facel*yj
2962           ggg(3)=facel*zj
2963 c          do k=1,3
2964 c            ghalf=0.5D0*ggg(k)
2965 c            gelc(k,i)=gelc(k,i)+ghalf
2966 c            gelc(k,j)=gelc(k,j)+ghalf
2967 c          enddo
2968 c 9/28/08 AL Gradient compotents will be summed only at the end
2969           do k=1,3
2970             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2971             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2972           enddo
2973 *
2974 * Loop over residues i+1 thru j-1.
2975 *
2976 cgrad          do k=i+1,j-1
2977 cgrad            do l=1,3
2978 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2979 cgrad            enddo
2980 cgrad          enddo
2981           ggg(1)=facvdw*xj
2982           ggg(2)=facvdw*yj
2983           ggg(3)=facvdw*zj
2984 c          do k=1,3
2985 c            ghalf=0.5D0*ggg(k)
2986 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2987 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2988 c          enddo
2989 c 9/28/08 AL Gradient compotents will be summed only at the end
2990           do k=1,3
2991             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2992             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2993           enddo
2994 *
2995 * Loop over residues i+1 thru j-1.
2996 *
2997 cgrad          do k=i+1,j-1
2998 cgrad            do l=1,3
2999 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3000 cgrad            enddo
3001 cgrad          enddo
3002 #else
3003           facvdw=ev1+evdwij
3004           facel=el1+eesij
3005           fac1=fac
3006           fac=-3*rrmij*(facvdw+facvdw+facel)
3007           erij(1)=xj*rmij
3008           erij(2)=yj*rmij
3009           erij(3)=zj*rmij
3010 *
3011 * Radial derivatives. First process both termini of the fragment (i,j)
3012 *
3013           ggg(1)=fac*xj
3014           ggg(2)=fac*yj
3015           ggg(3)=fac*zj
3016 c          do k=1,3
3017 c            ghalf=0.5D0*ggg(k)
3018 c            gelc(k,i)=gelc(k,i)+ghalf
3019 c            gelc(k,j)=gelc(k,j)+ghalf
3020 c          enddo
3021 c 9/28/08 AL Gradient compotents will be summed only at the end
3022           do k=1,3
3023             gelc_long(k,j)=gelc(k,j)+ggg(k)
3024             gelc_long(k,i)=gelc(k,i)-ggg(k)
3025           enddo
3026 *
3027 * Loop over residues i+1 thru j-1.
3028 *
3029 cgrad          do k=i+1,j-1
3030 cgrad            do l=1,3
3031 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3032 cgrad            enddo
3033 cgrad          enddo
3034 c 9/28/08 AL Gradient compotents will be summed only at the end
3035           ggg(1)=facvdw*xj
3036           ggg(2)=facvdw*yj
3037           ggg(3)=facvdw*zj
3038           do k=1,3
3039             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3040             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3041           enddo
3042 #endif
3043 *
3044 * Angular part
3045 *
3046           ecosa=2.0D0*fac3*fac1+fac4
3047           fac4=-3.0D0*fac4
3048           fac3=-6.0D0*fac3
3049           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3050           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3051           do k=1,3
3052             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3053             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3054           enddo
3055 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3056 cd   &          (dcosg(k),k=1,3)
3057           do k=1,3
3058             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3059           enddo
3060 c          do k=1,3
3061 c            ghalf=0.5D0*ggg(k)
3062 c            gelc(k,i)=gelc(k,i)+ghalf
3063 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3064 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3065 c            gelc(k,j)=gelc(k,j)+ghalf
3066 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3067 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3068 c          enddo
3069 cgrad          do k=i+1,j-1
3070 cgrad            do l=1,3
3071 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3072 cgrad            enddo
3073 cgrad          enddo
3074           do k=1,3
3075             gelc(k,i)=gelc(k,i)
3076      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3077      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3078             gelc(k,j)=gelc(k,j)
3079      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3080      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3081             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3082             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3083           enddo
3084           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3085      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3086      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3087 C
3088 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3089 C   energy of a peptide unit is assumed in the form of a second-order
3090 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3091 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3092 C   are computed for EVERY pair of non-contiguous peptide groups.
3093 C
3094           if (j.lt.nres-1) then
3095             j1=j+1
3096             j2=j-1
3097           else
3098             j1=j-1
3099             j2=j-2
3100           endif
3101           kkk=0
3102           do k=1,2
3103             do l=1,2
3104               kkk=kkk+1
3105               muij(kkk)=mu(k,i)*mu(l,j)
3106             enddo
3107           enddo
3108 cd         write (iout,*) 'EELEC: i',i,' j',j
3109 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3110 cd          write(iout,*) 'muij',muij
3111           ury=scalar(uy(1,i),erij)
3112           urz=scalar(uz(1,i),erij)
3113           vry=scalar(uy(1,j),erij)
3114           vrz=scalar(uz(1,j),erij)
3115           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3116           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3117           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3118           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3119           fac=dsqrt(-ael6i)*r3ij
3120           a22=a22*fac
3121           a23=a23*fac
3122           a32=a32*fac
3123           a33=a33*fac
3124 cd          write (iout,'(4i5,4f10.5)')
3125 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3126 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3127 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3128 cd     &      uy(:,j),uz(:,j)
3129 cd          write (iout,'(4f10.5)')
3130 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3131 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3132 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3133 cd           write (iout,'(9f10.5/)')
3134 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3135 C Derivatives of the elements of A in virtual-bond vectors
3136           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3137           do k=1,3
3138             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3139             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3140             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3141             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3142             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3143             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3144             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3145             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3146             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3147             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3148             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3149             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3150           enddo
3151 C Compute radial contributions to the gradient
3152           facr=-3.0d0*rrmij
3153           a22der=a22*facr
3154           a23der=a23*facr
3155           a32der=a32*facr
3156           a33der=a33*facr
3157           agg(1,1)=a22der*xj
3158           agg(2,1)=a22der*yj
3159           agg(3,1)=a22der*zj
3160           agg(1,2)=a23der*xj
3161           agg(2,2)=a23der*yj
3162           agg(3,2)=a23der*zj
3163           agg(1,3)=a32der*xj
3164           agg(2,3)=a32der*yj
3165           agg(3,3)=a32der*zj
3166           agg(1,4)=a33der*xj
3167           agg(2,4)=a33der*yj
3168           agg(3,4)=a33der*zj
3169 C Add the contributions coming from er
3170           fac3=-3.0d0*fac
3171           do k=1,3
3172             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3173             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3174             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3175             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3176           enddo
3177           do k=1,3
3178 C Derivatives in DC(i)
3179 cgrad            ghalf1=0.5d0*agg(k,1)
3180 cgrad            ghalf2=0.5d0*agg(k,2)
3181 cgrad            ghalf3=0.5d0*agg(k,3)
3182 cgrad            ghalf4=0.5d0*agg(k,4)
3183             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3184      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3185             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3186      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3187             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3188      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3189             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3190      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3191 C Derivatives in DC(i+1)
3192             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3193      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3194             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3195      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3196             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3197      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3198             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3199      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3200 C Derivatives in DC(j)
3201             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3202      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3203             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3204      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3205             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3206      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3207             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3208      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3209 C Derivatives in DC(j+1) or DC(nres-1)
3210             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3211      &      -3.0d0*vryg(k,3)*ury)
3212             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3213      &      -3.0d0*vrzg(k,3)*ury)
3214             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3215      &      -3.0d0*vryg(k,3)*urz)
3216             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3217      &      -3.0d0*vrzg(k,3)*urz)
3218 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3219 cgrad              do l=1,4
3220 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3221 cgrad              enddo
3222 cgrad            endif
3223           enddo
3224           acipa(1,1)=a22
3225           acipa(1,2)=a23
3226           acipa(2,1)=a32
3227           acipa(2,2)=a33
3228           a22=-a22
3229           a23=-a23
3230           do l=1,2
3231             do k=1,3
3232               agg(k,l)=-agg(k,l)
3233               aggi(k,l)=-aggi(k,l)
3234               aggi1(k,l)=-aggi1(k,l)
3235               aggj(k,l)=-aggj(k,l)
3236               aggj1(k,l)=-aggj1(k,l)
3237             enddo
3238           enddo
3239           if (j.lt.nres-1) then
3240             a22=-a22
3241             a32=-a32
3242             do l=1,3,2
3243               do k=1,3
3244                 agg(k,l)=-agg(k,l)
3245                 aggi(k,l)=-aggi(k,l)
3246                 aggi1(k,l)=-aggi1(k,l)
3247                 aggj(k,l)=-aggj(k,l)
3248                 aggj1(k,l)=-aggj1(k,l)
3249               enddo
3250             enddo
3251           else
3252             a22=-a22
3253             a23=-a23
3254             a32=-a32
3255             a33=-a33
3256             do l=1,4
3257               do k=1,3
3258                 agg(k,l)=-agg(k,l)
3259                 aggi(k,l)=-aggi(k,l)
3260                 aggi1(k,l)=-aggi1(k,l)
3261                 aggj(k,l)=-aggj(k,l)
3262                 aggj1(k,l)=-aggj1(k,l)
3263               enddo
3264             enddo
3265           endif
3266           ENDIF ! WCORR
3267           IF (wel_loc.gt.0.0d0) THEN
3268 C Contribution to the local-electrostatic energy coming from the i-j pair
3269           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3270      &     +a33*muij(4)
3271 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3272
3273           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3274      &            'eelloc',i,j,eel_loc_ij
3275
3276           eel_loc=eel_loc+eel_loc_ij
3277 C Partial derivatives in virtual-bond dihedral angles gamma
3278           if (i.gt.1)
3279      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3280      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3281      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3282           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3283      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3284      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3285 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3286           do l=1,3
3287             ggg(l)=agg(l,1)*muij(1)+
3288      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3289             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3290             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3291 cgrad            ghalf=0.5d0*ggg(l)
3292 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3293 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3294           enddo
3295 cgrad          do k=i+1,j2
3296 cgrad            do l=1,3
3297 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3298 cgrad            enddo
3299 cgrad          enddo
3300 C Remaining derivatives of eello
3301           do l=1,3
3302             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3303      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3304             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3305      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3306             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3307      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3308             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3309      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3310           enddo
3311           ENDIF
3312 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3313 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3314           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3315      &       .and. num_conti.le.maxconts) then
3316 c            write (iout,*) i,j," entered corr"
3317 C
3318 C Calculate the contact function. The ith column of the array JCONT will
3319 C contain the numbers of atoms that make contacts with the atom I (of numbers
3320 C greater than I). The arrays FACONT and GACONT will contain the values of
3321 C the contact function and its derivative.
3322 c           r0ij=1.02D0*rpp(iteli,itelj)
3323 c           r0ij=1.11D0*rpp(iteli,itelj)
3324             r0ij=2.20D0*rpp(iteli,itelj)
3325 c           r0ij=1.55D0*rpp(iteli,itelj)
3326             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3327             if (fcont.gt.0.0D0) then
3328               num_conti=num_conti+1
3329               if (num_conti.gt.maxconts) then
3330                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3331      &                         ' will skip next contacts for this conf.'
3332               else
3333                 jcont_hb(num_conti,i)=j
3334 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3335 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3336                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3337      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3338 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3339 C  terms.
3340                 d_cont(num_conti,i)=rij
3341 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3342 C     --- Electrostatic-interaction matrix ---
3343                 a_chuj(1,1,num_conti,i)=a22
3344                 a_chuj(1,2,num_conti,i)=a23
3345                 a_chuj(2,1,num_conti,i)=a32
3346                 a_chuj(2,2,num_conti,i)=a33
3347 C     --- Gradient of rij
3348                 do kkk=1,3
3349                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3350                 enddo
3351                 kkll=0
3352                 do k=1,2
3353                   do l=1,2
3354                     kkll=kkll+1
3355                     do m=1,3
3356                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3357                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3358                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3359                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3360                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3361                     enddo
3362                   enddo
3363                 enddo
3364                 ENDIF
3365                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3366 C Calculate contact energies
3367                 cosa4=4.0D0*cosa
3368                 wij=cosa-3.0D0*cosb*cosg
3369                 cosbg1=cosb+cosg
3370                 cosbg2=cosb-cosg
3371 c               fac3=dsqrt(-ael6i)/r0ij**3
3372                 fac3=dsqrt(-ael6i)*r3ij
3373 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3374                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3375                 if (ees0tmp.gt.0) then
3376                   ees0pij=dsqrt(ees0tmp)
3377                 else
3378                   ees0pij=0
3379                 endif
3380 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3381                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3382                 if (ees0tmp.gt.0) then
3383                   ees0mij=dsqrt(ees0tmp)
3384                 else
3385                   ees0mij=0
3386                 endif
3387 c               ees0mij=0.0D0
3388                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3389                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3390 C Diagnostics. Comment out or remove after debugging!
3391 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3392 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3393 c               ees0m(num_conti,i)=0.0D0
3394 C End diagnostics.
3395 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3396 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3397 C Angular derivatives of the contact function
3398                 ees0pij1=fac3/ees0pij
3399                 ees0mij1=fac3/ees0mij
3400                 fac3p=-3.0D0*fac3*rrmij
3401                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3402                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3403 c               ees0mij1=0.0D0
3404                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3405                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3406                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3407                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3408                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3409                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3410                 ecosap=ecosa1+ecosa2
3411                 ecosbp=ecosb1+ecosb2
3412                 ecosgp=ecosg1+ecosg2
3413                 ecosam=ecosa1-ecosa2
3414                 ecosbm=ecosb1-ecosb2
3415                 ecosgm=ecosg1-ecosg2
3416 C Diagnostics
3417 c               ecosap=ecosa1
3418 c               ecosbp=ecosb1
3419 c               ecosgp=ecosg1
3420 c               ecosam=0.0D0
3421 c               ecosbm=0.0D0
3422 c               ecosgm=0.0D0
3423 C End diagnostics
3424                 facont_hb(num_conti,i)=fcont
3425                 fprimcont=fprimcont/rij
3426 cd              facont_hb(num_conti,i)=1.0D0
3427 C Following line is for diagnostics.
3428 cd              fprimcont=0.0D0
3429                 do k=1,3
3430                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3431                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3432                 enddo
3433                 do k=1,3
3434                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3435                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3436                 enddo
3437                 gggp(1)=gggp(1)+ees0pijp*xj
3438                 gggp(2)=gggp(2)+ees0pijp*yj
3439                 gggp(3)=gggp(3)+ees0pijp*zj
3440                 gggm(1)=gggm(1)+ees0mijp*xj
3441                 gggm(2)=gggm(2)+ees0mijp*yj
3442                 gggm(3)=gggm(3)+ees0mijp*zj
3443 C Derivatives due to the contact function
3444                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3445                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3446                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3447                 do k=1,3
3448 c
3449 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3450 c          following the change of gradient-summation algorithm.
3451 c
3452 cgrad                  ghalfp=0.5D0*gggp(k)
3453 cgrad                  ghalfm=0.5D0*gggm(k)
3454                   gacontp_hb1(k,num_conti,i)=!ghalfp
3455      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3456      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3457                   gacontp_hb2(k,num_conti,i)=!ghalfp
3458      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3459      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3460                   gacontp_hb3(k,num_conti,i)=gggp(k)
3461                   gacontm_hb1(k,num_conti,i)=!ghalfm
3462      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3463      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3464                   gacontm_hb2(k,num_conti,i)=!ghalfm
3465      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3466      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3467                   gacontm_hb3(k,num_conti,i)=gggm(k)
3468                 enddo
3469 C Diagnostics. Comment out or remove after debugging!
3470 cdiag           do k=1,3
3471 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3472 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3473 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3474 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3475 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3476 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3477 cdiag           enddo
3478               ENDIF ! wcorr
3479               endif  ! num_conti.le.maxconts
3480             endif  ! fcont.gt.0
3481           endif    ! j.gt.i+1
3482           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3483             do k=1,4
3484               do l=1,3
3485                 ghalf=0.5d0*agg(l,k)
3486                 aggi(l,k)=aggi(l,k)+ghalf
3487                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3488                 aggj(l,k)=aggj(l,k)+ghalf
3489               enddo
3490             enddo
3491             if (j.eq.nres-1 .and. i.lt.j-2) then
3492               do k=1,4
3493                 do l=1,3
3494                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3495                 enddo
3496               enddo
3497             endif
3498           endif
3499 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3500       return
3501       end
3502 C-----------------------------------------------------------------------------
3503       subroutine eturn3(i,eello_turn3)
3504 C Third- and fourth-order contributions from turns
3505       implicit real*8 (a-h,o-z)
3506       include 'DIMENSIONS'
3507       include 'COMMON.IOUNITS'
3508       include 'COMMON.GEO'
3509       include 'COMMON.VAR'
3510       include 'COMMON.LOCAL'
3511       include 'COMMON.CHAIN'
3512       include 'COMMON.DERIV'
3513       include 'COMMON.INTERACT'
3514       include 'COMMON.CONTACTS'
3515       include 'COMMON.TORSION'
3516       include 'COMMON.VECTORS'
3517       include 'COMMON.FFIELD'
3518       include 'COMMON.CONTROL'
3519       dimension ggg(3)
3520       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3521      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3522      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3523       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3524      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3525       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3526      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3527      &    num_conti,j1,j2
3528       j=i+2
3529 c      write (iout,*) "eturn3",i,j,j1,j2
3530       a_temp(1,1)=a22
3531       a_temp(1,2)=a23
3532       a_temp(2,1)=a32
3533       a_temp(2,2)=a33
3534 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3535 C
3536 C               Third-order contributions
3537 C
3538 C                 (i+2)o----(i+3)
3539 C                      | |
3540 C                      | |
3541 C                 (i+1)o----i
3542 C
3543 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3544 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3545         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3546         call transpose2(auxmat(1,1),auxmat1(1,1))
3547         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3548         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3549         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3550      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3551 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3552 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3553 cd     &    ' eello_turn3_num',4*eello_turn3_num
3554 C Derivatives in gamma(i)
3555         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3556         call transpose2(auxmat2(1,1),auxmat3(1,1))
3557         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3558         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3559 C Derivatives in gamma(i+1)
3560         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3561         call transpose2(auxmat2(1,1),auxmat3(1,1))
3562         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3563         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3564      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3565 C Cartesian derivatives
3566         do l=1,3
3567 c            ghalf1=0.5d0*agg(l,1)
3568 c            ghalf2=0.5d0*agg(l,2)
3569 c            ghalf3=0.5d0*agg(l,3)
3570 c            ghalf4=0.5d0*agg(l,4)
3571           a_temp(1,1)=aggi(l,1)!+ghalf1
3572           a_temp(1,2)=aggi(l,2)!+ghalf2
3573           a_temp(2,1)=aggi(l,3)!+ghalf3
3574           a_temp(2,2)=aggi(l,4)!+ghalf4
3575           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3576           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3577      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3578           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3579           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3580           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3581           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3582           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3583           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3584      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3585           a_temp(1,1)=aggj(l,1)!+ghalf1
3586           a_temp(1,2)=aggj(l,2)!+ghalf2
3587           a_temp(2,1)=aggj(l,3)!+ghalf3
3588           a_temp(2,2)=aggj(l,4)!+ghalf4
3589           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3590           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3591      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3592           a_temp(1,1)=aggj1(l,1)
3593           a_temp(1,2)=aggj1(l,2)
3594           a_temp(2,1)=aggj1(l,3)
3595           a_temp(2,2)=aggj1(l,4)
3596           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3597           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3598      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3599         enddo
3600       return
3601       end
3602 C-------------------------------------------------------------------------------
3603       subroutine eturn4(i,eello_turn4)
3604 C Third- and fourth-order contributions from turns
3605       implicit real*8 (a-h,o-z)
3606       include 'DIMENSIONS'
3607       include 'COMMON.IOUNITS'
3608       include 'COMMON.GEO'
3609       include 'COMMON.VAR'
3610       include 'COMMON.LOCAL'
3611       include 'COMMON.CHAIN'
3612       include 'COMMON.DERIV'
3613       include 'COMMON.INTERACT'
3614       include 'COMMON.CONTACTS'
3615       include 'COMMON.TORSION'
3616       include 'COMMON.VECTORS'
3617       include 'COMMON.FFIELD'
3618       include 'COMMON.CONTROL'
3619       dimension ggg(3)
3620       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3621      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3622      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3623       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3624      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3625       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3626      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3627      &    num_conti,j1,j2
3628       j=i+3
3629 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3630 C
3631 C               Fourth-order contributions
3632 C
3633 C                 (i+3)o----(i+4)
3634 C                     /  |
3635 C               (i+2)o   |
3636 C                     \  |
3637 C                 (i+1)o----i
3638 C
3639 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3640 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3641 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3642         a_temp(1,1)=a22
3643         a_temp(1,2)=a23
3644         a_temp(2,1)=a32
3645         a_temp(2,2)=a33
3646         iti1=itortyp(itype(i+1))
3647         iti2=itortyp(itype(i+2))
3648         iti3=itortyp(itype(i+3))
3649 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3650         call transpose2(EUg(1,1,i+1),e1t(1,1))
3651         call transpose2(Eug(1,1,i+2),e2t(1,1))
3652         call transpose2(Eug(1,1,i+3),e3t(1,1))
3653         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3654         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3655         s1=scalar2(b1(1,iti2),auxvec(1))
3656         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3657         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3658         s2=scalar2(b1(1,iti1),auxvec(1))
3659         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3660         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3661         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3662         eello_turn4=eello_turn4-(s1+s2+s3)
3663         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3664      &      'eturn4',i,j,-(s1+s2+s3)
3665 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3666 cd     &    ' eello_turn4_num',8*eello_turn4_num
3667 C Derivatives in gamma(i)
3668         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3669         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3670         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3671         s1=scalar2(b1(1,iti2),auxvec(1))
3672         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3673         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3674         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3675 C Derivatives in gamma(i+1)
3676         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3677         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3678         s2=scalar2(b1(1,iti1),auxvec(1))
3679         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3680         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3681         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3682         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3683 C Derivatives in gamma(i+2)
3684         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3685         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3686         s1=scalar2(b1(1,iti2),auxvec(1))
3687         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3688         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3689         s2=scalar2(b1(1,iti1),auxvec(1))
3690         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3691         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3692         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3693         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3694 C Cartesian derivatives
3695 C Derivatives of this turn contributions in DC(i+2)
3696         if (j.lt.nres-1) then
3697           do l=1,3
3698             a_temp(1,1)=agg(l,1)
3699             a_temp(1,2)=agg(l,2)
3700             a_temp(2,1)=agg(l,3)
3701             a_temp(2,2)=agg(l,4)
3702             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3703             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3704             s1=scalar2(b1(1,iti2),auxvec(1))
3705             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3706             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3707             s2=scalar2(b1(1,iti1),auxvec(1))
3708             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3709             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3710             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3711             ggg(l)=-(s1+s2+s3)
3712             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3713           enddo
3714         endif
3715 C Remaining derivatives of this turn contribution
3716         do l=1,3
3717           a_temp(1,1)=aggi(l,1)
3718           a_temp(1,2)=aggi(l,2)
3719           a_temp(2,1)=aggi(l,3)
3720           a_temp(2,2)=aggi(l,4)
3721           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3722           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3723           s1=scalar2(b1(1,iti2),auxvec(1))
3724           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3725           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3726           s2=scalar2(b1(1,iti1),auxvec(1))
3727           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3728           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3729           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3730           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3731           a_temp(1,1)=aggi1(l,1)
3732           a_temp(1,2)=aggi1(l,2)
3733           a_temp(2,1)=aggi1(l,3)
3734           a_temp(2,2)=aggi1(l,4)
3735           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3736           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3737           s1=scalar2(b1(1,iti2),auxvec(1))
3738           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3739           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3740           s2=scalar2(b1(1,iti1),auxvec(1))
3741           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3742           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3743           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3744           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3745           a_temp(1,1)=aggj(l,1)
3746           a_temp(1,2)=aggj(l,2)
3747           a_temp(2,1)=aggj(l,3)
3748           a_temp(2,2)=aggj(l,4)
3749           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3750           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3751           s1=scalar2(b1(1,iti2),auxvec(1))
3752           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3753           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3754           s2=scalar2(b1(1,iti1),auxvec(1))
3755           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3756           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3757           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3758           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3759           a_temp(1,1)=aggj1(l,1)
3760           a_temp(1,2)=aggj1(l,2)
3761           a_temp(2,1)=aggj1(l,3)
3762           a_temp(2,2)=aggj1(l,4)
3763           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3764           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3765           s1=scalar2(b1(1,iti2),auxvec(1))
3766           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3767           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3768           s2=scalar2(b1(1,iti1),auxvec(1))
3769           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3770           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3771           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3772 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3773           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3774         enddo
3775       return
3776       end
3777 C-----------------------------------------------------------------------------
3778       subroutine vecpr(u,v,w)
3779       implicit real*8(a-h,o-z)
3780       dimension u(3),v(3),w(3)
3781       w(1)=u(2)*v(3)-u(3)*v(2)
3782       w(2)=-u(1)*v(3)+u(3)*v(1)
3783       w(3)=u(1)*v(2)-u(2)*v(1)
3784       return
3785       end
3786 C-----------------------------------------------------------------------------
3787       subroutine unormderiv(u,ugrad,unorm,ungrad)
3788 C This subroutine computes the derivatives of a normalized vector u, given
3789 C the derivatives computed without normalization conditions, ugrad. Returns
3790 C ungrad.
3791       implicit none
3792       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3793       double precision vec(3)
3794       double precision scalar
3795       integer i,j
3796 c      write (2,*) 'ugrad',ugrad
3797 c      write (2,*) 'u',u
3798       do i=1,3
3799         vec(i)=scalar(ugrad(1,i),u(1))
3800       enddo
3801 c      write (2,*) 'vec',vec
3802       do i=1,3
3803         do j=1,3
3804           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3805         enddo
3806       enddo
3807 c      write (2,*) 'ungrad',ungrad
3808       return
3809       end
3810 C-----------------------------------------------------------------------------
3811       subroutine escp_soft_sphere(evdw2,evdw2_14)
3812 C
3813 C This subroutine calculates the excluded-volume interaction energy between
3814 C peptide-group centers and side chains and its gradient in virtual-bond and
3815 C side-chain vectors.
3816 C
3817       implicit real*8 (a-h,o-z)
3818       include 'DIMENSIONS'
3819       include 'COMMON.GEO'
3820       include 'COMMON.VAR'
3821       include 'COMMON.LOCAL'
3822       include 'COMMON.CHAIN'
3823       include 'COMMON.DERIV'
3824       include 'COMMON.INTERACT'
3825       include 'COMMON.FFIELD'
3826       include 'COMMON.IOUNITS'
3827       include 'COMMON.CONTROL'
3828       dimension ggg(3)
3829       evdw2=0.0D0
3830       evdw2_14=0.0d0
3831       r0_scp=4.5d0
3832 cd    print '(a)','Enter ESCP'
3833 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3834       do i=iatscp_s,iatscp_e
3835         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3836         iteli=itel(i)
3837         xi=0.5D0*(c(1,i)+c(1,i+1))
3838         yi=0.5D0*(c(2,i)+c(2,i+1))
3839         zi=0.5D0*(c(3,i)+c(3,i+1))
3840
3841         do iint=1,nscp_gr(i)
3842
3843         do j=iscpstart(i,iint),iscpend(i,iint)
3844           if (itype(j).eq.ntyp1) cycle
3845           itypj=iabs(itype(j))
3846 C Uncomment following three lines for SC-p interactions
3847 c         xj=c(1,nres+j)-xi
3848 c         yj=c(2,nres+j)-yi
3849 c         zj=c(3,nres+j)-zi
3850 C Uncomment following three lines for Ca-p interactions
3851           xj=c(1,j)-xi
3852           yj=c(2,j)-yi
3853           zj=c(3,j)-zi
3854           rij=xj*xj+yj*yj+zj*zj
3855           r0ij=r0_scp
3856           r0ijsq=r0ij*r0ij
3857           if (rij.lt.r0ijsq) then
3858             evdwij=0.25d0*(rij-r0ijsq)**2
3859             fac=rij-r0ijsq
3860           else
3861             evdwij=0.0d0
3862             fac=0.0d0
3863           endif
3864           evdw2=evdw2+evdwij
3865 C
3866 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3867 C
3868           ggg(1)=xj*fac
3869           ggg(2)=yj*fac
3870           ggg(3)=zj*fac
3871 cgrad          if (j.lt.i) then
3872 cd          write (iout,*) 'j<i'
3873 C Uncomment following three lines for SC-p interactions
3874 c           do k=1,3
3875 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3876 c           enddo
3877 cgrad          else
3878 cd          write (iout,*) 'j>i'
3879 cgrad            do k=1,3
3880 cgrad              ggg(k)=-ggg(k)
3881 C Uncomment following line for SC-p interactions
3882 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3883 cgrad            enddo
3884 cgrad          endif
3885 cgrad          do k=1,3
3886 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3887 cgrad          enddo
3888 cgrad          kstart=min0(i+1,j)
3889 cgrad          kend=max0(i-1,j-1)
3890 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3891 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3892 cgrad          do k=kstart,kend
3893 cgrad            do l=1,3
3894 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3895 cgrad            enddo
3896 cgrad          enddo
3897           do k=1,3
3898             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3899             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3900           enddo
3901         enddo
3902
3903         enddo ! iint
3904       enddo ! i
3905       return
3906       end
3907 C-----------------------------------------------------------------------------
3908       subroutine escp(evdw2,evdw2_14)
3909 C
3910 C This subroutine calculates the excluded-volume interaction energy between
3911 C peptide-group centers and side chains and its gradient in virtual-bond and
3912 C side-chain vectors.
3913 C
3914       implicit real*8 (a-h,o-z)
3915       include 'DIMENSIONS'
3916       include 'COMMON.GEO'
3917       include 'COMMON.VAR'
3918       include 'COMMON.LOCAL'
3919       include 'COMMON.CHAIN'
3920       include 'COMMON.DERIV'
3921       include 'COMMON.INTERACT'
3922       include 'COMMON.FFIELD'
3923       include 'COMMON.IOUNITS'
3924       include 'COMMON.CONTROL'
3925       dimension ggg(3)
3926       evdw2=0.0D0
3927       evdw2_14=0.0d0
3928 cd    print '(a)','Enter ESCP'
3929 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3930       do i=iatscp_s,iatscp_e
3931         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3932         iteli=itel(i)
3933         xi=0.5D0*(c(1,i)+c(1,i+1))
3934         yi=0.5D0*(c(2,i)+c(2,i+1))
3935         zi=0.5D0*(c(3,i)+c(3,i+1))
3936
3937         do iint=1,nscp_gr(i)
3938
3939         do j=iscpstart(i,iint),iscpend(i,iint)
3940           itypj=iabs(itype(j))
3941           if (itypj.eq.ntyp1) cycle
3942 C Uncomment following three lines for SC-p interactions
3943 c         xj=c(1,nres+j)-xi
3944 c         yj=c(2,nres+j)-yi
3945 c         zj=c(3,nres+j)-zi
3946 C Uncomment following three lines for Ca-p interactions
3947           xj=c(1,j)-xi
3948           yj=c(2,j)-yi
3949           zj=c(3,j)-zi
3950           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3951           fac=rrij**expon2
3952           e1=fac*fac*aad(itypj,iteli)
3953           e2=fac*bad(itypj,iteli)
3954           if (iabs(j-i) .le. 2) then
3955             e1=scal14*e1
3956             e2=scal14*e2
3957             evdw2_14=evdw2_14+e1+e2
3958           endif
3959           evdwij=e1+e2
3960           evdw2=evdw2+evdwij
3961           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3962      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3963      &       bad(itypj,iteli)
3964 C
3965 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3966 C
3967           fac=-(evdwij+e1)*rrij
3968           ggg(1)=xj*fac
3969           ggg(2)=yj*fac
3970           ggg(3)=zj*fac
3971 cgrad          if (j.lt.i) then
3972 cd          write (iout,*) 'j<i'
3973 C Uncomment following three lines for SC-p interactions
3974 c           do k=1,3
3975 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3976 c           enddo
3977 cgrad          else
3978 cd          write (iout,*) 'j>i'
3979 cgrad            do k=1,3
3980 cgrad              ggg(k)=-ggg(k)
3981 C Uncomment following line for SC-p interactions
3982 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3983 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3984 cgrad            enddo
3985 cgrad          endif
3986 cgrad          do k=1,3
3987 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3988 cgrad          enddo
3989 cgrad          kstart=min0(i+1,j)
3990 cgrad          kend=max0(i-1,j-1)
3991 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3992 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3993 cgrad          do k=kstart,kend
3994 cgrad            do l=1,3
3995 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3996 cgrad            enddo
3997 cgrad          enddo
3998           do k=1,3
3999             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4000             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4001           enddo
4002         enddo
4003
4004         enddo ! iint
4005       enddo ! i
4006       do i=1,nct
4007         do j=1,3
4008           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4009           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4010           gradx_scp(j,i)=expon*gradx_scp(j,i)
4011         enddo
4012       enddo
4013 C******************************************************************************
4014 C
4015 C                              N O T E !!!
4016 C
4017 C To save time the factor EXPON has been extracted from ALL components
4018 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4019 C use!
4020 C
4021 C******************************************************************************
4022       return
4023       end
4024 C--------------------------------------------------------------------------
4025       subroutine edis(ehpb)
4026 C
4027 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4028 C
4029       implicit real*8 (a-h,o-z)
4030       include 'DIMENSIONS'
4031       include 'COMMON.SBRIDGE'
4032       include 'COMMON.CHAIN'
4033       include 'COMMON.DERIV'
4034       include 'COMMON.VAR'
4035       include 'COMMON.INTERACT'
4036       include 'COMMON.IOUNITS'
4037       dimension ggg(3)
4038       ehpb=0.0D0
4039 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4040 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4041       if (link_end.eq.0) return
4042       do i=link_start,link_end
4043 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4044 C CA-CA distance used in regularization of structure.
4045         ii=ihpb(i)
4046         jj=jhpb(i)
4047 C iii and jjj point to the residues for which the distance is assigned.
4048         if (ii.gt.nres) then
4049           iii=ii-nres
4050           jjj=jj-nres
4051         else
4052           iii=ii
4053           jjj=jj
4054         endif
4055 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4056 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4057 C    distance and angle dependent SS bond potential.
4058         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4059      & iabs(itype(jjj)).eq.1) then
4060           call ssbond_ene(iii,jjj,eij)
4061           ehpb=ehpb+2*eij
4062 cd          write (iout,*) "eij",eij
4063         else
4064 C Calculate the distance between the two points and its difference from the
4065 C target distance.
4066         dd=dist(ii,jj)
4067         rdis=dd-dhpb(i)
4068 C Get the force constant corresponding to this distance.
4069         waga=forcon(i)
4070 C Calculate the contribution to energy.
4071         ehpb=ehpb+waga*rdis*rdis
4072 C
4073 C Evaluate gradient.
4074 C
4075         fac=waga*rdis/dd
4076 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4077 cd   &   ' waga=',waga,' fac=',fac
4078         do j=1,3
4079           ggg(j)=fac*(c(j,jj)-c(j,ii))
4080         enddo
4081 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4082 C If this is a SC-SC distance, we need to calculate the contributions to the
4083 C Cartesian gradient in the SC vectors (ghpbx).
4084         if (iii.lt.ii) then
4085           do j=1,3
4086             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4087             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4088           enddo
4089         endif
4090 cgrad        do j=iii,jjj-1
4091 cgrad          do k=1,3
4092 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4093 cgrad          enddo
4094 cgrad        enddo
4095         do k=1,3
4096           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4097           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4098         enddo
4099         endif
4100       enddo
4101       ehpb=0.5D0*ehpb
4102       return
4103       end
4104 C--------------------------------------------------------------------------
4105       subroutine ssbond_ene(i,j,eij)
4106 C
4107 C Calculate the distance and angle dependent SS-bond potential energy
4108 C using a free-energy function derived based on RHF/6-31G** ab initio
4109 C calculations of diethyl disulfide.
4110 C
4111 C A. Liwo and U. Kozlowska, 11/24/03
4112 C
4113       implicit real*8 (a-h,o-z)
4114       include 'DIMENSIONS'
4115       include 'COMMON.SBRIDGE'
4116       include 'COMMON.CHAIN'
4117       include 'COMMON.DERIV'
4118       include 'COMMON.LOCAL'
4119       include 'COMMON.INTERACT'
4120       include 'COMMON.VAR'
4121       include 'COMMON.IOUNITS'
4122       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4123       itypi=iabs(itype(i))
4124       xi=c(1,nres+i)
4125       yi=c(2,nres+i)
4126       zi=c(3,nres+i)
4127       dxi=dc_norm(1,nres+i)
4128       dyi=dc_norm(2,nres+i)
4129       dzi=dc_norm(3,nres+i)
4130 c      dsci_inv=dsc_inv(itypi)
4131       dsci_inv=vbld_inv(nres+i)
4132       itypj=iabs(itype(j))
4133 c      dscj_inv=dsc_inv(itypj)
4134       dscj_inv=vbld_inv(nres+j)
4135       xj=c(1,nres+j)-xi
4136       yj=c(2,nres+j)-yi
4137       zj=c(3,nres+j)-zi
4138       dxj=dc_norm(1,nres+j)
4139       dyj=dc_norm(2,nres+j)
4140       dzj=dc_norm(3,nres+j)
4141       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4142       rij=dsqrt(rrij)
4143       erij(1)=xj*rij
4144       erij(2)=yj*rij
4145       erij(3)=zj*rij
4146       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4147       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4148       om12=dxi*dxj+dyi*dyj+dzi*dzj
4149       do k=1,3
4150         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4151         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4152       enddo
4153       rij=1.0d0/rij
4154       deltad=rij-d0cm
4155       deltat1=1.0d0-om1
4156       deltat2=1.0d0+om2
4157       deltat12=om2-om1+2.0d0
4158       cosphi=om12-om1*om2
4159       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4160      &  +akct*deltad*deltat12
4161      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4162 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4163 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4164 c     &  " deltat12",deltat12," eij",eij
4165       ed=2*akcm*deltad+akct*deltat12
4166       pom1=akct*deltad
4167       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4168       eom1=-2*akth*deltat1-pom1-om2*pom2
4169       eom2= 2*akth*deltat2+pom1-om1*pom2
4170       eom12=pom2
4171       do k=1,3
4172         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4173         ghpbx(k,i)=ghpbx(k,i)-ggk
4174      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4175      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4176         ghpbx(k,j)=ghpbx(k,j)+ggk
4177      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4178      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4179         ghpbc(k,i)=ghpbc(k,i)-ggk
4180         ghpbc(k,j)=ghpbc(k,j)+ggk
4181       enddo
4182 C
4183 C Calculate the components of the gradient in DC and X
4184 C
4185 cgrad      do k=i,j-1
4186 cgrad        do l=1,3
4187 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4188 cgrad        enddo
4189 cgrad      enddo
4190       return
4191       end
4192 C--------------------------------------------------------------------------
4193       subroutine ebond(estr)
4194 c
4195 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4196 c
4197       implicit real*8 (a-h,o-z)
4198       include 'DIMENSIONS'
4199       include 'COMMON.LOCAL'
4200       include 'COMMON.GEO'
4201       include 'COMMON.INTERACT'
4202       include 'COMMON.DERIV'
4203       include 'COMMON.VAR'
4204       include 'COMMON.CHAIN'
4205       include 'COMMON.IOUNITS'
4206       include 'COMMON.NAMES'
4207       include 'COMMON.FFIELD'
4208       include 'COMMON.CONTROL'
4209       include 'COMMON.SETUP'
4210       double precision u(3),ud(3)
4211       estr=0.0d0
4212       estr1=0.0d0
4213       do i=ibondp_start,ibondp_end
4214         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4215           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4216           do j=1,3
4217           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4218      &      *dc(j,i-1)/vbld(i)
4219           enddo
4220           if (energy_dec) write(iout,*)
4221      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4222         else
4223         diff = vbld(i)-vbldp0
4224         if (energy_dec) write (iout,*)
4225      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4226         estr=estr+diff*diff
4227         do j=1,3
4228           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4229         enddo
4230 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4231         endif
4232       enddo
4233       estr=0.5d0*AKP*estr+estr1
4234 c
4235 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4236 c
4237       do i=ibond_start,ibond_end
4238         iti=iabs(itype(i))
4239         if (iti.ne.10 .and. iti.ne.ntyp1) then
4240           nbi=nbondterm(iti)
4241           if (nbi.eq.1) then
4242             diff=vbld(i+nres)-vbldsc0(1,iti)
4243             if (energy_dec) write (iout,*)
4244      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4245      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4246             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4247             do j=1,3
4248               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4249             enddo
4250           else
4251             do j=1,nbi
4252               diff=vbld(i+nres)-vbldsc0(j,iti)
4253               ud(j)=aksc(j,iti)*diff
4254               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4255             enddo
4256             uprod=u(1)
4257             do j=2,nbi
4258               uprod=uprod*u(j)
4259             enddo
4260             usum=0.0d0
4261             usumsqder=0.0d0
4262             do j=1,nbi
4263               uprod1=1.0d0
4264               uprod2=1.0d0
4265               do k=1,nbi
4266                 if (k.ne.j) then
4267                   uprod1=uprod1*u(k)
4268                   uprod2=uprod2*u(k)*u(k)
4269                 endif
4270               enddo
4271               usum=usum+uprod1
4272               usumsqder=usumsqder+ud(j)*uprod2
4273             enddo
4274             estr=estr+uprod/usum
4275             do j=1,3
4276              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4277             enddo
4278           endif
4279         endif
4280       enddo
4281       return
4282       end
4283 #ifdef CRYST_THETA
4284 C--------------------------------------------------------------------------
4285       subroutine ebend(etheta)
4286 C
4287 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4288 C angles gamma and its derivatives in consecutive thetas and gammas.
4289 C
4290       implicit real*8 (a-h,o-z)
4291       include 'DIMENSIONS'
4292       include 'COMMON.LOCAL'
4293       include 'COMMON.GEO'
4294       include 'COMMON.INTERACT'
4295       include 'COMMON.DERIV'
4296       include 'COMMON.VAR'
4297       include 'COMMON.CHAIN'
4298       include 'COMMON.IOUNITS'
4299       include 'COMMON.NAMES'
4300       include 'COMMON.FFIELD'
4301       include 'COMMON.CONTROL'
4302       common /calcthet/ term1,term2,termm,diffak,ratak,
4303      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4304      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4305       double precision y(2),z(2)
4306       delta=0.02d0*pi
4307 c      time11=dexp(-2*time)
4308 c      time12=1.0d0
4309       etheta=0.0D0
4310 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4311       do i=ithet_start,ithet_end
4312         if (itype(i-1).eq.ntyp1) cycle
4313 C Zero the energy function and its derivative at 0 or pi.
4314         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4315         it=itype(i-1)
4316         ichir1=isign(1,itype(i-2))
4317         ichir2=isign(1,itype(i))
4318          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4319          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4320          if (itype(i-1).eq.10) then
4321           itype1=isign(10,itype(i-2))
4322           ichir11=isign(1,itype(i-2))
4323           ichir12=isign(1,itype(i-2))
4324           itype2=isign(10,itype(i))
4325           ichir21=isign(1,itype(i))
4326           ichir22=isign(1,itype(i))
4327          endif
4328
4329         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4330 #ifdef OSF
4331           phii=phi(i)
4332           if (phii.ne.phii) phii=150.0
4333 #else
4334           phii=phi(i)
4335 #endif
4336           y(1)=dcos(phii)
4337           y(2)=dsin(phii)
4338         else
4339           y(1)=0.0D0
4340           y(2)=0.0D0
4341         endif
4342         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4343 #ifdef OSF
4344           phii1=phi(i+1)
4345           if (phii1.ne.phii1) phii1=150.0
4346           phii1=pinorm(phii1)
4347           z(1)=cos(phii1)
4348 #else
4349           phii1=phi(i+1)
4350           z(1)=dcos(phii1)
4351 #endif
4352           z(2)=dsin(phii1)
4353         else
4354           z(1)=0.0D0
4355           z(2)=0.0D0
4356         endif
4357 C Calculate the "mean" value of theta from the part of the distribution
4358 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4359 C In following comments this theta will be referred to as t_c.
4360         thet_pred_mean=0.0d0
4361         do k=1,2
4362             athetk=athet(k,it,ichir1,ichir2)
4363             bthetk=bthet(k,it,ichir1,ichir2)
4364           if (it.eq.10) then
4365              athetk=athet(k,itype1,ichir11,ichir12)
4366              bthetk=bthet(k,itype2,ichir21,ichir22)
4367           endif
4368          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4369         enddo
4370         dthett=thet_pred_mean*ssd
4371         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4372 C Derivatives of the "mean" values in gamma1 and gamma2.
4373         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4374      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4375          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4376      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4377          if (it.eq.10) then
4378       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4379      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4380         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4381      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4382          endif
4383         if (theta(i).gt.pi-delta) then
4384           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4385      &         E_tc0)
4386           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4387           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4388           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4389      &        E_theta)
4390           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4391      &        E_tc)
4392         else if (theta(i).lt.delta) then
4393           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4394           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4395           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4396      &        E_theta)
4397           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4398           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4399      &        E_tc)
4400         else
4401           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4402      &        E_theta,E_tc)
4403         endif
4404         etheta=etheta+ethetai
4405         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4406      &      'ebend',i,ethetai
4407         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4408         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4409         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4410       enddo
4411 C Ufff.... We've done all this!!!
4412       return
4413       end
4414 C---------------------------------------------------------------------------
4415       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4416      &     E_tc)
4417       implicit real*8 (a-h,o-z)
4418       include 'DIMENSIONS'
4419       include 'COMMON.LOCAL'
4420       include 'COMMON.IOUNITS'
4421       common /calcthet/ term1,term2,termm,diffak,ratak,
4422      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4423      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4424 C Calculate the contributions to both Gaussian lobes.
4425 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4426 C The "polynomial part" of the "standard deviation" of this part of
4427 C the distribution.
4428         sig=polthet(3,it)
4429         do j=2,0,-1
4430           sig=sig*thet_pred_mean+polthet(j,it)
4431         enddo
4432 C Derivative of the "interior part" of the "standard deviation of the"
4433 C gamma-dependent Gaussian lobe in t_c.
4434         sigtc=3*polthet(3,it)
4435         do j=2,1,-1
4436           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4437         enddo
4438         sigtc=sig*sigtc
4439 C Set the parameters of both Gaussian lobes of the distribution.
4440 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4441         fac=sig*sig+sigc0(it)
4442         sigcsq=fac+fac
4443         sigc=1.0D0/sigcsq
4444 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4445         sigsqtc=-4.0D0*sigcsq*sigtc
4446 c       print *,i,sig,sigtc,sigsqtc
4447 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4448         sigtc=-sigtc/(fac*fac)
4449 C Following variable is sigma(t_c)**(-2)
4450         sigcsq=sigcsq*sigcsq
4451         sig0i=sig0(it)
4452         sig0inv=1.0D0/sig0i**2
4453         delthec=thetai-thet_pred_mean
4454         delthe0=thetai-theta0i
4455         term1=-0.5D0*sigcsq*delthec*delthec
4456         term2=-0.5D0*sig0inv*delthe0*delthe0
4457 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4458 C NaNs in taking the logarithm. We extract the largest exponent which is added
4459 C to the energy (this being the log of the distribution) at the end of energy
4460 C term evaluation for this virtual-bond angle.
4461         if (term1.gt.term2) then
4462           termm=term1
4463           term2=dexp(term2-termm)
4464           term1=1.0d0
4465         else
4466           termm=term2
4467           term1=dexp(term1-termm)
4468           term2=1.0d0
4469         endif
4470 C The ratio between the gamma-independent and gamma-dependent lobes of
4471 C the distribution is a Gaussian function of thet_pred_mean too.
4472         diffak=gthet(2,it)-thet_pred_mean
4473         ratak=diffak/gthet(3,it)**2
4474         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4475 C Let's differentiate it in thet_pred_mean NOW.
4476         aktc=ak*ratak
4477 C Now put together the distribution terms to make complete distribution.
4478         termexp=term1+ak*term2
4479         termpre=sigc+ak*sig0i
4480 C Contribution of the bending energy from this theta is just the -log of
4481 C the sum of the contributions from the two lobes and the pre-exponential
4482 C factor. Simple enough, isn't it?
4483         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4484 C NOW the derivatives!!!
4485 C 6/6/97 Take into account the deformation.
4486         E_theta=(delthec*sigcsq*term1
4487      &       +ak*delthe0*sig0inv*term2)/termexp
4488         E_tc=((sigtc+aktc*sig0i)/termpre
4489      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4490      &       aktc*term2)/termexp)
4491       return
4492       end
4493 c-----------------------------------------------------------------------------
4494       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4495       implicit real*8 (a-h,o-z)
4496       include 'DIMENSIONS'
4497       include 'COMMON.LOCAL'
4498       include 'COMMON.IOUNITS'
4499       common /calcthet/ term1,term2,termm,diffak,ratak,
4500      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4501      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4502       delthec=thetai-thet_pred_mean
4503       delthe0=thetai-theta0i
4504 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4505       t3 = thetai-thet_pred_mean
4506       t6 = t3**2
4507       t9 = term1
4508       t12 = t3*sigcsq
4509       t14 = t12+t6*sigsqtc
4510       t16 = 1.0d0
4511       t21 = thetai-theta0i
4512       t23 = t21**2
4513       t26 = term2
4514       t27 = t21*t26
4515       t32 = termexp
4516       t40 = t32**2
4517       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4518      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4519      & *(-t12*t9-ak*sig0inv*t27)
4520       return
4521       end
4522 #else
4523 C--------------------------------------------------------------------------
4524       subroutine ebend(etheta)
4525 C
4526 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4527 C angles gamma and its derivatives in consecutive thetas and gammas.
4528 C ab initio-derived potentials from
4529 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4530 C
4531       implicit real*8 (a-h,o-z)
4532       include 'DIMENSIONS'
4533       include 'COMMON.LOCAL'
4534       include 'COMMON.GEO'
4535       include 'COMMON.INTERACT'
4536       include 'COMMON.DERIV'
4537       include 'COMMON.VAR'
4538       include 'COMMON.CHAIN'
4539       include 'COMMON.IOUNITS'
4540       include 'COMMON.NAMES'
4541       include 'COMMON.FFIELD'
4542       include 'COMMON.CONTROL'
4543       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4544      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4545      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4546      & sinph1ph2(maxdouble,maxdouble)
4547       logical lprn /.false./, lprn1 /.false./
4548       etheta=0.0D0
4549       do i=ithet_start,ithet_end
4550         if (itype(i-1).eq.ntyp1) cycle
4551         if (iabs(itype(i+1)).eq.20) iblock=2
4552         if (iabs(itype(i+1)).ne.20) iblock=1
4553         dethetai=0.0d0
4554         dephii=0.0d0
4555         dephii1=0.0d0
4556         theti2=0.5d0*theta(i)
4557         ityp2=ithetyp((itype(i-1)))
4558         do k=1,nntheterm
4559           coskt(k)=dcos(k*theti2)
4560           sinkt(k)=dsin(k*theti2)
4561         enddo
4562         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4563 #ifdef OSF
4564           phii=phi(i)
4565           if (phii.ne.phii) phii=150.0
4566 #else
4567           phii=phi(i)
4568 #endif
4569           ityp1=ithetyp((itype(i-2)))
4570 C propagation of chirality for glycine type
4571           do k=1,nsingle
4572             cosph1(k)=dcos(k*phii)
4573             sinph1(k)=dsin(k*phii)
4574           enddo
4575         else
4576           phii=0.0d0
4577           ityp1=nthetyp+1
4578           do k=1,nsingle
4579             cosph1(k)=0.0d0
4580             sinph1(k)=0.0d0
4581           enddo
4582         endif
4583         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4584 #ifdef OSF
4585           phii1=phi(i+1)
4586           if (phii1.ne.phii1) phii1=150.0
4587           phii1=pinorm(phii1)
4588 #else
4589           phii1=phi(i+1)
4590 #endif
4591           ityp3=ithetyp((itype(i)))
4592           do k=1,nsingle
4593             cosph2(k)=dcos(k*phii1)
4594             sinph2(k)=dsin(k*phii1)
4595           enddo
4596         else
4597           phii1=0.0d0
4598           ityp3=nthetyp+1
4599           do k=1,nsingle
4600             cosph2(k)=0.0d0
4601             sinph2(k)=0.0d0
4602           enddo
4603         endif
4604         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4605         do k=1,ndouble
4606           do l=1,k-1
4607             ccl=cosph1(l)*cosph2(k-l)
4608             ssl=sinph1(l)*sinph2(k-l)
4609             scl=sinph1(l)*cosph2(k-l)
4610             csl=cosph1(l)*sinph2(k-l)
4611             cosph1ph2(l,k)=ccl-ssl
4612             cosph1ph2(k,l)=ccl+ssl
4613             sinph1ph2(l,k)=scl+csl
4614             sinph1ph2(k,l)=scl-csl
4615           enddo
4616         enddo
4617         if (lprn) then
4618         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4619      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4620         write (iout,*) "coskt and sinkt"
4621         do k=1,nntheterm
4622           write (iout,*) k,coskt(k),sinkt(k)
4623         enddo
4624         endif
4625         do k=1,ntheterm
4626           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4627           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4628      &      *coskt(k)
4629           if (lprn)
4630      &    write (iout,*) "k",k,"
4631      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4632      &     " ethetai",ethetai
4633         enddo
4634         if (lprn) then
4635         write (iout,*) "cosph and sinph"
4636         do k=1,nsingle
4637           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4638         enddo
4639         write (iout,*) "cosph1ph2 and sinph2ph2"
4640         do k=2,ndouble
4641           do l=1,k-1
4642             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4643      &         sinph1ph2(l,k),sinph1ph2(k,l)
4644           enddo
4645         enddo
4646         write(iout,*) "ethetai",ethetai
4647         endif
4648         do m=1,ntheterm2
4649           do k=1,nsingle
4650             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4651      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4652      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4653      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4654             ethetai=ethetai+sinkt(m)*aux
4655             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4656             dephii=dephii+k*sinkt(m)*(
4657      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4658      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4659             dephii1=dephii1+k*sinkt(m)*(
4660      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4661      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4662             if (lprn)
4663      &      write (iout,*) "m",m," k",k," bbthet",
4664      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4665      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4666      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4667      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4668           enddo
4669         enddo
4670         if (lprn)
4671      &  write(iout,*) "ethetai",ethetai
4672         do m=1,ntheterm3
4673           do k=2,ndouble
4674             do l=1,k-1
4675               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4676      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4677      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4678      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4679               ethetai=ethetai+sinkt(m)*aux
4680               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4681               dephii=dephii+l*sinkt(m)*(
4682      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4683      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4684      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4685      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4686               dephii1=dephii1+(k-l)*sinkt(m)*(
4687      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4688      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4689      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4690      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4691               if (lprn) then
4692               write (iout,*) "m",m," k",k," l",l," ffthet",
4693      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4694      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4695      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4696      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4697      &            " 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 c        lprn1=.true.
4707         if (lprn1)
4708      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4709      &   i,theta(i)*rad2deg,phii*rad2deg,
4710      &   phii1*rad2deg,ethetai
4711 c        lprn1=.false.
4712         etheta=etheta+ethetai
4713         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4714         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4715         gloc(nphi+i-2,icg)=wang*dethetai
4716       enddo
4717       return
4718       end
4719 #endif
4720 #ifdef CRYST_SC
4721 c-----------------------------------------------------------------------------
4722       subroutine esc(escloc)
4723 C Calculate the local energy of a side chain and its derivatives in the
4724 C corresponding virtual-bond valence angles THETA and the spherical angles
4725 C ALPHA and OMEGA.
4726       implicit real*8 (a-h,o-z)
4727       include 'DIMENSIONS'
4728       include 'COMMON.GEO'
4729       include 'COMMON.LOCAL'
4730       include 'COMMON.VAR'
4731       include 'COMMON.INTERACT'
4732       include 'COMMON.DERIV'
4733       include 'COMMON.CHAIN'
4734       include 'COMMON.IOUNITS'
4735       include 'COMMON.NAMES'
4736       include 'COMMON.FFIELD'
4737       include 'COMMON.CONTROL'
4738       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4739      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4740       common /sccalc/ time11,time12,time112,theti,it,nlobit
4741       delta=0.02d0*pi
4742       escloc=0.0D0
4743 c     write (iout,'(a)') 'ESC'
4744       do i=loc_start,loc_end
4745         it=itype(i)
4746         if (it.eq.ntyp1) cycle
4747         if (it.eq.10) goto 1
4748         nlobit=nlob(iabs(it))
4749 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4750 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4751         theti=theta(i+1)-pipol
4752         x(1)=dtan(theti)
4753         x(2)=alph(i)
4754         x(3)=omeg(i)
4755
4756         if (x(2).gt.pi-delta) then
4757           xtemp(1)=x(1)
4758           xtemp(2)=pi-delta
4759           xtemp(3)=x(3)
4760           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4761           xtemp(2)=pi
4762           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4763           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4764      &        escloci,dersc(2))
4765           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4766      &        ddersc0(1),dersc(1))
4767           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4768      &        ddersc0(3),dersc(3))
4769           xtemp(2)=pi-delta
4770           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4771           xtemp(2)=pi
4772           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4773           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4774      &            dersc0(2),esclocbi,dersc02)
4775           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4776      &            dersc12,dersc01)
4777           call splinthet(x(2),0.5d0*delta,ss,ssd)
4778           dersc0(1)=dersc01
4779           dersc0(2)=dersc02
4780           dersc0(3)=0.0d0
4781           do k=1,3
4782             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4783           enddo
4784           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4785 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4786 c    &             esclocbi,ss,ssd
4787           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4788 c         escloci=esclocbi
4789 c         write (iout,*) escloci
4790         else if (x(2).lt.delta) then
4791           xtemp(1)=x(1)
4792           xtemp(2)=delta
4793           xtemp(3)=x(3)
4794           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4795           xtemp(2)=0.0d0
4796           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4797           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4798      &        escloci,dersc(2))
4799           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4800      &        ddersc0(1),dersc(1))
4801           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4802      &        ddersc0(3),dersc(3))
4803           xtemp(2)=delta
4804           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4805           xtemp(2)=0.0d0
4806           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4807           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4808      &            dersc0(2),esclocbi,dersc02)
4809           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4810      &            dersc12,dersc01)
4811           dersc0(1)=dersc01
4812           dersc0(2)=dersc02
4813           dersc0(3)=0.0d0
4814           call splinthet(x(2),0.5d0*delta,ss,ssd)
4815           do k=1,3
4816             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4817           enddo
4818           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4819 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4820 c    &             esclocbi,ss,ssd
4821           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4822 c         write (iout,*) escloci
4823         else
4824           call enesc(x,escloci,dersc,ddummy,.false.)
4825         endif
4826
4827         escloc=escloc+escloci
4828         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4829      &     'escloc',i,escloci
4830 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4831
4832         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4833      &   wscloc*dersc(1)
4834         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4835         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4836     1   continue
4837       enddo
4838       return
4839       end
4840 C---------------------------------------------------------------------------
4841       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4842       implicit real*8 (a-h,o-z)
4843       include 'DIMENSIONS'
4844       include 'COMMON.GEO'
4845       include 'COMMON.LOCAL'
4846       include 'COMMON.IOUNITS'
4847       common /sccalc/ time11,time12,time112,theti,it,nlobit
4848       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4849       double precision contr(maxlob,-1:1)
4850       logical mixed
4851 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4852         escloc_i=0.0D0
4853         do j=1,3
4854           dersc(j)=0.0D0
4855           if (mixed) ddersc(j)=0.0d0
4856         enddo
4857         x3=x(3)
4858
4859 C Because of periodicity of the dependence of the SC energy in omega we have
4860 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4861 C To avoid underflows, first compute & store the exponents.
4862
4863         do iii=-1,1
4864
4865           x(3)=x3+iii*dwapi
4866
4867           do j=1,nlobit
4868             do k=1,3
4869               z(k)=x(k)-censc(k,j,it)
4870             enddo
4871             do k=1,3
4872               Axk=0.0D0
4873               do l=1,3
4874                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4875               enddo
4876               Ax(k,j,iii)=Axk
4877             enddo
4878             expfac=0.0D0
4879             do k=1,3
4880               expfac=expfac+Ax(k,j,iii)*z(k)
4881             enddo
4882             contr(j,iii)=expfac
4883           enddo ! j
4884
4885         enddo ! iii
4886
4887         x(3)=x3
4888 C As in the case of ebend, we want to avoid underflows in exponentiation and
4889 C subsequent NaNs and INFs in energy calculation.
4890 C Find the largest exponent
4891         emin=contr(1,-1)
4892         do iii=-1,1
4893           do j=1,nlobit
4894             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4895           enddo
4896         enddo
4897         emin=0.5D0*emin
4898 cd      print *,'it=',it,' emin=',emin
4899
4900 C Compute the contribution to SC energy and derivatives
4901         do iii=-1,1
4902
4903           do j=1,nlobit
4904 #ifdef OSF
4905             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4906             if(adexp.ne.adexp) adexp=1.0
4907             expfac=dexp(adexp)
4908 #else
4909             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4910 #endif
4911 cd          print *,'j=',j,' expfac=',expfac
4912             escloc_i=escloc_i+expfac
4913             do k=1,3
4914               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4915             enddo
4916             if (mixed) then
4917               do k=1,3,2
4918                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4919      &            +gaussc(k,2,j,it))*expfac
4920               enddo
4921             endif
4922           enddo
4923
4924         enddo ! iii
4925
4926         dersc(1)=dersc(1)/cos(theti)**2
4927         ddersc(1)=ddersc(1)/cos(theti)**2
4928         ddersc(3)=ddersc(3)
4929
4930         escloci=-(dlog(escloc_i)-emin)
4931         do j=1,3
4932           dersc(j)=dersc(j)/escloc_i
4933         enddo
4934         if (mixed) then
4935           do j=1,3,2
4936             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4937           enddo
4938         endif
4939       return
4940       end
4941 C------------------------------------------------------------------------------
4942       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4943       implicit real*8 (a-h,o-z)
4944       include 'DIMENSIONS'
4945       include 'COMMON.GEO'
4946       include 'COMMON.LOCAL'
4947       include 'COMMON.IOUNITS'
4948       common /sccalc/ time11,time12,time112,theti,it,nlobit
4949       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4950       double precision contr(maxlob)
4951       logical mixed
4952
4953       escloc_i=0.0D0
4954
4955       do j=1,3
4956         dersc(j)=0.0D0
4957       enddo
4958
4959       do j=1,nlobit
4960         do k=1,2
4961           z(k)=x(k)-censc(k,j,it)
4962         enddo
4963         z(3)=dwapi
4964         do k=1,3
4965           Axk=0.0D0
4966           do l=1,3
4967             Axk=Axk+gaussc(l,k,j,it)*z(l)
4968           enddo
4969           Ax(k,j)=Axk
4970         enddo
4971         expfac=0.0D0
4972         do k=1,3
4973           expfac=expfac+Ax(k,j)*z(k)
4974         enddo
4975         contr(j)=expfac
4976       enddo ! j
4977
4978 C As in the case of ebend, we want to avoid underflows in exponentiation and
4979 C subsequent NaNs and INFs in energy calculation.
4980 C Find the largest exponent
4981       emin=contr(1)
4982       do j=1,nlobit
4983         if (emin.gt.contr(j)) emin=contr(j)
4984       enddo
4985       emin=0.5D0*emin
4986
4987 C Compute the contribution to SC energy and derivatives
4988
4989       dersc12=0.0d0
4990       do j=1,nlobit
4991         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4992         escloc_i=escloc_i+expfac
4993         do k=1,2
4994           dersc(k)=dersc(k)+Ax(k,j)*expfac
4995         enddo
4996         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4997      &            +gaussc(1,2,j,it))*expfac
4998         dersc(3)=0.0d0
4999       enddo
5000
5001       dersc(1)=dersc(1)/cos(theti)**2
5002       dersc12=dersc12/cos(theti)**2
5003       escloci=-(dlog(escloc_i)-emin)
5004       do j=1,2
5005         dersc(j)=dersc(j)/escloc_i
5006       enddo
5007       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5008       return
5009       end
5010 #else
5011 c----------------------------------------------------------------------------------
5012       subroutine esc(escloc)
5013 C Calculate the local energy of a side chain and its derivatives in the
5014 C corresponding virtual-bond valence angles THETA and the spherical angles
5015 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5016 C added by Urszula Kozlowska. 07/11/2007
5017 C
5018       implicit real*8 (a-h,o-z)
5019       include 'DIMENSIONS'
5020       include 'COMMON.GEO'
5021       include 'COMMON.LOCAL'
5022       include 'COMMON.VAR'
5023       include 'COMMON.SCROT'
5024       include 'COMMON.INTERACT'
5025       include 'COMMON.DERIV'
5026       include 'COMMON.CHAIN'
5027       include 'COMMON.IOUNITS'
5028       include 'COMMON.NAMES'
5029       include 'COMMON.FFIELD'
5030       include 'COMMON.CONTROL'
5031       include 'COMMON.VECTORS'
5032       double precision x_prime(3),y_prime(3),z_prime(3)
5033      &    , sumene,dsc_i,dp2_i,x(65),
5034      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5035      &    de_dxx,de_dyy,de_dzz,de_dt
5036       double precision s1_t,s1_6_t,s2_t,s2_6_t
5037       double precision
5038      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5039      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5040      & dt_dCi(3),dt_dCi1(3)
5041       common /sccalc/ time11,time12,time112,theti,it,nlobit
5042       delta=0.02d0*pi
5043       escloc=0.0D0
5044       do i=loc_start,loc_end
5045         if (itype(i).eq.ntyp1) cycle
5046         costtab(i+1) =dcos(theta(i+1))
5047         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5048         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5049         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5050         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5051         cosfac=dsqrt(cosfac2)
5052         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5053         sinfac=dsqrt(sinfac2)
5054         it=itype(i)
5055         if (it.eq.10) goto 1
5056 c
5057 C  Compute the axes of tghe local cartesian coordinates system; store in
5058 c   x_prime, y_prime and z_prime
5059 c
5060         do j=1,3
5061           x_prime(j) = 0.00
5062           y_prime(j) = 0.00
5063           z_prime(j) = 0.00
5064         enddo
5065 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5066 C     &   dc_norm(3,i+nres)
5067         do j = 1,3
5068           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5069           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5070         enddo
5071         do j = 1,3
5072           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5073         enddo
5074 c       write (2,*) "i",i
5075 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5076 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5077 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5078 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5079 c      & " xy",scalar(x_prime(1),y_prime(1)),
5080 c      & " xz",scalar(x_prime(1),z_prime(1)),
5081 c      & " yy",scalar(y_prime(1),y_prime(1)),
5082 c      & " yz",scalar(y_prime(1),z_prime(1)),
5083 c      & " zz",scalar(z_prime(1),z_prime(1))
5084 c
5085 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5086 C to local coordinate system. Store in xx, yy, zz.
5087 c
5088         xx=0.0d0
5089         yy=0.0d0
5090         zz=0.0d0
5091         do j = 1,3
5092           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5093           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5094           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5095         enddo
5096
5097         xxtab(i)=xx
5098         yytab(i)=yy
5099         zztab(i)=zz
5100 C
5101 C Compute the energy of the ith side cbain
5102 C
5103 c        write (2,*) "xx",xx," yy",yy," zz",zz
5104         it=iabs(itype(i))
5105         do j = 1,65
5106           x(j) = sc_parmin(j,it)
5107         enddo
5108 #ifdef CHECK_COORD
5109 Cc diagnostics - remove later
5110         xx1 = dcos(alph(2))
5111         yy1 = dsin(alph(2))*dcos(omeg(2))
5112         zz1 = -dsign(1.0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5113         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5114      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5115      &    xx1,yy1,zz1
5116 C,"  --- ", xx_w,yy_w,zz_w
5117 c end diagnostics
5118 #endif
5119         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5120      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5121      &   + x(10)*yy*zz
5122         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5123      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5124      & + x(20)*yy*zz
5125         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5126      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5127      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5128      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5129      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5130      &  +x(40)*xx*yy*zz
5131         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5132      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5133      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5134      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5135      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5136      &  +x(60)*xx*yy*zz
5137         dsc_i   = 0.743d0+x(61)
5138         dp2_i   = 1.9d0+x(62)
5139         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5140      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5141         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5142      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5143         s1=(1+x(63))/(0.1d0 + dscp1)
5144         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5145         s2=(1+x(65))/(0.1d0 + dscp2)
5146         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5147         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5148      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5149 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5150 c     &   sumene4,
5151 c     &   dscp1,dscp2,sumene
5152 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5153         escloc = escloc + sumene
5154 c        write (2,*) "i",i," escloc",sumene,escloc
5155 c#define DEBUG
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 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5200         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5201         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5202         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5203         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5204         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5205         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5206         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5207         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5208         pom1=(sumene3*sint2tab(i+1)+sumene1)
5209      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5210         pom2=(sumene4*cost2tab(i+1)+sumene2)
5211      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5212         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5213         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5214      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5215      &  +x(40)*yy*zz
5216         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5217         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5218      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5219      &  +x(60)*yy*zz
5220         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5221      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5222      &        +(pom1+pom2)*pom_dx
5223 #ifdef DEBUG
5224         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5225 #endif
5226 C
5227         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5228         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5229      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5230      &  +x(40)*xx*zz
5231         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5232         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5233      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5234      &  +x(59)*zz**2 +x(60)*xx*zz
5235         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5236      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5237      &        +(pom1-pom2)*pom_dy
5238 #ifdef DEBUG
5239         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5240 #endif
5241 C
5242         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5243      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5244      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5245      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5246      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5247      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5248      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5249      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5250 #ifdef DEBUG
5251         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5252 #endif
5253 C
5254         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5255      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5256      &  +pom1*pom_dt1+pom2*pom_dt2
5257 #ifdef DEBUG
5258         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5259 #endif
5260 c#undef DEBUG
5261 c
5262 C
5263        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5264        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5265        cosfac2xx=cosfac2*xx
5266        sinfac2yy=sinfac2*yy
5267        do k = 1,3
5268          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5269      &      vbld_inv(i+1)
5270          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5271      &      vbld_inv(i)
5272          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5273          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5274 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5275 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5276 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5277 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5278          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5279          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5280          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5281          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5282          dZZ_Ci1(k)=0.0d0
5283          dZZ_Ci(k)=0.0d0
5284          do j=1,3
5285            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5286      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5287            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5288      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5289          enddo
5290
5291          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5292          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5293          dZZ_XYZ(k)=vbld_inv(i+nres)*
5294      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5295 c
5296          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5297          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5298        enddo
5299
5300        do k=1,3
5301          dXX_Ctab(k,i)=dXX_Ci(k)
5302          dXX_C1tab(k,i)=dXX_Ci1(k)
5303          dYY_Ctab(k,i)=dYY_Ci(k)
5304          dYY_C1tab(k,i)=dYY_Ci1(k)
5305          dZZ_Ctab(k,i)=dZZ_Ci(k)
5306          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5307          dXX_XYZtab(k,i)=dXX_XYZ(k)
5308          dYY_XYZtab(k,i)=dYY_XYZ(k)
5309          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5310        enddo
5311
5312        do k = 1,3
5313 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5314 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5315 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5316 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5317 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5318 c     &    dt_dci(k)
5319 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5320 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5321          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5322      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5323          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5324      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5325          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5326      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5327        enddo
5328 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5329 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5330
5331 C to check gradient call subroutine check_grad
5332
5333     1 continue
5334       enddo
5335       return
5336       end
5337 c------------------------------------------------------------------------------
5338       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5339       implicit none
5340       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5341      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5342       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5343      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5344      &   + x(10)*yy*zz
5345       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5346      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5347      & + x(20)*yy*zz
5348       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5349      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5350      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5351      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5352      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5353      &  +x(40)*xx*yy*zz
5354       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5355      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5356      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5357      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5358      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5359      &  +x(60)*xx*yy*zz
5360       dsc_i   = 0.743d0+x(61)
5361       dp2_i   = 1.9d0+x(62)
5362       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5363      &          *(xx*cost2+yy*sint2))
5364       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5365      &          *(xx*cost2-yy*sint2))
5366       s1=(1+x(63))/(0.1d0 + dscp1)
5367       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5368       s2=(1+x(65))/(0.1d0 + dscp2)
5369       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5370       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5371      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5372       enesc=sumene
5373       return
5374       end
5375 #endif
5376 c------------------------------------------------------------------------------
5377       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5378 C
5379 C This procedure calculates two-body contact function g(rij) and its derivative:
5380 C
5381 C           eps0ij                                     !       x < -1
5382 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5383 C            0                                         !       x > 1
5384 C
5385 C where x=(rij-r0ij)/delta
5386 C
5387 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5388 C
5389       implicit none
5390       double precision rij,r0ij,eps0ij,fcont,fprimcont
5391       double precision x,x2,x4,delta
5392 c     delta=0.02D0*r0ij
5393 c      delta=0.2D0*r0ij
5394       x=(rij-r0ij)/delta
5395       if (x.lt.-1.0D0) then
5396         fcont=eps0ij
5397         fprimcont=0.0D0
5398       else if (x.le.1.0D0) then
5399         x2=x*x
5400         x4=x2*x2
5401         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5402         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5403       else
5404         fcont=0.0D0
5405         fprimcont=0.0D0
5406       endif
5407       return
5408       end
5409 c------------------------------------------------------------------------------
5410       subroutine splinthet(theti,delta,ss,ssder)
5411       implicit real*8 (a-h,o-z)
5412       include 'DIMENSIONS'
5413       include 'COMMON.VAR'
5414       include 'COMMON.GEO'
5415       thetup=pi-delta
5416       thetlow=delta
5417       if (theti.gt.pipol) then
5418         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5419       else
5420         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5421         ssder=-ssder
5422       endif
5423       return
5424       end
5425 c------------------------------------------------------------------------------
5426       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5427       implicit none
5428       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5429       double precision ksi,ksi2,ksi3,a1,a2,a3
5430       a1=fprim0*delta/(f1-f0)
5431       a2=3.0d0-2.0d0*a1
5432       a3=a1-2.0d0
5433       ksi=(x-x0)/delta
5434       ksi2=ksi*ksi
5435       ksi3=ksi2*ksi
5436       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5437       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5438       return
5439       end
5440 c------------------------------------------------------------------------------
5441       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5442       implicit none
5443       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5444       double precision ksi,ksi2,ksi3,a1,a2,a3
5445       ksi=(x-x0)/delta
5446       ksi2=ksi*ksi
5447       ksi3=ksi2*ksi
5448       a1=fprim0x*delta
5449       a2=3*(f1x-f0x)-2*fprim0x*delta
5450       a3=fprim0x*delta-2*(f1x-f0x)
5451       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5452       return
5453       end
5454 C-----------------------------------------------------------------------------
5455 #ifdef CRYST_TOR
5456 C-----------------------------------------------------------------------------
5457       subroutine etor(etors,edihcnstr)
5458       implicit real*8 (a-h,o-z)
5459       include 'DIMENSIONS'
5460       include 'COMMON.VAR'
5461       include 'COMMON.GEO'
5462       include 'COMMON.LOCAL'
5463       include 'COMMON.TORSION'
5464       include 'COMMON.INTERACT'
5465       include 'COMMON.DERIV'
5466       include 'COMMON.CHAIN'
5467       include 'COMMON.NAMES'
5468       include 'COMMON.IOUNITS'
5469       include 'COMMON.FFIELD'
5470       include 'COMMON.TORCNSTR'
5471       include 'COMMON.CONTROL'
5472       logical lprn
5473 C Set lprn=.true. for debugging
5474       lprn=.false.
5475 c      lprn=.true.
5476       etors=0.0D0
5477       do i=iphi_start,iphi_end
5478       etors_ii=0.0D0
5479         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5480      &      .or. itype(i).eq.ntyp1) cycle
5481         itori=itortyp(itype(i-2))
5482         itori1=itortyp(itype(i-1))
5483         phii=phi(i)
5484         gloci=0.0D0
5485 C Proline-Proline pair is a special case...
5486         if (itori.eq.3 .and. itori1.eq.3) then
5487           if (phii.gt.-dwapi3) then
5488             cosphi=dcos(3*phii)
5489             fac=1.0D0/(1.0D0-cosphi)
5490             etorsi=v1(1,3,3)*fac
5491             etorsi=etorsi+etorsi
5492             etors=etors+etorsi-v1(1,3,3)
5493             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5494             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5495           endif
5496           do j=1,3
5497             v1ij=v1(j+1,itori,itori1)
5498             v2ij=v2(j+1,itori,itori1)
5499             cosphi=dcos(j*phii)
5500             sinphi=dsin(j*phii)
5501             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5502             if (energy_dec) etors_ii=etors_ii+
5503      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5504             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5505           enddo
5506         else
5507           do j=1,nterm_old
5508             v1ij=v1(j,itori,itori1)
5509             v2ij=v2(j,itori,itori1)
5510             cosphi=dcos(j*phii)
5511             sinphi=dsin(j*phii)
5512             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5513             if (energy_dec) etors_ii=etors_ii+
5514      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5515             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5516           enddo
5517         endif
5518         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5519              'etor',i,etors_ii
5520         if (lprn)
5521      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5522      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5523      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5524         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5525 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5526       enddo
5527 ! 6/20/98 - dihedral angle constraints
5528       edihcnstr=0.0d0
5529       do i=1,ndih_constr
5530         itori=idih_constr(i)
5531         phii=phi(itori)
5532         difi=phii-phi0(i)
5533         if (difi.gt.drange(i)) then
5534           difi=difi-drange(i)
5535           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5536           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5537         else if (difi.lt.-drange(i)) then
5538           difi=difi+drange(i)
5539           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5540           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5541         endif
5542 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5543 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5544       enddo
5545 !      write (iout,*) 'edihcnstr',edihcnstr
5546       return
5547       end
5548 c------------------------------------------------------------------------------
5549       subroutine etor_d(etors_d)
5550       etors_d=0.0d0
5551       return
5552       end
5553 c----------------------------------------------------------------------------
5554 #else
5555       subroutine etor(etors,edihcnstr)
5556       implicit real*8 (a-h,o-z)
5557       include 'DIMENSIONS'
5558       include 'COMMON.VAR'
5559       include 'COMMON.GEO'
5560       include 'COMMON.LOCAL'
5561       include 'COMMON.TORSION'
5562       include 'COMMON.INTERACT'
5563       include 'COMMON.DERIV'
5564       include 'COMMON.CHAIN'
5565       include 'COMMON.NAMES'
5566       include 'COMMON.IOUNITS'
5567       include 'COMMON.FFIELD'
5568       include 'COMMON.TORCNSTR'
5569       include 'COMMON.CONTROL'
5570       logical lprn
5571 C Set lprn=.true. for debugging
5572       lprn=.false.
5573 c     lprn=.true.
5574       etors=0.0D0
5575       do i=iphi_start,iphi_end
5576         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5577      &       .or. itype(i).eq.ntyp1) cycle
5578         etors_ii=0.0D0
5579          if (iabs(itype(i)).eq.20) then
5580          iblock=2
5581          else
5582          iblock=1
5583          endif
5584         itori=itortyp(itype(i-2))
5585         itori1=itortyp(itype(i-1))
5586         phii=phi(i)
5587         gloci=0.0D0
5588 C Regular cosine and sine terms
5589         do j=1,nterm(itori,itori1,iblock)
5590           v1ij=v1(j,itori,itori1,iblock)
5591           v2ij=v2(j,itori,itori1,iblock)
5592           cosphi=dcos(j*phii)
5593           sinphi=dsin(j*phii)
5594           etors=etors+v1ij*cosphi+v2ij*sinphi
5595           if (energy_dec) etors_ii=etors_ii+
5596      &                v1ij*cosphi+v2ij*sinphi
5597           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5598         enddo
5599 C Lorentz terms
5600 C                         v1
5601 C  E = SUM ----------------------------------- - v1
5602 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5603 C
5604         cosphi=dcos(0.5d0*phii)
5605         sinphi=dsin(0.5d0*phii)
5606         do j=1,nlor(itori,itori1,iblock)
5607           vl1ij=vlor1(j,itori,itori1)
5608           vl2ij=vlor2(j,itori,itori1)
5609           vl3ij=vlor3(j,itori,itori1)
5610           pom=vl2ij*cosphi+vl3ij*sinphi
5611           pom1=1.0d0/(pom*pom+1.0d0)
5612           etors=etors+vl1ij*pom1
5613           if (energy_dec) etors_ii=etors_ii+
5614      &                vl1ij*pom1
5615           pom=-pom*pom1*pom1
5616           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5617         enddo
5618 C Subtract the constant term
5619         etors=etors-v0(itori,itori1,iblock)
5620           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5621      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5622         if (lprn)
5623      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5624      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5625      &  (v1(j,itori,itori1,iblock),j=1,6),
5626      &  (v2(j,itori,itori1,iblock),j=1,6)
5627         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5628 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5629       enddo
5630 ! 6/20/98 - dihedral angle constraints
5631       edihcnstr=0.0d0
5632 c      do i=1,ndih_constr
5633       do i=idihconstr_start,idihconstr_end
5634         itori=idih_constr(i)
5635         phii=phi(itori)
5636         difi=pinorm(phii-phi0(i))
5637         if (difi.gt.drange(i)) then
5638           difi=difi-drange(i)
5639           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5640           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5641         else if (difi.lt.-drange(i)) then
5642           difi=difi+drange(i)
5643           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5644           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5645         else
5646           difi=0.0
5647         endif
5648 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5649 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5650 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5651       enddo
5652 cd       write (iout,*) 'edihcnstr',edihcnstr
5653       return
5654       end
5655 c----------------------------------------------------------------------------
5656       subroutine etor_d(etors_d)
5657 C 6/23/01 Compute double torsional energy
5658       implicit real*8 (a-h,o-z)
5659       include 'DIMENSIONS'
5660       include 'COMMON.VAR'
5661       include 'COMMON.GEO'
5662       include 'COMMON.LOCAL'
5663       include 'COMMON.TORSION'
5664       include 'COMMON.INTERACT'
5665       include 'COMMON.DERIV'
5666       include 'COMMON.CHAIN'
5667       include 'COMMON.NAMES'
5668       include 'COMMON.IOUNITS'
5669       include 'COMMON.FFIELD'
5670       include 'COMMON.TORCNSTR'
5671       logical lprn
5672 C Set lprn=.true. for debugging
5673       lprn=.false.
5674 c     lprn=.true.
5675       etors_d=0.0D0
5676 c      write(iout,*) "a tu??"
5677       do i=iphid_start,iphid_end
5678         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5679      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5680         itori=itortyp(itype(i-2))
5681         itori1=itortyp(itype(i-1))
5682         itori2=itortyp(itype(i))
5683         phii=phi(i)
5684         phii1=phi(i+1)
5685         gloci1=0.0D0
5686         gloci2=0.0D0
5687         iblock=1
5688         if (iabs(itype(i+1)).eq.20) iblock=2
5689
5690 C Regular cosine and sine terms
5691         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5692           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5693           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5694           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5695           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5696           cosphi1=dcos(j*phii)
5697           sinphi1=dsin(j*phii)
5698           cosphi2=dcos(j*phii1)
5699           sinphi2=dsin(j*phii1)
5700           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5701      &     v2cij*cosphi2+v2sij*sinphi2
5702           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5703           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5704         enddo
5705         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5706           do l=1,k-1
5707             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5708             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5709             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5710             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5711             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5712             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5713             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5714             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5715             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5716      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5717             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5718      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5719             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5720      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5721           enddo
5722         enddo
5723         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5724         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5725       enddo
5726       return
5727       end
5728 #endif
5729 c------------------------------------------------------------------------------
5730       subroutine eback_sc_corr(esccor)
5731 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5732 c        conformational states; temporarily implemented as differences
5733 c        between UNRES torsional potentials (dependent on three types of
5734 c        residues) and the torsional potentials dependent on all 20 types
5735 c        of residues computed from AM1  energy surfaces of terminally-blocked
5736 c        amino-acid residues.
5737       implicit real*8 (a-h,o-z)
5738       include 'DIMENSIONS'
5739       include 'COMMON.VAR'
5740       include 'COMMON.GEO'
5741       include 'COMMON.LOCAL'
5742       include 'COMMON.TORSION'
5743       include 'COMMON.SCCOR'
5744       include 'COMMON.INTERACT'
5745       include 'COMMON.DERIV'
5746       include 'COMMON.CHAIN'
5747       include 'COMMON.NAMES'
5748       include 'COMMON.IOUNITS'
5749       include 'COMMON.FFIELD'
5750       include 'COMMON.CONTROL'
5751       logical lprn
5752 C Set lprn=.true. for debugging
5753       lprn=.false.
5754 c      lprn=.true.
5755 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5756       esccor=0.0D0
5757       do i=itau_start,itau_end
5758         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5759         esccor_ii=0.0D0
5760         isccori=isccortyp(itype(i-2))
5761         isccori1=isccortyp(itype(i-1))
5762 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5763         phii=phi(i)
5764         do intertyp=1,3 !intertyp
5765 cc Added 09 May 2012 (Adasko)
5766 cc  Intertyp means interaction type of backbone mainchain correlation:
5767 c   1 = SC...Ca...Ca...Ca
5768 c   2 = Ca...Ca...Ca...SC
5769 c   3 = SC...Ca...Ca...SCi
5770         gloci=0.0D0
5771         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5772      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5773      &      (itype(i-1).eq.ntyp1)))
5774      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5775      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5776      &     .or.(itype(i).eq.ntyp1)))
5777      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5778      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5779      &      (itype(i-3).eq.ntyp1)))) cycle
5780         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5781         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5782      & cycle
5783        do j=1,nterm_sccor(isccori,isccori1)
5784           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5785           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5786           cosphi=dcos(j*tauangle(intertyp,i))
5787           sinphi=dsin(j*tauangle(intertyp,i))
5788           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5789           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5790         enddo
5791 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5792         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5793         if (lprn)
5794      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5795      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5796      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5797      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5798         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5799        enddo !intertyp
5800       enddo
5801
5802       return
5803       end
5804 c----------------------------------------------------------------------------
5805       subroutine multibody(ecorr)
5806 C This subroutine calculates multi-body contributions to energy following
5807 C the idea of Skolnick et al. If side chains I and J make a contact and
5808 C at the same time side chains I+1 and J+1 make a contact, an extra
5809 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5810       implicit real*8 (a-h,o-z)
5811       include 'DIMENSIONS'
5812       include 'COMMON.IOUNITS'
5813       include 'COMMON.DERIV'
5814       include 'COMMON.INTERACT'
5815       include 'COMMON.CONTACTS'
5816       double precision gx(3),gx1(3)
5817       logical lprn
5818
5819 C Set lprn=.true. for debugging
5820       lprn=.false.
5821
5822       if (lprn) then
5823         write (iout,'(a)') 'Contact function values:'
5824         do i=nnt,nct-2
5825           write (iout,'(i2,20(1x,i2,f10.5))')
5826      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5827         enddo
5828       endif
5829       ecorr=0.0D0
5830       do i=nnt,nct
5831         do j=1,3
5832           gradcorr(j,i)=0.0D0
5833           gradxorr(j,i)=0.0D0
5834         enddo
5835       enddo
5836       do i=nnt,nct-2
5837
5838         DO ISHIFT = 3,4
5839
5840         i1=i+ishift
5841         num_conti=num_cont(i)
5842         num_conti1=num_cont(i1)
5843         do jj=1,num_conti
5844           j=jcont(jj,i)
5845           do kk=1,num_conti1
5846             j1=jcont(kk,i1)
5847             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5848 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5849 cd   &                   ' ishift=',ishift
5850 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5851 C The system gains extra energy.
5852               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5853             endif   ! j1==j+-ishift
5854           enddo     ! kk
5855         enddo       ! jj
5856
5857         ENDDO ! ISHIFT
5858
5859       enddo         ! i
5860       return
5861       end
5862 c------------------------------------------------------------------------------
5863       double precision function esccorr(i,j,k,l,jj,kk)
5864       implicit real*8 (a-h,o-z)
5865       include 'DIMENSIONS'
5866       include 'COMMON.IOUNITS'
5867       include 'COMMON.DERIV'
5868       include 'COMMON.INTERACT'
5869       include 'COMMON.CONTACTS'
5870       double precision gx(3),gx1(3)
5871       logical lprn
5872       lprn=.false.
5873       eij=facont(jj,i)
5874       ekl=facont(kk,k)
5875 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5876 C Calculate the multi-body contribution to energy.
5877 C Calculate multi-body contributions to the gradient.
5878 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5879 cd   & k,l,(gacont(m,kk,k),m=1,3)
5880       do m=1,3
5881         gx(m) =ekl*gacont(m,jj,i)
5882         gx1(m)=eij*gacont(m,kk,k)
5883         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5884         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5885         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5886         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5887       enddo
5888       do m=i,j-1
5889         do ll=1,3
5890           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5891         enddo
5892       enddo
5893       do m=k,l-1
5894         do ll=1,3
5895           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5896         enddo
5897       enddo
5898       esccorr=-eij*ekl
5899       return
5900       end
5901 c------------------------------------------------------------------------------
5902       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5903 C This subroutine calculates multi-body contributions to hydrogen-bonding
5904       implicit real*8 (a-h,o-z)
5905       include 'DIMENSIONS'
5906       include 'COMMON.IOUNITS'
5907 #ifdef MPI
5908       include "mpif.h"
5909       parameter (max_cont=maxconts)
5910       parameter (max_dim=26)
5911       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5912       double precision zapas(max_dim,maxconts,max_fg_procs),
5913      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5914       common /przechowalnia/ zapas
5915       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5916      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5917 #endif
5918       include 'COMMON.SETUP'
5919       include 'COMMON.FFIELD'
5920       include 'COMMON.DERIV'
5921       include 'COMMON.INTERACT'
5922       include 'COMMON.CONTACTS'
5923       include 'COMMON.CONTROL'
5924       include 'COMMON.LOCAL'
5925       double precision gx(3),gx1(3),time00
5926       logical lprn,ldone
5927
5928 C Set lprn=.true. for debugging
5929       lprn=.false.
5930 #ifdef MPI
5931       n_corr=0
5932       n_corr1=0
5933       if (nfgtasks.le.1) goto 30
5934       if (lprn) then
5935         write (iout,'(a)') 'Contact function values before RECEIVE:'
5936         do i=nnt,nct-2
5937           write (iout,'(2i3,50(1x,i2,f5.2))')
5938      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5939      &    j=1,num_cont_hb(i))
5940         enddo
5941       endif
5942       call flush(iout)
5943       do i=1,ntask_cont_from
5944         ncont_recv(i)=0
5945       enddo
5946       do i=1,ntask_cont_to
5947         ncont_sent(i)=0
5948       enddo
5949 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5950 c     & ntask_cont_to
5951 C Make the list of contacts to send to send to other procesors
5952 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5953 c      call flush(iout)
5954       do i=iturn3_start,iturn3_end
5955 c        write (iout,*) "make contact list turn3",i," num_cont",
5956 c     &    num_cont_hb(i)
5957         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5958       enddo
5959       do i=iturn4_start,iturn4_end
5960 c        write (iout,*) "make contact list turn4",i," num_cont",
5961 c     &   num_cont_hb(i)
5962         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5963       enddo
5964       do ii=1,nat_sent
5965         i=iat_sent(ii)
5966 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5967 c     &    num_cont_hb(i)
5968         do j=1,num_cont_hb(i)
5969         do k=1,4
5970           jjc=jcont_hb(j,i)
5971           iproc=iint_sent_local(k,jjc,ii)
5972 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5973           if (iproc.gt.0) then
5974             ncont_sent(iproc)=ncont_sent(iproc)+1
5975             nn=ncont_sent(iproc)
5976             zapas(1,nn,iproc)=i
5977             zapas(2,nn,iproc)=jjc
5978             zapas(3,nn,iproc)=facont_hb(j,i)
5979             zapas(4,nn,iproc)=ees0p(j,i)
5980             zapas(5,nn,iproc)=ees0m(j,i)
5981             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5982             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5983             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5984             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5985             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5986             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5987             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5988             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5989             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5990             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5991             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5992             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5993             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5994             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5995             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5996             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5997             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5998             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5999             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6000             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6001             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6002           endif
6003         enddo
6004         enddo
6005       enddo
6006       if (lprn) then
6007       write (iout,*)
6008      &  "Numbers of contacts to be sent to other processors",
6009      &  (ncont_sent(i),i=1,ntask_cont_to)
6010       write (iout,*) "Contacts sent"
6011       do ii=1,ntask_cont_to
6012         nn=ncont_sent(ii)
6013         iproc=itask_cont_to(ii)
6014         write (iout,*) nn," contacts to processor",iproc,
6015      &   " of CONT_TO_COMM group"
6016         do i=1,nn
6017           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6018         enddo
6019       enddo
6020       call flush(iout)
6021       endif
6022       CorrelType=477
6023       CorrelID=fg_rank+1
6024       CorrelType1=478
6025       CorrelID1=nfgtasks+fg_rank+1
6026       ireq=0
6027 C Receive the numbers of needed contacts from other processors
6028       do ii=1,ntask_cont_from
6029         iproc=itask_cont_from(ii)
6030         ireq=ireq+1
6031         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6032      &    FG_COMM,req(ireq),IERR)
6033       enddo
6034 c      write (iout,*) "IRECV ended"
6035 c      call flush(iout)
6036 C Send the number of contacts needed by other processors
6037       do ii=1,ntask_cont_to
6038         iproc=itask_cont_to(ii)
6039         ireq=ireq+1
6040         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6041      &    FG_COMM,req(ireq),IERR)
6042       enddo
6043 c      write (iout,*) "ISEND ended"
6044 c      write (iout,*) "number of requests (nn)",ireq
6045       call flush(iout)
6046       if (ireq.gt.0)
6047      &  call MPI_Waitall(ireq,req,status_array,ierr)
6048 c      write (iout,*)
6049 c     &  "Numbers of contacts to be received from other processors",
6050 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6051 c      call flush(iout)
6052 C Receive contacts
6053       ireq=0
6054       do ii=1,ntask_cont_from
6055         iproc=itask_cont_from(ii)
6056         nn=ncont_recv(ii)
6057 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6058 c     &   " of CONT_TO_COMM group"
6059         call flush(iout)
6060         if (nn.gt.0) then
6061           ireq=ireq+1
6062           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6063      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6064 c          write (iout,*) "ireq,req",ireq,req(ireq)
6065         endif
6066       enddo
6067 C Send the contacts to processors that need them
6068       do ii=1,ntask_cont_to
6069         iproc=itask_cont_to(ii)
6070         nn=ncont_sent(ii)
6071 c        write (iout,*) nn," contacts to processor",iproc,
6072 c     &   " of CONT_TO_COMM group"
6073         if (nn.gt.0) then
6074           ireq=ireq+1
6075           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6076      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6077 c          write (iout,*) "ireq,req",ireq,req(ireq)
6078 c          do i=1,nn
6079 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6080 c          enddo
6081         endif
6082       enddo
6083 c      write (iout,*) "number of requests (contacts)",ireq
6084 c      write (iout,*) "req",(req(i),i=1,4)
6085 c      call flush(iout)
6086       if (ireq.gt.0)
6087      & call MPI_Waitall(ireq,req,status_array,ierr)
6088       do iii=1,ntask_cont_from
6089         iproc=itask_cont_from(iii)
6090         nn=ncont_recv(iii)
6091         if (lprn) then
6092         write (iout,*) "Received",nn," contacts from processor",iproc,
6093      &   " of CONT_FROM_COMM group"
6094         call flush(iout)
6095         do i=1,nn
6096           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6097         enddo
6098         call flush(iout)
6099         endif
6100         do i=1,nn
6101           ii=zapas_recv(1,i,iii)
6102 c Flag the received contacts to prevent double-counting
6103           jj=-zapas_recv(2,i,iii)
6104 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6105 c          call flush(iout)
6106           nnn=num_cont_hb(ii)+1
6107           num_cont_hb(ii)=nnn
6108           jcont_hb(nnn,ii)=jj
6109           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6110           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6111           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6112           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6113           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6114           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6115           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6116           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6117           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6118           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6119           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6120           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6121           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6122           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6123           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6124           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6125           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6126           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6127           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6128           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6129           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6130           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6131           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6132           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6133         enddo
6134       enddo
6135       call flush(iout)
6136       if (lprn) then
6137         write (iout,'(a)') 'Contact function values after receive:'
6138         do i=nnt,nct-2
6139           write (iout,'(2i3,50(1x,i3,f5.2))')
6140      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6141      &    j=1,num_cont_hb(i))
6142         enddo
6143         call flush(iout)
6144       endif
6145    30 continue
6146 #endif
6147       if (lprn) then
6148         write (iout,'(a)') 'Contact function values:'
6149         do i=nnt,nct-2
6150           write (iout,'(2i3,50(1x,i3,f5.2))')
6151      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6152      &    j=1,num_cont_hb(i))
6153         enddo
6154       endif
6155       ecorr=0.0D0
6156 C Remove the loop below after debugging !!!
6157       do i=nnt,nct
6158         do j=1,3
6159           gradcorr(j,i)=0.0D0
6160           gradxorr(j,i)=0.0D0
6161         enddo
6162       enddo
6163 C Calculate the local-electrostatic correlation terms
6164       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6165         i1=i+1
6166         num_conti=num_cont_hb(i)
6167         num_conti1=num_cont_hb(i+1)
6168         do jj=1,num_conti
6169           j=jcont_hb(jj,i)
6170           jp=iabs(j)
6171           do kk=1,num_conti1
6172             j1=jcont_hb(kk,i1)
6173             jp1=iabs(j1)
6174 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6175 c     &         ' jj=',jj,' kk=',kk
6176             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6177      &          .or. j.lt.0 .and. j1.gt.0) .and.
6178      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6179 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6180 C The system gains extra energy.
6181               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6182               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6183      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6184               n_corr=n_corr+1
6185             else if (j1.eq.j) then
6186 C Contacts I-J and I-(J+1) occur simultaneously.
6187 C The system loses extra energy.
6188 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6189             endif
6190           enddo ! kk
6191           do kk=1,num_conti
6192             j1=jcont_hb(kk,i)
6193 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6194 c    &         ' jj=',jj,' kk=',kk
6195             if (j1.eq.j+1) then
6196 C Contacts I-J and (I+1)-J occur simultaneously.
6197 C The system loses extra energy.
6198 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6199             endif ! j1==j+1
6200           enddo ! kk
6201         enddo ! jj
6202       enddo ! i
6203       return
6204       end
6205 c------------------------------------------------------------------------------
6206       subroutine add_hb_contact(ii,jj,itask)
6207       implicit real*8 (a-h,o-z)
6208       include "DIMENSIONS"
6209       include "COMMON.IOUNITS"
6210       integer max_cont
6211       integer max_dim
6212       parameter (max_cont=maxconts)
6213       parameter (max_dim=26)
6214       include "COMMON.CONTACTS"
6215       double precision zapas(max_dim,maxconts,max_fg_procs),
6216      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6217       common /przechowalnia/ zapas
6218       integer i,j,ii,jj,iproc,itask(4),nn
6219 c      write (iout,*) "itask",itask
6220       do i=1,2
6221         iproc=itask(i)
6222         if (iproc.gt.0) then
6223           do j=1,num_cont_hb(ii)
6224             jjc=jcont_hb(j,ii)
6225 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6226             if (jjc.eq.jj) then
6227               ncont_sent(iproc)=ncont_sent(iproc)+1
6228               nn=ncont_sent(iproc)
6229               zapas(1,nn,iproc)=ii
6230               zapas(2,nn,iproc)=jjc
6231               zapas(3,nn,iproc)=facont_hb(j,ii)
6232               zapas(4,nn,iproc)=ees0p(j,ii)
6233               zapas(5,nn,iproc)=ees0m(j,ii)
6234               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6235               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6236               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6237               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6238               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6239               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6240               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6241               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6242               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6243               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6244               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6245               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6246               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6247               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6248               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6249               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6250               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6251               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6252               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6253               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6254               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6255               exit
6256             endif
6257           enddo
6258         endif
6259       enddo
6260       return
6261       end
6262 c------------------------------------------------------------------------------
6263       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6264      &  n_corr1)
6265 C This subroutine calculates multi-body contributions to hydrogen-bonding
6266       implicit real*8 (a-h,o-z)
6267       include 'DIMENSIONS'
6268       include 'COMMON.IOUNITS'
6269 #ifdef MPI
6270       include "mpif.h"
6271       parameter (max_cont=maxconts)
6272       parameter (max_dim=70)
6273       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6274       double precision zapas(max_dim,maxconts,max_fg_procs),
6275      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6276       common /przechowalnia/ zapas
6277       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6278      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6279 #endif
6280       include 'COMMON.SETUP'
6281       include 'COMMON.FFIELD'
6282       include 'COMMON.DERIV'
6283       include 'COMMON.LOCAL'
6284       include 'COMMON.INTERACT'
6285       include 'COMMON.CONTACTS'
6286       include 'COMMON.CHAIN'
6287       include 'COMMON.CONTROL'
6288       double precision gx(3),gx1(3)
6289       integer num_cont_hb_old(maxres)
6290       logical lprn,ldone
6291       double precision eello4,eello5,eelo6,eello_turn6
6292       external eello4,eello5,eello6,eello_turn6
6293 C Set lprn=.true. for debugging
6294       lprn=.false.
6295       eturn6=0.0d0
6296 #ifdef MPI
6297       do i=1,nres
6298         num_cont_hb_old(i)=num_cont_hb(i)
6299       enddo
6300       n_corr=0
6301       n_corr1=0
6302       if (nfgtasks.le.1) goto 30
6303       if (lprn) then
6304         write (iout,'(a)') 'Contact function values before RECEIVE:'
6305         do i=nnt,nct-2
6306           write (iout,'(2i3,50(1x,i2,f5.2))')
6307      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6308      &    j=1,num_cont_hb(i))
6309         enddo
6310       endif
6311       call flush(iout)
6312       do i=1,ntask_cont_from
6313         ncont_recv(i)=0
6314       enddo
6315       do i=1,ntask_cont_to
6316         ncont_sent(i)=0
6317       enddo
6318 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6319 c     & ntask_cont_to
6320 C Make the list of contacts to send to send to other procesors
6321       do i=iturn3_start,iturn3_end
6322 c        write (iout,*) "make contact list turn3",i," num_cont",
6323 c     &    num_cont_hb(i)
6324         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6325       enddo
6326       do i=iturn4_start,iturn4_end
6327 c        write (iout,*) "make contact list turn4",i," num_cont",
6328 c     &   num_cont_hb(i)
6329         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6330       enddo
6331       do ii=1,nat_sent
6332         i=iat_sent(ii)
6333 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6334 c     &    num_cont_hb(i)
6335         do j=1,num_cont_hb(i)
6336         do k=1,4
6337           jjc=jcont_hb(j,i)
6338           iproc=iint_sent_local(k,jjc,ii)
6339 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6340           if (iproc.ne.0) then
6341             ncont_sent(iproc)=ncont_sent(iproc)+1
6342             nn=ncont_sent(iproc)
6343             zapas(1,nn,iproc)=i
6344             zapas(2,nn,iproc)=jjc
6345             zapas(3,nn,iproc)=d_cont(j,i)
6346             ind=3
6347             do kk=1,3
6348               ind=ind+1
6349               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6350             enddo
6351             do kk=1,2
6352               do ll=1,2
6353                 ind=ind+1
6354                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6355               enddo
6356             enddo
6357             do jj=1,5
6358               do kk=1,3
6359                 do ll=1,2
6360                   do mm=1,2
6361                     ind=ind+1
6362                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6363                   enddo
6364                 enddo
6365               enddo
6366             enddo
6367           endif
6368         enddo
6369         enddo
6370       enddo
6371       if (lprn) then
6372       write (iout,*)
6373      &  "Numbers of contacts to be sent to other processors",
6374      &  (ncont_sent(i),i=1,ntask_cont_to)
6375       write (iout,*) "Contacts sent"
6376       do ii=1,ntask_cont_to
6377         nn=ncont_sent(ii)
6378         iproc=itask_cont_to(ii)
6379         write (iout,*) nn," contacts to processor",iproc,
6380      &   " of CONT_TO_COMM group"
6381         do i=1,nn
6382           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6383         enddo
6384       enddo
6385       call flush(iout)
6386       endif
6387       CorrelType=477
6388       CorrelID=fg_rank+1
6389       CorrelType1=478
6390       CorrelID1=nfgtasks+fg_rank+1
6391       ireq=0
6392 C Receive the numbers of needed contacts from other processors
6393       do ii=1,ntask_cont_from
6394         iproc=itask_cont_from(ii)
6395         ireq=ireq+1
6396         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6397      &    FG_COMM,req(ireq),IERR)
6398       enddo
6399 c      write (iout,*) "IRECV ended"
6400 c      call flush(iout)
6401 C Send the number of contacts needed by other processors
6402       do ii=1,ntask_cont_to
6403         iproc=itask_cont_to(ii)
6404         ireq=ireq+1
6405         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6406      &    FG_COMM,req(ireq),IERR)
6407       enddo
6408 c      write (iout,*) "ISEND ended"
6409 c      write (iout,*) "number of requests (nn)",ireq
6410       call flush(iout)
6411       if (ireq.gt.0)
6412      &  call MPI_Waitall(ireq,req,status_array,ierr)
6413 c      write (iout,*)
6414 c     &  "Numbers of contacts to be received from other processors",
6415 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6416 c      call flush(iout)
6417 C Receive contacts
6418       ireq=0
6419       do ii=1,ntask_cont_from
6420         iproc=itask_cont_from(ii)
6421         nn=ncont_recv(ii)
6422 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6423 c     &   " of CONT_TO_COMM group"
6424         call flush(iout)
6425         if (nn.gt.0) then
6426           ireq=ireq+1
6427           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6428      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6429 c          write (iout,*) "ireq,req",ireq,req(ireq)
6430         endif
6431       enddo
6432 C Send the contacts to processors that need them
6433       do ii=1,ntask_cont_to
6434         iproc=itask_cont_to(ii)
6435         nn=ncont_sent(ii)
6436 c        write (iout,*) nn," contacts to processor",iproc,
6437 c     &   " of CONT_TO_COMM group"
6438         if (nn.gt.0) then
6439           ireq=ireq+1
6440           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6441      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6442 c          write (iout,*) "ireq,req",ireq,req(ireq)
6443 c          do i=1,nn
6444 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6445 c          enddo
6446         endif
6447       enddo
6448 c      write (iout,*) "number of requests (contacts)",ireq
6449 c      write (iout,*) "req",(req(i),i=1,4)
6450 c      call flush(iout)
6451       if (ireq.gt.0)
6452      & call MPI_Waitall(ireq,req,status_array,ierr)
6453       do iii=1,ntask_cont_from
6454         iproc=itask_cont_from(iii)
6455         nn=ncont_recv(iii)
6456         if (lprn) then
6457         write (iout,*) "Received",nn," contacts from processor",iproc,
6458      &   " of CONT_FROM_COMM group"
6459         call flush(iout)
6460         do i=1,nn
6461           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6462         enddo
6463         call flush(iout)
6464         endif
6465         do i=1,nn
6466           ii=zapas_recv(1,i,iii)
6467 c Flag the received contacts to prevent double-counting
6468           jj=-zapas_recv(2,i,iii)
6469 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6470 c          call flush(iout)
6471           nnn=num_cont_hb(ii)+1
6472           num_cont_hb(ii)=nnn
6473           jcont_hb(nnn,ii)=jj
6474           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6475           ind=3
6476           do kk=1,3
6477             ind=ind+1
6478             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6479           enddo
6480           do kk=1,2
6481             do ll=1,2
6482               ind=ind+1
6483               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6484             enddo
6485           enddo
6486           do jj=1,5
6487             do kk=1,3
6488               do ll=1,2
6489                 do mm=1,2
6490                   ind=ind+1
6491                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6492                 enddo
6493               enddo
6494             enddo
6495           enddo
6496         enddo
6497       enddo
6498       call flush(iout)
6499       if (lprn) then
6500         write (iout,'(a)') 'Contact function values after receive:'
6501         do i=nnt,nct-2
6502           write (iout,'(2i3,50(1x,i3,5f6.3))')
6503      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6504      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6505         enddo
6506         call flush(iout)
6507       endif
6508    30 continue
6509 #endif
6510       if (lprn) then
6511         write (iout,'(a)') 'Contact function values:'
6512         do i=nnt,nct-2
6513           write (iout,'(2i3,50(1x,i2,5f6.3))')
6514      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6515      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6516         enddo
6517       endif
6518       ecorr=0.0D0
6519       ecorr5=0.0d0
6520       ecorr6=0.0d0
6521 C Remove the loop below after debugging !!!
6522       do i=nnt,nct
6523         do j=1,3
6524           gradcorr(j,i)=0.0D0
6525           gradxorr(j,i)=0.0D0
6526         enddo
6527       enddo
6528 C Calculate the dipole-dipole interaction energies
6529       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6530       do i=iatel_s,iatel_e+1
6531         num_conti=num_cont_hb(i)
6532         do jj=1,num_conti
6533           j=jcont_hb(jj,i)
6534 #ifdef MOMENT
6535           call dipole(i,j,jj)
6536 #endif
6537         enddo
6538       enddo
6539       endif
6540 C Calculate the local-electrostatic correlation terms
6541 c                write (iout,*) "gradcorr5 in eello5 before loop"
6542 c                do iii=1,nres
6543 c                  write (iout,'(i5,3f10.5)')
6544 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6545 c                enddo
6546       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6547 c        write (iout,*) "corr loop i",i
6548         i1=i+1
6549         num_conti=num_cont_hb(i)
6550         num_conti1=num_cont_hb(i+1)
6551         do jj=1,num_conti
6552           j=jcont_hb(jj,i)
6553           jp=iabs(j)
6554           do kk=1,num_conti1
6555             j1=jcont_hb(kk,i1)
6556             jp1=iabs(j1)
6557 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6558 c     &         ' jj=',jj,' kk=',kk
6559 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6560             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6561      &          .or. j.lt.0 .and. j1.gt.0) .and.
6562      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6563 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6564 C The system gains extra energy.
6565               n_corr=n_corr+1
6566               sqd1=dsqrt(d_cont(jj,i))
6567               sqd2=dsqrt(d_cont(kk,i1))
6568               sred_geom = sqd1*sqd2
6569               IF (sred_geom.lt.cutoff_corr) THEN
6570                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6571      &            ekont,fprimcont)
6572 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6573 cd     &         ' jj=',jj,' kk=',kk
6574                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6575                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6576                 do l=1,3
6577                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6578                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6579                 enddo
6580                 n_corr1=n_corr1+1
6581 cd               write (iout,*) 'sred_geom=',sred_geom,
6582 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6583 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6584 cd               write (iout,*) "g_contij",g_contij
6585 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6586 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6587                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6588                 if (wcorr4.gt.0.0d0)
6589      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6590                   if (energy_dec.and.wcorr4.gt.0.0d0)
6591      1                 write (iout,'(a6,4i5,0pf7.3)')
6592      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6593 c                write (iout,*) "gradcorr5 before eello5"
6594 c                do iii=1,nres
6595 c                  write (iout,'(i5,3f10.5)')
6596 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6597 c                enddo
6598                 if (wcorr5.gt.0.0d0)
6599      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6600 c                write (iout,*) "gradcorr5 after eello5"
6601 c                do iii=1,nres
6602 c                  write (iout,'(i5,3f10.5)')
6603 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6604 c                enddo
6605                   if (energy_dec.and.wcorr5.gt.0.0d0)
6606      1                 write (iout,'(a6,4i5,0pf7.3)')
6607      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6608 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6609 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6610                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6611      &               .or. wturn6.eq.0.0d0))then
6612 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6613                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6614                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6615      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6616 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6617 cd     &            'ecorr6=',ecorr6
6618 cd                write (iout,'(4e15.5)') sred_geom,
6619 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6620 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6621 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6622                 else if (wturn6.gt.0.0d0
6623      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6624 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6625                   eturn6=eturn6+eello_turn6(i,jj,kk)
6626                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6627      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6628 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6629                 endif
6630               ENDIF
6631 1111          continue
6632             endif
6633           enddo ! kk
6634         enddo ! jj
6635       enddo ! i
6636       do i=1,nres
6637         num_cont_hb(i)=num_cont_hb_old(i)
6638       enddo
6639 c                write (iout,*) "gradcorr5 in eello5"
6640 c                do iii=1,nres
6641 c                  write (iout,'(i5,3f10.5)')
6642 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6643 c                enddo
6644       return
6645       end
6646 c------------------------------------------------------------------------------
6647       subroutine add_hb_contact_eello(ii,jj,itask)
6648       implicit real*8 (a-h,o-z)
6649       include "DIMENSIONS"
6650       include "COMMON.IOUNITS"
6651       integer max_cont
6652       integer max_dim
6653       parameter (max_cont=maxconts)
6654       parameter (max_dim=70)
6655       include "COMMON.CONTACTS"
6656       double precision zapas(max_dim,maxconts,max_fg_procs),
6657      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6658       common /przechowalnia/ zapas
6659       integer i,j,ii,jj,iproc,itask(4),nn
6660 c      write (iout,*) "itask",itask
6661       do i=1,2
6662         iproc=itask(i)
6663         if (iproc.gt.0) then
6664           do j=1,num_cont_hb(ii)
6665             jjc=jcont_hb(j,ii)
6666 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6667             if (jjc.eq.jj) then
6668               ncont_sent(iproc)=ncont_sent(iproc)+1
6669               nn=ncont_sent(iproc)
6670               zapas(1,nn,iproc)=ii
6671               zapas(2,nn,iproc)=jjc
6672               zapas(3,nn,iproc)=d_cont(j,ii)
6673               ind=3
6674               do kk=1,3
6675                 ind=ind+1
6676                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6677               enddo
6678               do kk=1,2
6679                 do ll=1,2
6680                   ind=ind+1
6681                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6682                 enddo
6683               enddo
6684               do jj=1,5
6685                 do kk=1,3
6686                   do ll=1,2
6687                     do mm=1,2
6688                       ind=ind+1
6689                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6690                     enddo
6691                   enddo
6692                 enddo
6693               enddo
6694               exit
6695             endif
6696           enddo
6697         endif
6698       enddo
6699       return
6700       end
6701 c------------------------------------------------------------------------------
6702       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6703       implicit real*8 (a-h,o-z)
6704       include 'DIMENSIONS'
6705       include 'COMMON.IOUNITS'
6706       include 'COMMON.DERIV'
6707       include 'COMMON.INTERACT'
6708       include 'COMMON.CONTACTS'
6709       double precision gx(3),gx1(3)
6710       logical lprn
6711       lprn=.false.
6712       eij=facont_hb(jj,i)
6713       ekl=facont_hb(kk,k)
6714       ees0pij=ees0p(jj,i)
6715       ees0pkl=ees0p(kk,k)
6716       ees0mij=ees0m(jj,i)
6717       ees0mkl=ees0m(kk,k)
6718       ekont=eij*ekl
6719       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6720 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6721 C Following 4 lines for diagnostics.
6722 cd    ees0pkl=0.0D0
6723 cd    ees0pij=1.0D0
6724 cd    ees0mkl=0.0D0
6725 cd    ees0mij=1.0D0
6726 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6727 c     & 'Contacts ',i,j,
6728 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6729 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6730 c     & 'gradcorr_long'
6731 C Calculate the multi-body contribution to energy.
6732 c      ecorr=ecorr+ekont*ees
6733 C Calculate multi-body contributions to the gradient.
6734       coeffpees0pij=coeffp*ees0pij
6735       coeffmees0mij=coeffm*ees0mij
6736       coeffpees0pkl=coeffp*ees0pkl
6737       coeffmees0mkl=coeffm*ees0mkl
6738       do ll=1,3
6739 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6740         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6741      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6742      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6743         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6744      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6745      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6746 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6747         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6748      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6749      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6750         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6751      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6752      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6753         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6754      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6755      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6756         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6757         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6758         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6759      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6760      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6761         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6762         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6763 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6764       enddo
6765 c      write (iout,*)
6766 cgrad      do m=i+1,j-1
6767 cgrad        do ll=1,3
6768 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6769 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6770 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6771 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6772 cgrad        enddo
6773 cgrad      enddo
6774 cgrad      do m=k+1,l-1
6775 cgrad        do ll=1,3
6776 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6777 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6778 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6779 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6780 cgrad        enddo
6781 cgrad      enddo
6782 c      write (iout,*) "ehbcorr",ekont*ees
6783       ehbcorr=ekont*ees
6784       return
6785       end
6786 #ifdef MOMENT
6787 C---------------------------------------------------------------------------
6788       subroutine dipole(i,j,jj)
6789       implicit real*8 (a-h,o-z)
6790       include 'DIMENSIONS'
6791       include 'COMMON.IOUNITS'
6792       include 'COMMON.CHAIN'
6793       include 'COMMON.FFIELD'
6794       include 'COMMON.DERIV'
6795       include 'COMMON.INTERACT'
6796       include 'COMMON.CONTACTS'
6797       include 'COMMON.TORSION'
6798       include 'COMMON.VAR'
6799       include 'COMMON.GEO'
6800       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6801      &  auxmat(2,2)
6802       iti1 = itortyp(itype(i+1))
6803       if (j.lt.nres-1) then
6804         itj1 = itortyp(itype(j+1))
6805       else
6806         itj1=ntortyp+1
6807       endif
6808       do iii=1,2
6809         dipi(iii,1)=Ub2(iii,i)
6810         dipderi(iii)=Ub2der(iii,i)
6811         dipi(iii,2)=b1(iii,iti1)
6812         dipj(iii,1)=Ub2(iii,j)
6813         dipderj(iii)=Ub2der(iii,j)
6814         dipj(iii,2)=b1(iii,itj1)
6815       enddo
6816       kkk=0
6817       do iii=1,2
6818         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6819         do jjj=1,2
6820           kkk=kkk+1
6821           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6822         enddo
6823       enddo
6824       do kkk=1,5
6825         do lll=1,3
6826           mmm=0
6827           do iii=1,2
6828             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6829      &        auxvec(1))
6830             do jjj=1,2
6831               mmm=mmm+1
6832               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6833             enddo
6834           enddo
6835         enddo
6836       enddo
6837       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6838       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6839       do iii=1,2
6840         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6841       enddo
6842       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6843       do iii=1,2
6844         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6845       enddo
6846       return
6847       end
6848 #endif
6849 C---------------------------------------------------------------------------
6850       subroutine calc_eello(i,j,k,l,jj,kk)
6851 C
6852 C This subroutine computes matrices and vectors needed to calculate
6853 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6854 C
6855       implicit real*8 (a-h,o-z)
6856       include 'DIMENSIONS'
6857       include 'COMMON.IOUNITS'
6858       include 'COMMON.CHAIN'
6859       include 'COMMON.DERIV'
6860       include 'COMMON.INTERACT'
6861       include 'COMMON.CONTACTS'
6862       include 'COMMON.TORSION'
6863       include 'COMMON.VAR'
6864       include 'COMMON.GEO'
6865       include 'COMMON.FFIELD'
6866       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6867      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6868       logical lprn
6869       common /kutas/ lprn
6870 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6871 cd     & ' jj=',jj,' kk=',kk
6872 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6873 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6874 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6875       do iii=1,2
6876         do jjj=1,2
6877           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6878           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6879         enddo
6880       enddo
6881       call transpose2(aa1(1,1),aa1t(1,1))
6882       call transpose2(aa2(1,1),aa2t(1,1))
6883       do kkk=1,5
6884         do lll=1,3
6885           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6886      &      aa1tder(1,1,lll,kkk))
6887           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6888      &      aa2tder(1,1,lll,kkk))
6889         enddo
6890       enddo
6891       if (l.eq.j+1) then
6892 C parallel orientation of the two CA-CA-CA frames.
6893         if (i.gt.1) then
6894           iti=itortyp(itype(i))
6895         else
6896           iti=ntortyp+1
6897         endif
6898         itk1=itortyp(itype(k+1))
6899         itj=itortyp(itype(j))
6900         if (l.lt.nres-1) then
6901           itl1=itortyp(itype(l+1))
6902         else
6903           itl1=ntortyp+1
6904         endif
6905 C A1 kernel(j+1) A2T
6906 cd        do iii=1,2
6907 cd          write (iout,'(3f10.5,5x,3f10.5)')
6908 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6909 cd        enddo
6910         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6911      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6912      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6913 C Following matrices are needed only for 6-th order cumulants
6914         IF (wcorr6.gt.0.0d0) THEN
6915         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6916      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6917      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6918         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6919      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6920      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6921      &   ADtEAderx(1,1,1,1,1,1))
6922         lprn=.false.
6923         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6924      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6925      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6926      &   ADtEA1derx(1,1,1,1,1,1))
6927         ENDIF
6928 C End 6-th order cumulants
6929 cd        lprn=.false.
6930 cd        if (lprn) then
6931 cd        write (2,*) 'In calc_eello6'
6932 cd        do iii=1,2
6933 cd          write (2,*) 'iii=',iii
6934 cd          do kkk=1,5
6935 cd            write (2,*) 'kkk=',kkk
6936 cd            do jjj=1,2
6937 cd              write (2,'(3(2f10.5),5x)')
6938 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6939 cd            enddo
6940 cd          enddo
6941 cd        enddo
6942 cd        endif
6943         call transpose2(EUgder(1,1,k),auxmat(1,1))
6944         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6945         call transpose2(EUg(1,1,k),auxmat(1,1))
6946         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6947         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6948         do iii=1,2
6949           do kkk=1,5
6950             do lll=1,3
6951               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6952      &          EAEAderx(1,1,lll,kkk,iii,1))
6953             enddo
6954           enddo
6955         enddo
6956 C A1T kernel(i+1) A2
6957         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6958      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6959      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6960 C Following matrices are needed only for 6-th order cumulants
6961         IF (wcorr6.gt.0.0d0) THEN
6962         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6963      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6964      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6965         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6966      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6967      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6968      &   ADtEAderx(1,1,1,1,1,2))
6969         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6970      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6971      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6972      &   ADtEA1derx(1,1,1,1,1,2))
6973         ENDIF
6974 C End 6-th order cumulants
6975         call transpose2(EUgder(1,1,l),auxmat(1,1))
6976         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6977         call transpose2(EUg(1,1,l),auxmat(1,1))
6978         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6979         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6980         do iii=1,2
6981           do kkk=1,5
6982             do lll=1,3
6983               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6984      &          EAEAderx(1,1,lll,kkk,iii,2))
6985             enddo
6986           enddo
6987         enddo
6988 C AEAb1 and AEAb2
6989 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6990 C They are needed only when the fifth- or the sixth-order cumulants are
6991 C indluded.
6992         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6993         call transpose2(AEA(1,1,1),auxmat(1,1))
6994         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6995         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6996         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6997         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6998         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6999         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7000         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7001         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7002         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7003         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7004         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7005         call transpose2(AEA(1,1,2),auxmat(1,1))
7006         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7007         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7008         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7009         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7010         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7011         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7012         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7013         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7014         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7015         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7016         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7017 C Calculate the Cartesian derivatives of the vectors.
7018         do iii=1,2
7019           do kkk=1,5
7020             do lll=1,3
7021               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7022               call matvec2(auxmat(1,1),b1(1,iti),
7023      &          AEAb1derx(1,lll,kkk,iii,1,1))
7024               call matvec2(auxmat(1,1),Ub2(1,i),
7025      &          AEAb2derx(1,lll,kkk,iii,1,1))
7026               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7027      &          AEAb1derx(1,lll,kkk,iii,2,1))
7028               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7029      &          AEAb2derx(1,lll,kkk,iii,2,1))
7030               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7031               call matvec2(auxmat(1,1),b1(1,itj),
7032      &          AEAb1derx(1,lll,kkk,iii,1,2))
7033               call matvec2(auxmat(1,1),Ub2(1,j),
7034      &          AEAb2derx(1,lll,kkk,iii,1,2))
7035               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7036      &          AEAb1derx(1,lll,kkk,iii,2,2))
7037               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7038      &          AEAb2derx(1,lll,kkk,iii,2,2))
7039             enddo
7040           enddo
7041         enddo
7042         ENDIF
7043 C End vectors
7044       else
7045 C Antiparallel orientation of the two CA-CA-CA frames.
7046         if (i.gt.1) then
7047           iti=itortyp(itype(i))
7048         else
7049           iti=ntortyp+1
7050         endif
7051         itk1=itortyp(itype(k+1))
7052         itl=itortyp(itype(l))
7053         itj=itortyp(itype(j))
7054         if (j.lt.nres-1) then
7055           itj1=itortyp(itype(j+1))
7056         else
7057           itj1=ntortyp+1
7058         endif
7059 C A2 kernel(j-1)T A1T
7060         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7061      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7062      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7063 C Following matrices are needed only for 6-th order cumulants
7064         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7065      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7066         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7067      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7068      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7069         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7070      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7071      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7072      &   ADtEAderx(1,1,1,1,1,1))
7073         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7074      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7075      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7076      &   ADtEA1derx(1,1,1,1,1,1))
7077         ENDIF
7078 C End 6-th order cumulants
7079         call transpose2(EUgder(1,1,k),auxmat(1,1))
7080         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7081         call transpose2(EUg(1,1,k),auxmat(1,1))
7082         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7083         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7084         do iii=1,2
7085           do kkk=1,5
7086             do lll=1,3
7087               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7088      &          EAEAderx(1,1,lll,kkk,iii,1))
7089             enddo
7090           enddo
7091         enddo
7092 C A2T kernel(i+1)T A1
7093         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7094      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7095      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7096 C Following matrices are needed only for 6-th order cumulants
7097         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7098      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7099         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7100      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7101      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7102         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7103      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7104      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7105      &   ADtEAderx(1,1,1,1,1,2))
7106         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7107      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7108      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7109      &   ADtEA1derx(1,1,1,1,1,2))
7110         ENDIF
7111 C End 6-th order cumulants
7112         call transpose2(EUgder(1,1,j),auxmat(1,1))
7113         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7114         call transpose2(EUg(1,1,j),auxmat(1,1))
7115         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7116         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7117         do iii=1,2
7118           do kkk=1,5
7119             do lll=1,3
7120               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7121      &          EAEAderx(1,1,lll,kkk,iii,2))
7122             enddo
7123           enddo
7124         enddo
7125 C AEAb1 and AEAb2
7126 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7127 C They are needed only when the fifth- or the sixth-order cumulants are
7128 C indluded.
7129         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7130      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7131         call transpose2(AEA(1,1,1),auxmat(1,1))
7132         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7133         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7134         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7135         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7136         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7137         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7138         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7139         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7140         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7141         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7142         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7143         call transpose2(AEA(1,1,2),auxmat(1,1))
7144         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7145         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7146         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7147         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7148         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7149         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7150         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7151         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7152         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7153         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7154         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7155 C Calculate the Cartesian derivatives of the vectors.
7156         do iii=1,2
7157           do kkk=1,5
7158             do lll=1,3
7159               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7160               call matvec2(auxmat(1,1),b1(1,iti),
7161      &          AEAb1derx(1,lll,kkk,iii,1,1))
7162               call matvec2(auxmat(1,1),Ub2(1,i),
7163      &          AEAb2derx(1,lll,kkk,iii,1,1))
7164               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7165      &          AEAb1derx(1,lll,kkk,iii,2,1))
7166               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7167      &          AEAb2derx(1,lll,kkk,iii,2,1))
7168               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7169               call matvec2(auxmat(1,1),b1(1,itl),
7170      &          AEAb1derx(1,lll,kkk,iii,1,2))
7171               call matvec2(auxmat(1,1),Ub2(1,l),
7172      &          AEAb2derx(1,lll,kkk,iii,1,2))
7173               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7174      &          AEAb1derx(1,lll,kkk,iii,2,2))
7175               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7176      &          AEAb2derx(1,lll,kkk,iii,2,2))
7177             enddo
7178           enddo
7179         enddo
7180         ENDIF
7181 C End vectors
7182       endif
7183       return
7184       end
7185 C---------------------------------------------------------------------------
7186       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7187      &  KK,KKderg,AKA,AKAderg,AKAderx)
7188       implicit none
7189       integer nderg
7190       logical transp
7191       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7192      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7193      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7194       integer iii,kkk,lll
7195       integer jjj,mmm
7196       logical lprn
7197       common /kutas/ lprn
7198       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7199       do iii=1,nderg
7200         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7201      &    AKAderg(1,1,iii))
7202       enddo
7203 cd      if (lprn) write (2,*) 'In kernel'
7204       do kkk=1,5
7205 cd        if (lprn) write (2,*) 'kkk=',kkk
7206         do lll=1,3
7207           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7208      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7209 cd          if (lprn) then
7210 cd            write (2,*) 'lll=',lll
7211 cd            write (2,*) 'iii=1'
7212 cd            do jjj=1,2
7213 cd              write (2,'(3(2f10.5),5x)')
7214 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7215 cd            enddo
7216 cd          endif
7217           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7218      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7219 cd          if (lprn) then
7220 cd            write (2,*) 'lll=',lll
7221 cd            write (2,*) 'iii=2'
7222 cd            do jjj=1,2
7223 cd              write (2,'(3(2f10.5),5x)')
7224 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7225 cd            enddo
7226 cd          endif
7227         enddo
7228       enddo
7229       return
7230       end
7231 C---------------------------------------------------------------------------
7232       double precision function eello4(i,j,k,l,jj,kk)
7233       implicit real*8 (a-h,o-z)
7234       include 'DIMENSIONS'
7235       include 'COMMON.IOUNITS'
7236       include 'COMMON.CHAIN'
7237       include 'COMMON.DERIV'
7238       include 'COMMON.INTERACT'
7239       include 'COMMON.CONTACTS'
7240       include 'COMMON.TORSION'
7241       include 'COMMON.VAR'
7242       include 'COMMON.GEO'
7243       double precision pizda(2,2),ggg1(3),ggg2(3)
7244 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7245 cd        eello4=0.0d0
7246 cd        return
7247 cd      endif
7248 cd      print *,'eello4:',i,j,k,l,jj,kk
7249 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7250 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7251 cold      eij=facont_hb(jj,i)
7252 cold      ekl=facont_hb(kk,k)
7253 cold      ekont=eij*ekl
7254       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7255 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7256       gcorr_loc(k-1)=gcorr_loc(k-1)
7257      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7258       if (l.eq.j+1) then
7259         gcorr_loc(l-1)=gcorr_loc(l-1)
7260      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7261       else
7262         gcorr_loc(j-1)=gcorr_loc(j-1)
7263      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7264       endif
7265       do iii=1,2
7266         do kkk=1,5
7267           do lll=1,3
7268             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7269      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7270 cd            derx(lll,kkk,iii)=0.0d0
7271           enddo
7272         enddo
7273       enddo
7274 cd      gcorr_loc(l-1)=0.0d0
7275 cd      gcorr_loc(j-1)=0.0d0
7276 cd      gcorr_loc(k-1)=0.0d0
7277 cd      eel4=1.0d0
7278 cd      write (iout,*)'Contacts have occurred for peptide groups',
7279 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7280 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7281       if (j.lt.nres-1) then
7282         j1=j+1
7283         j2=j-1
7284       else
7285         j1=j-1
7286         j2=j-2
7287       endif
7288       if (l.lt.nres-1) then
7289         l1=l+1
7290         l2=l-1
7291       else
7292         l1=l-1
7293         l2=l-2
7294       endif
7295       do ll=1,3
7296 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7297 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7298         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7299         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7300 cgrad        ghalf=0.5d0*ggg1(ll)
7301         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7302         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7303         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7304         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7305         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7306         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7307 cgrad        ghalf=0.5d0*ggg2(ll)
7308         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7309         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7310         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7311         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7312         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7313         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7314       enddo
7315 cgrad      do m=i+1,j-1
7316 cgrad        do ll=1,3
7317 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7318 cgrad        enddo
7319 cgrad      enddo
7320 cgrad      do m=k+1,l-1
7321 cgrad        do ll=1,3
7322 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7323 cgrad        enddo
7324 cgrad      enddo
7325 cgrad      do m=i+2,j2
7326 cgrad        do ll=1,3
7327 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7328 cgrad        enddo
7329 cgrad      enddo
7330 cgrad      do m=k+2,l2
7331 cgrad        do ll=1,3
7332 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7333 cgrad        enddo
7334 cgrad      enddo
7335 cd      do iii=1,nres-3
7336 cd        write (2,*) iii,gcorr_loc(iii)
7337 cd      enddo
7338       eello4=ekont*eel4
7339 cd      write (2,*) 'ekont',ekont
7340 cd      write (iout,*) 'eello4',ekont*eel4
7341       return
7342       end
7343 C---------------------------------------------------------------------------
7344       double precision function eello5(i,j,k,l,jj,kk)
7345       implicit real*8 (a-h,o-z)
7346       include 'DIMENSIONS'
7347       include 'COMMON.IOUNITS'
7348       include 'COMMON.CHAIN'
7349       include 'COMMON.DERIV'
7350       include 'COMMON.INTERACT'
7351       include 'COMMON.CONTACTS'
7352       include 'COMMON.TORSION'
7353       include 'COMMON.VAR'
7354       include 'COMMON.GEO'
7355       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7356       double precision ggg1(3),ggg2(3)
7357 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7358 C                                                                              C
7359 C                            Parallel chains                                   C
7360 C                                                                              C
7361 C          o             o                   o             o                   C
7362 C         /l\           / \             \   / \           / \   /              C
7363 C        /   \         /   \             \ /   \         /   \ /               C
7364 C       j| o |l1       | o |              o| o |         | o |o                C
7365 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7366 C      \i/   \         /   \ /             /   \         /   \                 C
7367 C       o    k1             o                                                  C
7368 C         (I)          (II)                (III)          (IV)                 C
7369 C                                                                              C
7370 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7371 C                                                                              C
7372 C                            Antiparallel chains                               C
7373 C                                                                              C
7374 C          o             o                   o             o                   C
7375 C         /j\           / \             \   / \           / \   /              C
7376 C        /   \         /   \             \ /   \         /   \ /               C
7377 C      j1| o |l        | o |              o| o |         | o |o                C
7378 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7379 C      \i/   \         /   \ /             /   \         /   \                 C
7380 C       o     k1            o                                                  C
7381 C         (I)          (II)                (III)          (IV)                 C
7382 C                                                                              C
7383 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7384 C                                                                              C
7385 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7386 C                                                                              C
7387 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7388 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7389 cd        eello5=0.0d0
7390 cd        return
7391 cd      endif
7392 cd      write (iout,*)
7393 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7394 cd     &   ' and',k,l
7395       itk=itortyp(itype(k))
7396       itl=itortyp(itype(l))
7397       itj=itortyp(itype(j))
7398       eello5_1=0.0d0
7399       eello5_2=0.0d0
7400       eello5_3=0.0d0
7401       eello5_4=0.0d0
7402 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7403 cd     &   eel5_3_num,eel5_4_num)
7404       do iii=1,2
7405         do kkk=1,5
7406           do lll=1,3
7407             derx(lll,kkk,iii)=0.0d0
7408           enddo
7409         enddo
7410       enddo
7411 cd      eij=facont_hb(jj,i)
7412 cd      ekl=facont_hb(kk,k)
7413 cd      ekont=eij*ekl
7414 cd      write (iout,*)'Contacts have occurred for peptide groups',
7415 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7416 cd      goto 1111
7417 C Contribution from the graph I.
7418 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7419 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7420       call transpose2(EUg(1,1,k),auxmat(1,1))
7421       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7422       vv(1)=pizda(1,1)-pizda(2,2)
7423       vv(2)=pizda(1,2)+pizda(2,1)
7424       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7425      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7426 C Explicit gradient in virtual-dihedral angles.
7427       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7428      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7429      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7430       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7431       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7432       vv(1)=pizda(1,1)-pizda(2,2)
7433       vv(2)=pizda(1,2)+pizda(2,1)
7434       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7435      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7436      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7437       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7438       vv(1)=pizda(1,1)-pizda(2,2)
7439       vv(2)=pizda(1,2)+pizda(2,1)
7440       if (l.eq.j+1) then
7441         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7442      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7443      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7444       else
7445         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7446      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7447      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7448       endif
7449 C Cartesian gradient
7450       do iii=1,2
7451         do kkk=1,5
7452           do lll=1,3
7453             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7454      &        pizda(1,1))
7455             vv(1)=pizda(1,1)-pizda(2,2)
7456             vv(2)=pizda(1,2)+pizda(2,1)
7457             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7458      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7459      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7460           enddo
7461         enddo
7462       enddo
7463 c      goto 1112
7464 c1111  continue
7465 C Contribution from graph II
7466       call transpose2(EE(1,1,itk),auxmat(1,1))
7467       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7468       vv(1)=pizda(1,1)+pizda(2,2)
7469       vv(2)=pizda(2,1)-pizda(1,2)
7470       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7471      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7472 C Explicit gradient in virtual-dihedral angles.
7473       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7474      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7475       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7476       vv(1)=pizda(1,1)+pizda(2,2)
7477       vv(2)=pizda(2,1)-pizda(1,2)
7478       if (l.eq.j+1) then
7479         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7480      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7481      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7482       else
7483         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7484      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7485      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7486       endif
7487 C Cartesian gradient
7488       do iii=1,2
7489         do kkk=1,5
7490           do lll=1,3
7491             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7492      &        pizda(1,1))
7493             vv(1)=pizda(1,1)+pizda(2,2)
7494             vv(2)=pizda(2,1)-pizda(1,2)
7495             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7496      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7497      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7498           enddo
7499         enddo
7500       enddo
7501 cd      goto 1112
7502 cd1111  continue
7503       if (l.eq.j+1) then
7504 cd        goto 1110
7505 C Parallel orientation
7506 C Contribution from graph III
7507         call transpose2(EUg(1,1,l),auxmat(1,1))
7508         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7509         vv(1)=pizda(1,1)-pizda(2,2)
7510         vv(2)=pizda(1,2)+pizda(2,1)
7511         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7512      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7513 C Explicit gradient in virtual-dihedral angles.
7514         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7515      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7516      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7517         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7518         vv(1)=pizda(1,1)-pizda(2,2)
7519         vv(2)=pizda(1,2)+pizda(2,1)
7520         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7521      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7522      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7523         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7524         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7525         vv(1)=pizda(1,1)-pizda(2,2)
7526         vv(2)=pizda(1,2)+pizda(2,1)
7527         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7528      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7529      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7530 C Cartesian gradient
7531         do iii=1,2
7532           do kkk=1,5
7533             do lll=1,3
7534               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7535      &          pizda(1,1))
7536               vv(1)=pizda(1,1)-pizda(2,2)
7537               vv(2)=pizda(1,2)+pizda(2,1)
7538               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7539      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7540      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7541             enddo
7542           enddo
7543         enddo
7544 cd        goto 1112
7545 C Contribution from graph IV
7546 cd1110    continue
7547         call transpose2(EE(1,1,itl),auxmat(1,1))
7548         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7549         vv(1)=pizda(1,1)+pizda(2,2)
7550         vv(2)=pizda(2,1)-pizda(1,2)
7551         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7552      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7553 C Explicit gradient in virtual-dihedral angles.
7554         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7555      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7556         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7557         vv(1)=pizda(1,1)+pizda(2,2)
7558         vv(2)=pizda(2,1)-pizda(1,2)
7559         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7560      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7561      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7562 C Cartesian gradient
7563         do iii=1,2
7564           do kkk=1,5
7565             do lll=1,3
7566               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7567      &          pizda(1,1))
7568               vv(1)=pizda(1,1)+pizda(2,2)
7569               vv(2)=pizda(2,1)-pizda(1,2)
7570               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7571      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7572      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7573             enddo
7574           enddo
7575         enddo
7576       else
7577 C Antiparallel orientation
7578 C Contribution from graph III
7579 c        goto 1110
7580         call transpose2(EUg(1,1,j),auxmat(1,1))
7581         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7582         vv(1)=pizda(1,1)-pizda(2,2)
7583         vv(2)=pizda(1,2)+pizda(2,1)
7584         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7585      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7586 C Explicit gradient in virtual-dihedral angles.
7587         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7588      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7589      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7590         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7591         vv(1)=pizda(1,1)-pizda(2,2)
7592         vv(2)=pizda(1,2)+pizda(2,1)
7593         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7594      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7595      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7596         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7597         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7598         vv(1)=pizda(1,1)-pizda(2,2)
7599         vv(2)=pizda(1,2)+pizda(2,1)
7600         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7601      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7602      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7603 C Cartesian gradient
7604         do iii=1,2
7605           do kkk=1,5
7606             do lll=1,3
7607               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7608      &          pizda(1,1))
7609               vv(1)=pizda(1,1)-pizda(2,2)
7610               vv(2)=pizda(1,2)+pizda(2,1)
7611               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7612      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7613      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7614             enddo
7615           enddo
7616         enddo
7617 cd        goto 1112
7618 C Contribution from graph IV
7619 1110    continue
7620         call transpose2(EE(1,1,itj),auxmat(1,1))
7621         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7622         vv(1)=pizda(1,1)+pizda(2,2)
7623         vv(2)=pizda(2,1)-pizda(1,2)
7624         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7625      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7626 C Explicit gradient in virtual-dihedral angles.
7627         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7628      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7629         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7630         vv(1)=pizda(1,1)+pizda(2,2)
7631         vv(2)=pizda(2,1)-pizda(1,2)
7632         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7633      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7634      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7635 C Cartesian gradient
7636         do iii=1,2
7637           do kkk=1,5
7638             do lll=1,3
7639               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7640      &          pizda(1,1))
7641               vv(1)=pizda(1,1)+pizda(2,2)
7642               vv(2)=pizda(2,1)-pizda(1,2)
7643               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7644      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7645      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7646             enddo
7647           enddo
7648         enddo
7649       endif
7650 1112  continue
7651       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7652 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7653 cd        write (2,*) 'ijkl',i,j,k,l
7654 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7655 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7656 cd      endif
7657 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7658 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7659 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7660 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7661       if (j.lt.nres-1) then
7662         j1=j+1
7663         j2=j-1
7664       else
7665         j1=j-1
7666         j2=j-2
7667       endif
7668       if (l.lt.nres-1) then
7669         l1=l+1
7670         l2=l-1
7671       else
7672         l1=l-1
7673         l2=l-2
7674       endif
7675 cd      eij=1.0d0
7676 cd      ekl=1.0d0
7677 cd      ekont=1.0d0
7678 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7679 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7680 C        summed up outside the subrouine as for the other subroutines
7681 C        handling long-range interactions. The old code is commented out
7682 C        with "cgrad" to keep track of changes.
7683       do ll=1,3
7684 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7685 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7686         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7687         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7688 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7689 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7690 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7691 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7692 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7693 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7694 c     &   gradcorr5ij,
7695 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7696 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7697 cgrad        ghalf=0.5d0*ggg1(ll)
7698 cd        ghalf=0.0d0
7699         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7700         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7701         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7702         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7703         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7704         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7705 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7706 cgrad        ghalf=0.5d0*ggg2(ll)
7707 cd        ghalf=0.0d0
7708         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7709         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7710         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7711         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7712         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7713         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7714       enddo
7715 cd      goto 1112
7716 cgrad      do m=i+1,j-1
7717 cgrad        do ll=1,3
7718 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7719 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7720 cgrad        enddo
7721 cgrad      enddo
7722 cgrad      do m=k+1,l-1
7723 cgrad        do ll=1,3
7724 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7725 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7726 cgrad        enddo
7727 cgrad      enddo
7728 c1112  continue
7729 cgrad      do m=i+2,j2
7730 cgrad        do ll=1,3
7731 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7732 cgrad        enddo
7733 cgrad      enddo
7734 cgrad      do m=k+2,l2
7735 cgrad        do ll=1,3
7736 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7737 cgrad        enddo
7738 cgrad      enddo
7739 cd      do iii=1,nres-3
7740 cd        write (2,*) iii,g_corr5_loc(iii)
7741 cd      enddo
7742       eello5=ekont*eel5
7743 cd      write (2,*) 'ekont',ekont
7744 cd      write (iout,*) 'eello5',ekont*eel5
7745       return
7746       end
7747 c--------------------------------------------------------------------------
7748       double precision function eello6(i,j,k,l,jj,kk)
7749       implicit real*8 (a-h,o-z)
7750       include 'DIMENSIONS'
7751       include 'COMMON.IOUNITS'
7752       include 'COMMON.CHAIN'
7753       include 'COMMON.DERIV'
7754       include 'COMMON.INTERACT'
7755       include 'COMMON.CONTACTS'
7756       include 'COMMON.TORSION'
7757       include 'COMMON.VAR'
7758       include 'COMMON.GEO'
7759       include 'COMMON.FFIELD'
7760       double precision ggg1(3),ggg2(3)
7761 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7762 cd        eello6=0.0d0
7763 cd        return
7764 cd      endif
7765 cd      write (iout,*)
7766 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7767 cd     &   ' and',k,l
7768       eello6_1=0.0d0
7769       eello6_2=0.0d0
7770       eello6_3=0.0d0
7771       eello6_4=0.0d0
7772       eello6_5=0.0d0
7773       eello6_6=0.0d0
7774 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7775 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7776       do iii=1,2
7777         do kkk=1,5
7778           do lll=1,3
7779             derx(lll,kkk,iii)=0.0d0
7780           enddo
7781         enddo
7782       enddo
7783 cd      eij=facont_hb(jj,i)
7784 cd      ekl=facont_hb(kk,k)
7785 cd      ekont=eij*ekl
7786 cd      eij=1.0d0
7787 cd      ekl=1.0d0
7788 cd      ekont=1.0d0
7789       if (l.eq.j+1) then
7790         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7791         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7792         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7793         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7794         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7795         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7796       else
7797         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7798         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7799         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7800         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7801         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7802           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7803         else
7804           eello6_5=0.0d0
7805         endif
7806         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7807       endif
7808 C If turn contributions are considered, they will be handled separately.
7809       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7810 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7811 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7812 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7813 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7814 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7815 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7816 cd      goto 1112
7817       if (j.lt.nres-1) then
7818         j1=j+1
7819         j2=j-1
7820       else
7821         j1=j-1
7822         j2=j-2
7823       endif
7824       if (l.lt.nres-1) then
7825         l1=l+1
7826         l2=l-1
7827       else
7828         l1=l-1
7829         l2=l-2
7830       endif
7831       do ll=1,3
7832 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7833 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7834 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7835 cgrad        ghalf=0.5d0*ggg1(ll)
7836 cd        ghalf=0.0d0
7837         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7838         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7839         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7840         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7841         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7842         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7843         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7844         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7845 cgrad        ghalf=0.5d0*ggg2(ll)
7846 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7847 cd        ghalf=0.0d0
7848         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7849         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7850         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7851         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7852         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7853         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7854       enddo
7855 cd      goto 1112
7856 cgrad      do m=i+1,j-1
7857 cgrad        do ll=1,3
7858 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7859 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7860 cgrad        enddo
7861 cgrad      enddo
7862 cgrad      do m=k+1,l-1
7863 cgrad        do ll=1,3
7864 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7865 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7866 cgrad        enddo
7867 cgrad      enddo
7868 cgrad1112  continue
7869 cgrad      do m=i+2,j2
7870 cgrad        do ll=1,3
7871 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7872 cgrad        enddo
7873 cgrad      enddo
7874 cgrad      do m=k+2,l2
7875 cgrad        do ll=1,3
7876 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7877 cgrad        enddo
7878 cgrad      enddo
7879 cd      do iii=1,nres-3
7880 cd        write (2,*) iii,g_corr6_loc(iii)
7881 cd      enddo
7882       eello6=ekont*eel6
7883 cd      write (2,*) 'ekont',ekont
7884 cd      write (iout,*) 'eello6',ekont*eel6
7885       return
7886       end
7887 c--------------------------------------------------------------------------
7888       double precision function eello6_graph1(i,j,k,l,imat,swap)
7889       implicit real*8 (a-h,o-z)
7890       include 'DIMENSIONS'
7891       include 'COMMON.IOUNITS'
7892       include 'COMMON.CHAIN'
7893       include 'COMMON.DERIV'
7894       include 'COMMON.INTERACT'
7895       include 'COMMON.CONTACTS'
7896       include 'COMMON.TORSION'
7897       include 'COMMON.VAR'
7898       include 'COMMON.GEO'
7899       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7900       logical swap
7901       logical lprn
7902       common /kutas/ lprn
7903 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7904 C                                                                              C
7905 C      Parallel       Antiparallel                                             C
7906 C                                                                              C
7907 C          o             o                                                     C
7908 C         /l\           /j\                                                    C
7909 C        /   \         /   \                                                   C
7910 C       /| o |         | o |\                                                  C
7911 C     \ j|/k\|  /   \  |/k\|l /                                                C
7912 C      \ /   \ /     \ /   \ /                                                 C
7913 C       o     o       o     o                                                  C
7914 C       i             i                                                        C
7915 C                                                                              C
7916 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7917       itk=itortyp(itype(k))
7918       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7919       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7920       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7921       call transpose2(EUgC(1,1,k),auxmat(1,1))
7922       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7923       vv1(1)=pizda1(1,1)-pizda1(2,2)
7924       vv1(2)=pizda1(1,2)+pizda1(2,1)
7925       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7926       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7927       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7928       s5=scalar2(vv(1),Dtobr2(1,i))
7929 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7930       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7931       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7932      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7933      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7934      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7935      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7936      & +scalar2(vv(1),Dtobr2der(1,i)))
7937       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7938       vv1(1)=pizda1(1,1)-pizda1(2,2)
7939       vv1(2)=pizda1(1,2)+pizda1(2,1)
7940       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7941       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7942       if (l.eq.j+1) then
7943         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7944      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7945      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7946      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7947      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7948       else
7949         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7950      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7951      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7952      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7953      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7954       endif
7955       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7956       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7957       vv1(1)=pizda1(1,1)-pizda1(2,2)
7958       vv1(2)=pizda1(1,2)+pizda1(2,1)
7959       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7960      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7961      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7962      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7963       do iii=1,2
7964         if (swap) then
7965           ind=3-iii
7966         else
7967           ind=iii
7968         endif
7969         do kkk=1,5
7970           do lll=1,3
7971             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7972             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7973             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7974             call transpose2(EUgC(1,1,k),auxmat(1,1))
7975             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7976      &        pizda1(1,1))
7977             vv1(1)=pizda1(1,1)-pizda1(2,2)
7978             vv1(2)=pizda1(1,2)+pizda1(2,1)
7979             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7980             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7981      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7982             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7983      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7984             s5=scalar2(vv(1),Dtobr2(1,i))
7985             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7986           enddo
7987         enddo
7988       enddo
7989       return
7990       end
7991 c----------------------------------------------------------------------------
7992       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7993       implicit real*8 (a-h,o-z)
7994       include 'DIMENSIONS'
7995       include 'COMMON.IOUNITS'
7996       include 'COMMON.CHAIN'
7997       include 'COMMON.DERIV'
7998       include 'COMMON.INTERACT'
7999       include 'COMMON.CONTACTS'
8000       include 'COMMON.TORSION'
8001       include 'COMMON.VAR'
8002       include 'COMMON.GEO'
8003       logical swap
8004       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8005      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8006       logical lprn
8007       common /kutas/ lprn
8008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8009 C                                                                              C
8010 C      Parallel       Antiparallel                                             C
8011 C                                                                              C
8012 C          o             o                                                     C
8013 C     \   /l\           /j\   /                                                C
8014 C      \ /   \         /   \ /                                                 C
8015 C       o| o |         | o |o                                                  C
8016 C     \ j|/k\|      \  |/k\|l                                                  C
8017 C      \ /   \       \ /   \                                                   C
8018 C       o             o                                                        C
8019 C       i             i                                                        C
8020 C                                                                              C
8021 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8022 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8023 C AL 7/4/01 s1 would occur in the sixth-order moment,
8024 C           but not in a cluster cumulant
8025 #ifdef MOMENT
8026       s1=dip(1,jj,i)*dip(1,kk,k)
8027 #endif
8028       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8029       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8030       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8031       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8032       call transpose2(EUg(1,1,k),auxmat(1,1))
8033       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8034       vv(1)=pizda(1,1)-pizda(2,2)
8035       vv(2)=pizda(1,2)+pizda(2,1)
8036       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8037 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8038 #ifdef MOMENT
8039       eello6_graph2=-(s1+s2+s3+s4)
8040 #else
8041       eello6_graph2=-(s2+s3+s4)
8042 #endif
8043 c      eello6_graph2=-s3
8044 C Derivatives in gamma(i-1)
8045       if (i.gt.1) then
8046 #ifdef MOMENT
8047         s1=dipderg(1,jj,i)*dip(1,kk,k)
8048 #endif
8049         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8050         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8051         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8052         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8053 #ifdef MOMENT
8054         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8055 #else
8056         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8057 #endif
8058 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8059       endif
8060 C Derivatives in gamma(k-1)
8061 #ifdef MOMENT
8062       s1=dip(1,jj,i)*dipderg(1,kk,k)
8063 #endif
8064       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8065       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8066       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8067       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8068       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8069       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8070       vv(1)=pizda(1,1)-pizda(2,2)
8071       vv(2)=pizda(1,2)+pizda(2,1)
8072       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8073 #ifdef MOMENT
8074       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8075 #else
8076       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8077 #endif
8078 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8079 C Derivatives in gamma(j-1) or gamma(l-1)
8080       if (j.gt.1) then
8081 #ifdef MOMENT
8082         s1=dipderg(3,jj,i)*dip(1,kk,k)
8083 #endif
8084         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8085         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8086         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8087         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8088         vv(1)=pizda(1,1)-pizda(2,2)
8089         vv(2)=pizda(1,2)+pizda(2,1)
8090         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8091 #ifdef MOMENT
8092         if (swap) then
8093           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8094         else
8095           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8096         endif
8097 #endif
8098         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8099 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8100       endif
8101 C Derivatives in gamma(l-1) or gamma(j-1)
8102       if (l.gt.1) then
8103 #ifdef MOMENT
8104         s1=dip(1,jj,i)*dipderg(3,kk,k)
8105 #endif
8106         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8107         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8108         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8109         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8110         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8111         vv(1)=pizda(1,1)-pizda(2,2)
8112         vv(2)=pizda(1,2)+pizda(2,1)
8113         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8114 #ifdef MOMENT
8115         if (swap) then
8116           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8117         else
8118           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8119         endif
8120 #endif
8121         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8122 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8123       endif
8124 C Cartesian derivatives.
8125       if (lprn) then
8126         write (2,*) 'In eello6_graph2'
8127         do iii=1,2
8128           write (2,*) 'iii=',iii
8129           do kkk=1,5
8130             write (2,*) 'kkk=',kkk
8131             do jjj=1,2
8132               write (2,'(3(2f10.5),5x)')
8133      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8134             enddo
8135           enddo
8136         enddo
8137       endif
8138       do iii=1,2
8139         do kkk=1,5
8140           do lll=1,3
8141 #ifdef MOMENT
8142             if (iii.eq.1) then
8143               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8144             else
8145               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8146             endif
8147 #endif
8148             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8149      &        auxvec(1))
8150             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8151             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8152      &        auxvec(1))
8153             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8154             call transpose2(EUg(1,1,k),auxmat(1,1))
8155             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8156      &        pizda(1,1))
8157             vv(1)=pizda(1,1)-pizda(2,2)
8158             vv(2)=pizda(1,2)+pizda(2,1)
8159             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8160 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8161 #ifdef MOMENT
8162             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8163 #else
8164             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8165 #endif
8166             if (swap) then
8167               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8168             else
8169               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8170             endif
8171           enddo
8172         enddo
8173       enddo
8174       return
8175       end
8176 c----------------------------------------------------------------------------
8177       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8178       implicit real*8 (a-h,o-z)
8179       include 'DIMENSIONS'
8180       include 'COMMON.IOUNITS'
8181       include 'COMMON.CHAIN'
8182       include 'COMMON.DERIV'
8183       include 'COMMON.INTERACT'
8184       include 'COMMON.CONTACTS'
8185       include 'COMMON.TORSION'
8186       include 'COMMON.VAR'
8187       include 'COMMON.GEO'
8188       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8189       logical swap
8190 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8191 C                                                                              C
8192 C      Parallel       Antiparallel                                             C
8193 C                                                                              C
8194 C          o             o                                                     C
8195 C         /l\   /   \   /j\                                                    C
8196 C        /   \ /     \ /   \                                                   C
8197 C       /| o |o       o| o |\                                                  C
8198 C       j|/k\|  /      |/k\|l /                                                C
8199 C        /   \ /       /   \ /                                                 C
8200 C       /     o       /     o                                                  C
8201 C       i             i                                                        C
8202 C                                                                              C
8203 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8204 C
8205 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8206 C           energy moment and not to the cluster cumulant.
8207       iti=itortyp(itype(i))
8208       if (j.lt.nres-1) then
8209         itj1=itortyp(itype(j+1))
8210       else
8211         itj1=ntortyp+1
8212       endif
8213       itk=itortyp(itype(k))
8214       itk1=itortyp(itype(k+1))
8215       if (l.lt.nres-1) then
8216         itl1=itortyp(itype(l+1))
8217       else
8218         itl1=ntortyp+1
8219       endif
8220 #ifdef MOMENT
8221       s1=dip(4,jj,i)*dip(4,kk,k)
8222 #endif
8223       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8224       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8225       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8226       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8227       call transpose2(EE(1,1,itk),auxmat(1,1))
8228       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8229       vv(1)=pizda(1,1)+pizda(2,2)
8230       vv(2)=pizda(2,1)-pizda(1,2)
8231       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8232 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8233 cd     & "sum",-(s2+s3+s4)
8234 #ifdef MOMENT
8235       eello6_graph3=-(s1+s2+s3+s4)
8236 #else
8237       eello6_graph3=-(s2+s3+s4)
8238 #endif
8239 c      eello6_graph3=-s4
8240 C Derivatives in gamma(k-1)
8241       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8242       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8243       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8244       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8245 C Derivatives in gamma(l-1)
8246       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8247       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8248       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8249       vv(1)=pizda(1,1)+pizda(2,2)
8250       vv(2)=pizda(2,1)-pizda(1,2)
8251       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8252       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8253 C Cartesian derivatives.
8254       do iii=1,2
8255         do kkk=1,5
8256           do lll=1,3
8257 #ifdef MOMENT
8258             if (iii.eq.1) then
8259               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8260             else
8261               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8262             endif
8263 #endif
8264             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8265      &        auxvec(1))
8266             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8267             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8268      &        auxvec(1))
8269             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8270             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8271      &        pizda(1,1))
8272             vv(1)=pizda(1,1)+pizda(2,2)
8273             vv(2)=pizda(2,1)-pizda(1,2)
8274             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8275 #ifdef MOMENT
8276             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8277 #else
8278             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8279 #endif
8280             if (swap) then
8281               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8282             else
8283               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8284             endif
8285 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8286           enddo
8287         enddo
8288       enddo
8289       return
8290       end
8291 c----------------------------------------------------------------------------
8292       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8293       implicit real*8 (a-h,o-z)
8294       include 'DIMENSIONS'
8295       include 'COMMON.IOUNITS'
8296       include 'COMMON.CHAIN'
8297       include 'COMMON.DERIV'
8298       include 'COMMON.INTERACT'
8299       include 'COMMON.CONTACTS'
8300       include 'COMMON.TORSION'
8301       include 'COMMON.VAR'
8302       include 'COMMON.GEO'
8303       include 'COMMON.FFIELD'
8304       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8305      & auxvec1(2),auxmat1(2,2)
8306       logical swap
8307 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8308 C                                                                              C
8309 C      Parallel       Antiparallel                                             C
8310 C                                                                              C
8311 C          o             o                                                     C
8312 C         /l\   /   \   /j\                                                    C
8313 C        /   \ /     \ /   \                                                   C
8314 C       /| o |o       o| o |\                                                  C
8315 C     \ j|/k\|      \  |/k\|l                                                  C
8316 C      \ /   \       \ /   \                                                   C
8317 C       o     \       o     \                                                  C
8318 C       i             i                                                        C
8319 C                                                                              C
8320 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8321 C
8322 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8323 C           energy moment and not to the cluster cumulant.
8324 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8325       iti=itortyp(itype(i))
8326       itj=itortyp(itype(j))
8327       if (j.lt.nres-1) then
8328         itj1=itortyp(itype(j+1))
8329       else
8330         itj1=ntortyp+1
8331       endif
8332       itk=itortyp(itype(k))
8333       if (k.lt.nres-1) then
8334         itk1=itortyp(itype(k+1))
8335       else
8336         itk1=ntortyp+1
8337       endif
8338       itl=itortyp(itype(l))
8339       if (l.lt.nres-1) then
8340         itl1=itortyp(itype(l+1))
8341       else
8342         itl1=ntortyp+1
8343       endif
8344 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8345 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8346 cd     & ' itl',itl,' itl1',itl1
8347 #ifdef MOMENT
8348       if (imat.eq.1) then
8349         s1=dip(3,jj,i)*dip(3,kk,k)
8350       else
8351         s1=dip(2,jj,j)*dip(2,kk,l)
8352       endif
8353 #endif
8354       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8355       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8356       if (j.eq.l+1) then
8357         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8358         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8359       else
8360         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8361         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8362       endif
8363       call transpose2(EUg(1,1,k),auxmat(1,1))
8364       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8365       vv(1)=pizda(1,1)-pizda(2,2)
8366       vv(2)=pizda(2,1)+pizda(1,2)
8367       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8368 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8369 #ifdef MOMENT
8370       eello6_graph4=-(s1+s2+s3+s4)
8371 #else
8372       eello6_graph4=-(s2+s3+s4)
8373 #endif
8374 C Derivatives in gamma(i-1)
8375       if (i.gt.1) then
8376 #ifdef MOMENT
8377         if (imat.eq.1) then
8378           s1=dipderg(2,jj,i)*dip(3,kk,k)
8379         else
8380           s1=dipderg(4,jj,j)*dip(2,kk,l)
8381         endif
8382 #endif
8383         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8384         if (j.eq.l+1) then
8385           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8386           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8387         else
8388           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8389           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8390         endif
8391         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8392         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8393 cd          write (2,*) 'turn6 derivatives'
8394 #ifdef MOMENT
8395           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8396 #else
8397           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8398 #endif
8399         else
8400 #ifdef MOMENT
8401           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8402 #else
8403           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8404 #endif
8405         endif
8406       endif
8407 C Derivatives in gamma(k-1)
8408 #ifdef MOMENT
8409       if (imat.eq.1) then
8410         s1=dip(3,jj,i)*dipderg(2,kk,k)
8411       else
8412         s1=dip(2,jj,j)*dipderg(4,kk,l)
8413       endif
8414 #endif
8415       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8416       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8417       if (j.eq.l+1) then
8418         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8419         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8420       else
8421         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8422         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8423       endif
8424       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8425       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8426       vv(1)=pizda(1,1)-pizda(2,2)
8427       vv(2)=pizda(2,1)+pizda(1,2)
8428       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8429       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8430 #ifdef MOMENT
8431         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8432 #else
8433         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8434 #endif
8435       else
8436 #ifdef MOMENT
8437         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8438 #else
8439         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8440 #endif
8441       endif
8442 C Derivatives in gamma(j-1) or gamma(l-1)
8443       if (l.eq.j+1 .and. l.gt.1) then
8444         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8445         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8446         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8447         vv(1)=pizda(1,1)-pizda(2,2)
8448         vv(2)=pizda(2,1)+pizda(1,2)
8449         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8450         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8451       else if (j.gt.1) then
8452         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8453         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8454         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8455         vv(1)=pizda(1,1)-pizda(2,2)
8456         vv(2)=pizda(2,1)+pizda(1,2)
8457         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8458         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8459           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8460         else
8461           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8462         endif
8463       endif
8464 C Cartesian derivatives.
8465       do iii=1,2
8466         do kkk=1,5
8467           do lll=1,3
8468 #ifdef MOMENT
8469             if (iii.eq.1) then
8470               if (imat.eq.1) then
8471                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8472               else
8473                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8474               endif
8475             else
8476               if (imat.eq.1) then
8477                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8478               else
8479                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8480               endif
8481             endif
8482 #endif
8483             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8484      &        auxvec(1))
8485             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8486             if (j.eq.l+1) then
8487               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8488      &          b1(1,itj1),auxvec(1))
8489               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8490             else
8491               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8492      &          b1(1,itl1),auxvec(1))
8493               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8494             endif
8495             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8496      &        pizda(1,1))
8497             vv(1)=pizda(1,1)-pizda(2,2)
8498             vv(2)=pizda(2,1)+pizda(1,2)
8499             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8500             if (swap) then
8501               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8502 #ifdef MOMENT
8503                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8504      &             -(s1+s2+s4)
8505 #else
8506                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8507      &             -(s2+s4)
8508 #endif
8509                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8510               else
8511 #ifdef MOMENT
8512                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8513 #else
8514                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8515 #endif
8516                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8517               endif
8518             else
8519 #ifdef MOMENT
8520               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8521 #else
8522               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8523 #endif
8524               if (l.eq.j+1) then
8525                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8526               else
8527                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8528               endif
8529             endif
8530           enddo
8531         enddo
8532       enddo
8533       return
8534       end
8535 c----------------------------------------------------------------------------
8536       double precision function eello_turn6(i,jj,kk)
8537       implicit real*8 (a-h,o-z)
8538       include 'DIMENSIONS'
8539       include 'COMMON.IOUNITS'
8540       include 'COMMON.CHAIN'
8541       include 'COMMON.DERIV'
8542       include 'COMMON.INTERACT'
8543       include 'COMMON.CONTACTS'
8544       include 'COMMON.TORSION'
8545       include 'COMMON.VAR'
8546       include 'COMMON.GEO'
8547       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8548      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8549      &  ggg1(3),ggg2(3)
8550       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8551      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8552 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8553 C           the respective energy moment and not to the cluster cumulant.
8554       s1=0.0d0
8555       s8=0.0d0
8556       s13=0.0d0
8557 c
8558       eello_turn6=0.0d0
8559       j=i+4
8560       k=i+1
8561       l=i+3
8562       iti=itortyp(itype(i))
8563       itk=itortyp(itype(k))
8564       itk1=itortyp(itype(k+1))
8565       itl=itortyp(itype(l))
8566       itj=itortyp(itype(j))
8567 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8568 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8569 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8570 cd        eello6=0.0d0
8571 cd        return
8572 cd      endif
8573 cd      write (iout,*)
8574 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8575 cd     &   ' and',k,l
8576 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8577       do iii=1,2
8578         do kkk=1,5
8579           do lll=1,3
8580             derx_turn(lll,kkk,iii)=0.0d0
8581           enddo
8582         enddo
8583       enddo
8584 cd      eij=1.0d0
8585 cd      ekl=1.0d0
8586 cd      ekont=1.0d0
8587       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8588 cd      eello6_5=0.0d0
8589 cd      write (2,*) 'eello6_5',eello6_5
8590 #ifdef MOMENT
8591       call transpose2(AEA(1,1,1),auxmat(1,1))
8592       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8593       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8594       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8595 #endif
8596       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8597       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8598       s2 = scalar2(b1(1,itk),vtemp1(1))
8599 #ifdef MOMENT
8600       call transpose2(AEA(1,1,2),atemp(1,1))
8601       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8602       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8603       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8604 #endif
8605       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8606       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8607       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8608 #ifdef MOMENT
8609       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8610       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8611       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8612       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8613       ss13 = scalar2(b1(1,itk),vtemp4(1))
8614       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8615 #endif
8616 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8617 c      s1=0.0d0
8618 c      s2=0.0d0
8619 c      s8=0.0d0
8620 c      s12=0.0d0
8621 c      s13=0.0d0
8622       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8623 C Derivatives in gamma(i+2)
8624       s1d =0.0d0
8625       s8d =0.0d0
8626 #ifdef MOMENT
8627       call transpose2(AEA(1,1,1),auxmatd(1,1))
8628       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8629       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8630       call transpose2(AEAderg(1,1,2),atempd(1,1))
8631       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8632       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8633 #endif
8634       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8635       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8636       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8637 c      s1d=0.0d0
8638 c      s2d=0.0d0
8639 c      s8d=0.0d0
8640 c      s12d=0.0d0
8641 c      s13d=0.0d0
8642       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8643 C Derivatives in gamma(i+3)
8644 #ifdef MOMENT
8645       call transpose2(AEA(1,1,1),auxmatd(1,1))
8646       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8647       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8648       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8649 #endif
8650       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8651       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8652       s2d = scalar2(b1(1,itk),vtemp1d(1))
8653 #ifdef MOMENT
8654       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8655       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8656 #endif
8657       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8658 #ifdef MOMENT
8659       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8660       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8661       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8662 #endif
8663 c      s1d=0.0d0
8664 c      s2d=0.0d0
8665 c      s8d=0.0d0
8666 c      s12d=0.0d0
8667 c      s13d=0.0d0
8668 #ifdef MOMENT
8669       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8670      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8671 #else
8672       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8673      &               -0.5d0*ekont*(s2d+s12d)
8674 #endif
8675 C Derivatives in gamma(i+4)
8676       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8677       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8678       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8679 #ifdef MOMENT
8680       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8681       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8682       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8683 #endif
8684 c      s1d=0.0d0
8685 c      s2d=0.0d0
8686 c      s8d=0.0d0
8687 C      s12d=0.0d0
8688 c      s13d=0.0d0
8689 #ifdef MOMENT
8690       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8691 #else
8692       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8693 #endif
8694 C Derivatives in gamma(i+5)
8695 #ifdef MOMENT
8696       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8697       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8698       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8699 #endif
8700       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8701       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8702       s2d = scalar2(b1(1,itk),vtemp1d(1))
8703 #ifdef MOMENT
8704       call transpose2(AEA(1,1,2),atempd(1,1))
8705       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8706       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8707 #endif
8708       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8709       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8710 #ifdef MOMENT
8711       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8712       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8713       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8714 #endif
8715 c      s1d=0.0d0
8716 c      s2d=0.0d0
8717 c      s8d=0.0d0
8718 c      s12d=0.0d0
8719 c      s13d=0.0d0
8720 #ifdef MOMENT
8721       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8722      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8723 #else
8724       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8725      &               -0.5d0*ekont*(s2d+s12d)
8726 #endif
8727 C Cartesian derivatives
8728       do iii=1,2
8729         do kkk=1,5
8730           do lll=1,3
8731 #ifdef MOMENT
8732             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8733             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8734             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8735 #endif
8736             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8737             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8738      &          vtemp1d(1))
8739             s2d = scalar2(b1(1,itk),vtemp1d(1))
8740 #ifdef MOMENT
8741             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8742             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8743             s8d = -(atempd(1,1)+atempd(2,2))*
8744      &           scalar2(cc(1,1,itl),vtemp2(1))
8745 #endif
8746             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8747      &           auxmatd(1,1))
8748             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8749             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8750 c      s1d=0.0d0
8751 c      s2d=0.0d0
8752 c      s8d=0.0d0
8753 c      s12d=0.0d0
8754 c      s13d=0.0d0
8755 #ifdef MOMENT
8756             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8757      &        - 0.5d0*(s1d+s2d)
8758 #else
8759             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8760      &        - 0.5d0*s2d
8761 #endif
8762 #ifdef MOMENT
8763             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8764      &        - 0.5d0*(s8d+s12d)
8765 #else
8766             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8767      &        - 0.5d0*s12d
8768 #endif
8769           enddo
8770         enddo
8771       enddo
8772 #ifdef MOMENT
8773       do kkk=1,5
8774         do lll=1,3
8775           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8776      &      achuj_tempd(1,1))
8777           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8778           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8779           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8780           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8781           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8782      &      vtemp4d(1))
8783           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8784           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8785           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8786         enddo
8787       enddo
8788 #endif
8789 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8790 cd     &  16*eel_turn6_num
8791 cd      goto 1112
8792       if (j.lt.nres-1) then
8793         j1=j+1
8794         j2=j-1
8795       else
8796         j1=j-1
8797         j2=j-2
8798       endif
8799       if (l.lt.nres-1) then
8800         l1=l+1
8801         l2=l-1
8802       else
8803         l1=l-1
8804         l2=l-2
8805       endif
8806       do ll=1,3
8807 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8808 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8809 cgrad        ghalf=0.5d0*ggg1(ll)
8810 cd        ghalf=0.0d0
8811         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8812         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8813         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8814      &    +ekont*derx_turn(ll,2,1)
8815         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8816         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8817      &    +ekont*derx_turn(ll,4,1)
8818         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8819         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8820         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8821 cgrad        ghalf=0.5d0*ggg2(ll)
8822 cd        ghalf=0.0d0
8823         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8824      &    +ekont*derx_turn(ll,2,2)
8825         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8826         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8827      &    +ekont*derx_turn(ll,4,2)
8828         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8829         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8830         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8831       enddo
8832 cd      goto 1112
8833 cgrad      do m=i+1,j-1
8834 cgrad        do ll=1,3
8835 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8836 cgrad        enddo
8837 cgrad      enddo
8838 cgrad      do m=k+1,l-1
8839 cgrad        do ll=1,3
8840 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8841 cgrad        enddo
8842 cgrad      enddo
8843 cgrad1112  continue
8844 cgrad      do m=i+2,j2
8845 cgrad        do ll=1,3
8846 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8847 cgrad        enddo
8848 cgrad      enddo
8849 cgrad      do m=k+2,l2
8850 cgrad        do ll=1,3
8851 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8852 cgrad        enddo
8853 cgrad      enddo
8854 cd      do iii=1,nres-3
8855 cd        write (2,*) iii,g_corr6_loc(iii)
8856 cd      enddo
8857       eello_turn6=ekont*eel_turn6
8858 cd      write (2,*) 'ekont',ekont
8859 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8860       return
8861       end
8862
8863 C-----------------------------------------------------------------------------
8864       double precision function scalar(u,v)
8865 !DIR$ INLINEALWAYS scalar
8866 #ifndef OSF
8867 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8868 #endif
8869       implicit none
8870       double precision u(3),v(3)
8871 cd      double precision sc
8872 cd      integer i
8873 cd      sc=0.0d0
8874 cd      do i=1,3
8875 cd        sc=sc+u(i)*v(i)
8876 cd      enddo
8877 cd      scalar=sc
8878
8879       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8880       return
8881       end
8882 crc-------------------------------------------------
8883       SUBROUTINE MATVEC2(A1,V1,V2)
8884 !DIR$ INLINEALWAYS MATVEC2
8885 #ifndef OSF
8886 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8887 #endif
8888       implicit real*8 (a-h,o-z)
8889       include 'DIMENSIONS'
8890       DIMENSION A1(2,2),V1(2),V2(2)
8891 c      DO 1 I=1,2
8892 c        VI=0.0
8893 c        DO 3 K=1,2
8894 c    3     VI=VI+A1(I,K)*V1(K)
8895 c        Vaux(I)=VI
8896 c    1 CONTINUE
8897
8898       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8899       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8900
8901       v2(1)=vaux1
8902       v2(2)=vaux2
8903       END
8904 C---------------------------------------
8905       SUBROUTINE MATMAT2(A1,A2,A3)
8906 #ifndef OSF
8907 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8908 #endif
8909       implicit real*8 (a-h,o-z)
8910       include 'DIMENSIONS'
8911       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8912 c      DIMENSION AI3(2,2)
8913 c        DO  J=1,2
8914 c          A3IJ=0.0
8915 c          DO K=1,2
8916 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8917 c          enddo
8918 c          A3(I,J)=A3IJ
8919 c       enddo
8920 c      enddo
8921
8922       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8923       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8924       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8925       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8926
8927       A3(1,1)=AI3_11
8928       A3(2,1)=AI3_21
8929       A3(1,2)=AI3_12
8930       A3(2,2)=AI3_22
8931       END
8932
8933 c-------------------------------------------------------------------------
8934       double precision function scalar2(u,v)
8935 !DIR$ INLINEALWAYS scalar2
8936       implicit none
8937       double precision u(2),v(2)
8938       double precision sc
8939       integer i
8940       scalar2=u(1)*v(1)+u(2)*v(2)
8941       return
8942       end
8943
8944 C-----------------------------------------------------------------------------
8945
8946       subroutine transpose2(a,at)
8947 !DIR$ INLINEALWAYS transpose2
8948 #ifndef OSF
8949 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8950 #endif
8951       implicit none
8952       double precision a(2,2),at(2,2)
8953       at(1,1)=a(1,1)
8954       at(1,2)=a(2,1)
8955       at(2,1)=a(1,2)
8956       at(2,2)=a(2,2)
8957       return
8958       end
8959 c--------------------------------------------------------------------------
8960       subroutine transpose(n,a,at)
8961       implicit none
8962       integer n,i,j
8963       double precision a(n,n),at(n,n)
8964       do i=1,n
8965         do j=1,n
8966           at(j,i)=a(i,j)
8967         enddo
8968       enddo
8969       return
8970       end
8971 C---------------------------------------------------------------------------
8972       subroutine prodmat3(a1,a2,kk,transp,prod)
8973 !DIR$ INLINEALWAYS prodmat3
8974 #ifndef OSF
8975 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8976 #endif
8977       implicit none
8978       integer i,j
8979       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8980       logical transp
8981 crc      double precision auxmat(2,2),prod_(2,2)
8982
8983       if (transp) then
8984 crc        call transpose2(kk(1,1),auxmat(1,1))
8985 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8986 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8987
8988            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8989      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8990            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8991      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8992            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8993      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8994            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8995      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8996
8997       else
8998 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8999 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9000
9001            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9002      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9003            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9004      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9005            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9006      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9007            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9008      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9009
9010       endif
9011 c      call transpose2(a2(1,1),a2t(1,1))
9012
9013 crc      print *,transp
9014 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9015 crc      print *,((prod(i,j),i=1,2),j=1,2)
9016
9017       return
9018       end
9019