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