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