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    Here are the energies showed per procesor if the are more processors
 300 c    per molecule then we sum it up in sum_energy subroutine
 301 c      print *," Processor",myrank," calls SUM_ENERGY"
 302       call sum_energy(energia,.true.)
 303 c      print *," Processor",myrank," left SUM_ENERGY"
 304 #ifdef TIMING
 305       time_sumene=time_sumene+MPI_Wtime()-time00
 306 #endif
 307       return
 308       end
 309 c-------------------------------------------------------------------------------
 310       subroutine sum_energy(energia,reduce)
 311       implicit real*8 (a-h,o-z)
 312       include 'DIMENSIONS'
 313 #ifndef ISNAN
 314       external proc_proc
 315 #ifdef WINPGI
 316 cMS$ATTRIBUTES C ::  proc_proc
 317 #endif
 318 #endif
 319 #ifdef MPI
 320       include "mpif.h"
 321 #endif
 322       include 'COMMON.SETUP'
 323       include 'COMMON.IOUNITS'
 324       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 325       include 'COMMON.FFIELD'
 326       include 'COMMON.DERIV'
 327       include 'COMMON.INTERACT'
 328       include 'COMMON.SBRIDGE'
 329       include 'COMMON.CHAIN'
 330       include 'COMMON.VAR'
 331       include 'COMMON.CONTROL'
 332       include 'COMMON.TIME1'
 333       logical reduce
 334 #ifdef MPI
 335       if (nfgtasks.gt.1 .and. reduce) then
 336 #ifdef DEBUG
 337         write (iout,*) "energies before REDUCE"
 338         call enerprint(energia)
 339         call flush(iout)
 340 #endif
 341         do i=0,n_ene
 342           enebuff(i)=energia(i)
 343         enddo
 344         time00=MPI_Wtime()
 345         call MPI_Barrier(FG_COMM,IERR)
 346         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 347         time00=MPI_Wtime()
 348         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 349      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 350 #ifdef DEBUG
 351         write (iout,*) "energies after REDUCE"
 352         call enerprint(energia)
 353         call flush(iout)
 354 #endif
 355         time_Reduce=time_Reduce+MPI_Wtime()-time00
 356       endif
 357       if (fg_rank.eq.0) then
 358 #endif
 359       evdw=energia(1)
 360 #ifdef SCP14
 361       evdw2=energia(2)+energia(18)
 362       evdw2_14=energia(18)
 363 #else
 364       evdw2=energia(2)
 365 #endif
 366 #ifdef SPLITELE
 367       ees=energia(3)
 368       evdw1=energia(16)
 369 #else
 370       ees=energia(3)
 371       evdw1=0.0d0
 372 #endif
 373       ecorr=energia(4)
 374       ecorr5=energia(5)
 375       ecorr6=energia(6)
 376       eel_loc=energia(7)
 377       eello_turn3=energia(8)
 378       eello_turn4=energia(9)
 379       eturn6=energia(10)
 380       ebe=energia(11)
 381       escloc=energia(12)
 382       etors=energia(13)
 383       etors_d=energia(14)
 384       ehpb=energia(15)
 385       edihcnstr=energia(19)
 386       estr=energia(17)
 387       Uconst=energia(20)
 388       esccor=energia(21)
 389 #ifdef SPLITELE
 390       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 391      & +wang*ebe+wtor*etors+wscloc*escloc
 392      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 393      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 394      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 395      & +wbond*estr+Uconst+wsccor*esccor
 396 #else
 397       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #endif
 404       energia(0)=etot
 405 c detecting NaNQ
 406 #ifdef ISNAN
 407 #ifdef AIX
 408       if (isnan(etot).ne.0) energia(0)=1.0d+99
 409 #else
 410       if (isnan(etot)) energia(0)=1.0d+99
 411 #endif
 412 #else
 413       i=0
 414 #ifdef WINPGI
 415       idumm=proc_proc(etot,i)
 416 #else
 417       call proc_proc(etot,i)
 418 #endif
 419       if(i.eq.1)energia(0)=1.0d+99
 420 #endif
 421 #ifdef MPI
 422       endif
 423 #endif
 424       return
 425       end
 426 c-------------------------------------------------------------------------------
 427       subroutine sum_gradient
 428       implicit real*8 (a-h,o-z)
 429       include 'DIMENSIONS'
 430 #ifndef ISNAN
 431       external proc_proc
 432 #ifdef WINPGI
 433 cMS$ATTRIBUTES C ::  proc_proc
 434 #endif
 435 #endif
 436 #ifdef MPI
 437       include 'mpif.h'
 438       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 439      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 440 #endif
 441       include 'COMMON.SETUP'
 442       include 'COMMON.IOUNITS'
 443       include 'COMMON.FFIELD'
 444       include 'COMMON.DERIV'
 445       include 'COMMON.INTERACT'
 446       include 'COMMON.SBRIDGE'
 447       include 'COMMON.CHAIN'
 448       include 'COMMON.VAR'
 449       include 'COMMON.CONTROL'
 450       include 'COMMON.TIME1'
 451       include 'COMMON.MAXGRAD'
 452       include 'COMMON.SCCOR'
 453 #ifdef TIMING
 454       time01=MPI_Wtime()
 455 #endif
 456 #ifdef DEBUG
 457       write (iout,*) "sum_gradient gvdwc, gvdwx"
 458       do i=1,nres
 459         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 460      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 461       enddo
 462       call flush(iout)
 463 #endif
 464 #ifdef MPI
 465 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 466         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 467      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 468 #endif
 469 C
 470 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 471 C            in virtual-bond-vector coordinates
 472 C
 473 #ifdef DEBUG
 474 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 475 c      do i=1,nres-1
 476 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 477 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 478 c      enddo
 479 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 482 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 483 c      enddo
 484       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 485       do i=1,nres
 486         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 487      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 488      &   g_corr5_loc(i)
 489       enddo
 490       call flush(iout)
 491 #endif
 492 #ifdef SPLITELE
 493       do i=1,nct
 494         do j=1,3
 495           gradbufc(j,i)=wsc*gvdwc(j,i)+
 496      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 497      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 498      &                wel_loc*gel_loc_long(j,i)+
 499      &                wcorr*gradcorr_long(j,i)+
 500      &                wcorr5*gradcorr5_long(j,i)+
 501      &                wcorr6*gradcorr6_long(j,i)+
 502      &                wturn6*gcorr6_turn_long(j,i)+
 503      &                wstrain*ghpbc(j,i)
 504         enddo
 505       enddo
 506 #else
 507       do i=1,nct
 508         do j=1,3
 509           gradbufc(j,i)=wsc*gvdwc(j,i)+
 510      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 511      &                welec*gelc_long(j,i)+
 512      &                wbond*gradb(j,i)+
 513      &                wel_loc*gel_loc_long(j,i)+
 514      &                wcorr*gradcorr_long(j,i)+
 515      &                wcorr5*gradcorr5_long(j,i)+
 516      &                wcorr6*gradcorr6_long(j,i)+
 517      &                wturn6*gcorr6_turn_long(j,i)+
 518      &                wstrain*ghpbc(j,i)
 519         enddo
 520       enddo
 521 #endif
 522 #ifdef MPI
 523       if (nfgtasks.gt.1) then
 524       time00=MPI_Wtime()
 525 #ifdef DEBUG
 526       write (iout,*) "gradbufc before allreduce"
 527       do i=1,nres
 528         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 529       enddo
 530       call flush(iout)
 531 #endif
 532       do i=1,nres
 533         do j=1,3
 534           gradbufc_sum(j,i)=gradbufc(j,i)
 535         enddo
 536       enddo
 537 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 538 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 539 c      time_reduce=time_reduce+MPI_Wtime()-time00
 540 #ifdef DEBUG
 541 c      write (iout,*) "gradbufc_sum after allreduce"
 542 c      do i=1,nres
 543 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 544 c      enddo
 545 c      call flush(iout)
 546 #endif
 547 #ifdef TIMING
 548 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 549 #endif
 550       do i=nnt,nres
 551         do k=1,3
 552           gradbufc(k,i)=0.0d0
 553         enddo
 554       enddo
 555 #ifdef DEBUG
 556       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 557       write (iout,*) (i," jgrad_start",jgrad_start(i),
 558      &                  " jgrad_end  ",jgrad_end(i),
 559      &                  i=igrad_start,igrad_end)
 560 #endif
 561 c
 562 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 563 c do not parallelize this part.
 564 c
 565 c      do i=igrad_start,igrad_end
 566 c        do j=jgrad_start(i),jgrad_end(i)
 567 c          do k=1,3
 568 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 569 c          enddo
 570 c        enddo
 571 c      enddo
 572       do j=1,3
 573         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 574       enddo
 575       do i=nres-2,nnt,-1
 576         do j=1,3
 577           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc after summing"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       else
 588 #endif
 589 #ifdef DEBUG
 590       write (iout,*) "gradbufc"
 591       do i=1,nres
 592         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 593       enddo
 594       call flush(iout)
 595 #endif
 596       do i=1,nres
 597         do j=1,3
 598           gradbufc_sum(j,i)=gradbufc(j,i)
 599           gradbufc(j,i)=0.0d0
 600         enddo
 601       enddo
 602       do j=1,3
 603         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 604       enddo
 605       do i=nres-2,nnt,-1
 606         do j=1,3
 607           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 608         enddo
 609       enddo
 610 c      do i=nnt,nres-1
 611 c        do k=1,3
 612 c          gradbufc(k,i)=0.0d0
 613 c        enddo
 614 c        do j=i+1,nres
 615 c          do k=1,3
 616 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 617 c          enddo
 618 c        enddo
 619 c      enddo
 620 #ifdef DEBUG
 621       write (iout,*) "gradbufc after summing"
 622       do i=1,nres
 623         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 624       enddo
 625       call flush(iout)
 626 #endif
 627 #ifdef MPI
 628       endif
 629 #endif
 630       do k=1,3
 631         gradbufc(k,nres)=0.0d0
 632       enddo
 633       do i=1,nct
 634         do j=1,3
 635 #ifdef SPLITELE
 636           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 637      &                wel_loc*gel_loc(j,i)+
 638      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 639      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 640      &                wel_loc*gel_loc_long(j,i)+
 641      &                wcorr*gradcorr_long(j,i)+
 642      &                wcorr5*gradcorr5_long(j,i)+
 643      &                wcorr6*gradcorr6_long(j,i)+
 644      &                wturn6*gcorr6_turn_long(j,i))+
 645      &                wbond*gradb(j,i)+
 646      &                wcorr*gradcorr(j,i)+
 647      &                wturn3*gcorr3_turn(j,i)+
 648      &                wturn4*gcorr4_turn(j,i)+
 649      &                wcorr5*gradcorr5(j,i)+
 650      &                wcorr6*gradcorr6(j,i)+
 651      &                wturn6*gcorr6_turn(j,i)+
 652      &                wsccor*gsccorc(j,i)
 653      &               +wscloc*gscloc(j,i)
 654 #else
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #endif
 674           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 675      &                  wbond*gradbx(j,i)+
 676      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 677      &                  wsccor*gsccorx(j,i)
 678      &                 +wscloc*gsclocx(j,i)
 679         enddo
 680       enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gloc before adding corr"
 683       do i=1,4*nres
 684         write (iout,*) i,gloc(i,icg)
 685       enddo
 686 #endif
 687       do i=1,nres-3
 688         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 689      &   +wcorr5*g_corr5_loc(i)
 690      &   +wcorr6*g_corr6_loc(i)
 691      &   +wturn4*gel_loc_turn4(i)
 692      &   +wturn3*gel_loc_turn3(i)
 693      &   +wturn6*gel_loc_turn6(i)
 694      &   +wel_loc*gel_loc_loc(i)
 695       enddo
 696 #ifdef DEBUG
 697       write (iout,*) "gloc after adding corr"
 698       do i=1,4*nres
 699         write (iout,*) i,gloc(i,icg)
 700       enddo
 701 #endif
 702 #ifdef MPI
 703       if (nfgtasks.gt.1) then
 704         do j=1,3
 705           do i=1,nres
 706             gradbufc(j,i)=gradc(j,i,icg)
 707             gradbufx(j,i)=gradx(j,i,icg)
 708           enddo
 709         enddo
 710         do i=1,4*nres
 711           glocbuf(i)=gloc(i,icg)
 712         enddo
 713 #define DEBUG
 714 #ifdef DEBUG
 715       write (iout,*) "gloc_sc before reduce"
 716       do i=1,nres
 717        do j=1,1
 718         write (iout,*) i,j,gloc_sc(j,i,icg)
 719        enddo
 720       enddo
 721 #endif
 722 #undef DEBUG
 723         do i=1,nres
 724          do j=1,3
 725           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 726          enddo
 727         enddo
 728         time00=MPI_Wtime()
 729         call MPI_Barrier(FG_COMM,IERR)
 730         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 731         time00=MPI_Wtime()
 732         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 737      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 738         time_reduce=time_reduce+MPI_Wtime()-time00
 739         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         time_reduce=time_reduce+MPI_Wtime()-time00
 742 #define DEBUG
 743 #ifdef DEBUG
 744       write (iout,*) "gloc_sc after reduce"
 745       do i=1,nres
 746        do j=1,1
 747         write (iout,*) i,j,gloc_sc(j,i,icg)
 748        enddo
 749       enddo
 750 #endif
 751 #undef DEBUG
 752 #ifdef DEBUG
 753       write (iout,*) "gloc after reduce"
 754       do i=1,4*nres
 755         write (iout,*) i,gloc(i,icg)
 756       enddo
 757 #endif
 758       endif
 759 #endif
 760       if (gnorm_check) then
 761 c
 762 c Compute the maximum elements of the gradient
 763 c
 764       gvdwc_max=0.0d0
 765       gvdwc_scp_max=0.0d0
 766       gelc_max=0.0d0
 767       gvdwpp_max=0.0d0
 768       gradb_max=0.0d0
 769       ghpbc_max=0.0d0
 770       gradcorr_max=0.0d0
 771       gel_loc_max=0.0d0
 772       gcorr3_turn_max=0.0d0
 773       gcorr4_turn_max=0.0d0
 774       gradcorr5_max=0.0d0
 775       gradcorr6_max=0.0d0
 776       gcorr6_turn_max=0.0d0
 777       gsccorc_max=0.0d0
 778       gscloc_max=0.0d0
 779       gvdwx_max=0.0d0
 780       gradx_scp_max=0.0d0
 781       ghpbx_max=0.0d0
 782       gradxorr_max=0.0d0
 783       gsccorx_max=0.0d0
 784       gsclocx_max=0.0d0
 785       do i=1,nct
 786         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 787         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 788         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 789         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 790      &   gvdwc_scp_max=gvdwc_scp_norm
 791         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 792         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 793         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 794         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 795         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 796         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 797         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 798         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 799         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 800         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 801         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 802         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 803         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 804      &    gcorr3_turn(1,i)))
 805         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 806      &    gcorr3_turn_max=gcorr3_turn_norm
 807         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 808      &    gcorr4_turn(1,i)))
 809         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 810      &    gcorr4_turn_max=gcorr4_turn_norm
 811         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 812         if (gradcorr5_norm.gt.gradcorr5_max)
 813      &    gradcorr5_max=gradcorr5_norm
 814         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 815         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 816         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 817      &    gcorr6_turn(1,i)))
 818         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 819      &    gcorr6_turn_max=gcorr6_turn_norm
 820         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 821         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 822         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 823         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 824         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 825         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 826         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 827         if (gradx_scp_norm.gt.gradx_scp_max)
 828      &    gradx_scp_max=gradx_scp_norm
 829         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 830         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 831         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 832         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 833         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 834         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 835         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 836         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 837       enddo
 838       if (gradout) then
 839 #ifdef AIX
 840         open(istat,file=statname,position="append")
 841 #else
 842         open(istat,file=statname,access="append")
 843 #endif
 844         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 845      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 846      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 847      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 848      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 849      &     gsccorx_max,gsclocx_max
 850         close(istat)
 851         if (gvdwc_max.gt.1.0d4) then
 852           write (iout,*) "gvdwc gvdwx gradb gradbx"
 853           do i=nnt,nct
 854             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 855      &        gradb(j,i),gradbx(j,i),j=1,3)
 856           enddo
 857           call pdbout(0.0d0,'cipiszcze',iout)
 858           call flush(iout)
 859         endif
 860       endif
 861       endif
 862 #ifdef DEBUG
 863       write (iout,*) "gradc gradx gloc"
 864       do i=1,nres
 865         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 866      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 867       enddo
 868 #endif
 869 #ifdef TIMING
 870       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 871 #endif
 872       return
 873       end
 874 c-------------------------------------------------------------------------------
 875       subroutine rescale_weights(t_bath)
 876       implicit real*8 (a-h,o-z)
 877       include 'DIMENSIONS'
 878       include 'COMMON.IOUNITS'
 879       include 'COMMON.FFIELD'
 880       include 'COMMON.SBRIDGE'
 881       double precision kfac /2.4d0/
 882       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 883 c      facT=temp0/t_bath
 884 c      facT=2*temp0/(t_bath+temp0)
 885       if (rescale_mode.eq.0) then
 886         facT=1.0d0
 887         facT2=1.0d0
 888         facT3=1.0d0
 889         facT4=1.0d0
 890         facT5=1.0d0
 891       else if (rescale_mode.eq.1) then
 892         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 893         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 894         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 895         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 896         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 897       else if (rescale_mode.eq.2) then
 898         x=t_bath/temp0
 899         x2=x*x
 900         x3=x2*x
 901         x4=x3*x
 902         x5=x4*x
 903         facT=licznik/dlog(dexp(x)+dexp(-x))
 904         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 905         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 906         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 907         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 908       else
 909         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 910         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 911 #ifdef MPI
 912        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 913 #endif
 914        stop 555
 915       endif
 916       welec=weights(3)*fact
 917       wcorr=weights(4)*fact3
 918       wcorr5=weights(5)*fact4
 919       wcorr6=weights(6)*fact5
 920       wel_loc=weights(7)*fact2
 921       wturn3=weights(8)*fact2
 922       wturn4=weights(9)*fact3
 923       wturn6=weights(10)*fact5
 924       wtor=weights(13)*fact
 925       wtor_d=weights(14)*fact2
 926       wsccor=weights(21)*fact
 927
 928       return
 929       end
 930 C------------------------------------------------------------------------
 931       subroutine enerprint(energia)
 932       implicit real*8 (a-h,o-z)
 933       include 'DIMENSIONS'
 934       include 'COMMON.IOUNITS'
 935       include 'COMMON.FFIELD'
 936       include 'COMMON.SBRIDGE'
 937       include 'COMMON.MD'
 938       double precision energia(0:n_ene)
 939       etot=energia(0)
 940       evdw=energia(1)
 941       evdw2=energia(2)
 942 #ifdef SCP14
 943       evdw2=energia(2)+energia(18)
 944 #else
 945       evdw2=energia(2)
 946 #endif
 947       ees=energia(3)
 948 #ifdef SPLITELE
 949       evdw1=energia(16)
 950 #endif
 951       ecorr=energia(4)
 952       ecorr5=energia(5)
 953       ecorr6=energia(6)
 954       eel_loc=energia(7)
 955       eello_turn3=energia(8)
 956       eello_turn4=energia(9)
 957       eello_turn6=energia(10)
 958       ebe=energia(11)
 959       escloc=energia(12)
 960       etors=energia(13)
 961       etors_d=energia(14)
 962       ehpb=energia(15)
 963       edihcnstr=energia(19)
 964       estr=energia(17)
 965       Uconst=energia(20)
 966       esccor=energia(21)
 967 #ifdef SPLITELE
 968       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 969      &  estr,wbond,ebe,wang,
 970      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 971      &  ecorr,wcorr,
 972      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 973      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 974      &  edihcnstr,ebr*nss,
 975      &  Uconst,etot
 976    10 format (/'Virtual-chain energies:'//
 977      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 978      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 979      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 980      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 981      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 982      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 983      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 984      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 985      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 986      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 987      & ' (SS bridges & dist. cnstr.)'/
 988      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 992      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 993      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 994      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 995      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 996      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 997      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 998      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 999      & 'ETOT=  ',1pE16.6,' (total)')
1000 #else
1001       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1002      &  estr,wbond,ebe,wang,
1003      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1004      &  ecorr,wcorr,
1005      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1006      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1007      &  ebr*nss,Uconst,etot
1008    10 format (/'Virtual-chain energies:'//
1009      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1010      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1011      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1012      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1013      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1014      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1015      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1016      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1017      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1018      & ' (SS bridges & dist. cnstr.)'/
1019      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1023      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1024      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1025      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1026      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1027      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1028      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1029      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1030      & 'ETOT=  ',1pE16.6,' (total)')
1031 #endif
1032       return
1033       end
1034 C-----------------------------------------------------------------------
1035       subroutine elj(evdw)
1036 C
1037 C This subroutine calculates the interaction energy of nonbonded side chains
1038 C assuming the LJ potential of interaction.
1039 C
1040       implicit real*8 (a-h,o-z)
1041       include 'DIMENSIONS'
1042       parameter (accur=1.0d-10)
1043       include 'COMMON.GEO'
1044       include 'COMMON.VAR'
1045       include 'COMMON.LOCAL'
1046       include 'COMMON.CHAIN'
1047       include 'COMMON.DERIV'
1048       include 'COMMON.INTERACT'
1049       include 'COMMON.TORSION'
1050       include 'COMMON.SBRIDGE'
1051       include 'COMMON.NAMES'
1052       include 'COMMON.IOUNITS'
1053       include 'COMMON.CONTACTS'
1054       dimension gg(3)
1055 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1056       evdw=0.0D0
1057       do i=iatsc_s,iatsc_e
1058         itypi=iabs(itype(i))
1059         if (itypi.eq.ntyp1) cycle
1060         itypi1=iabs(itype(i+1))
1061         xi=c(1,nres+i)
1062         yi=c(2,nres+i)
1063         zi=c(3,nres+i)
1064 C Change 12/1/95
1065         num_conti=0
1066 C
1067 C Calculate SC interaction energy.
1068 C
1069         do iint=1,nint_gr(i)
1070 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1071 cd   &                  'iend=',iend(i,iint)
1072           do j=istart(i,iint),iend(i,iint)
1073             itypj=iabs(itype(j))
1074             if (itypj.eq.ntyp1) cycle
1075             xj=c(1,nres+j)-xi
1076             yj=c(2,nres+j)-yi
1077             zj=c(3,nres+j)-zi
1078 C Change 12/1/95 to calculate four-body interactions
1079             rij=xj*xj+yj*yj+zj*zj
1080             rrij=1.0D0/rij
1081 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1082             eps0ij=eps(itypi,itypj)
1083             fac=rrij**expon2
1084             e1=fac*fac*aa(itypi,itypj)
1085             e2=fac*bb(itypi,itypj)
1086             evdwij=e1+e2
1087 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1088 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1089 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1090 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1091 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1092 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1093             evdw=evdw+evdwij
1094 C
1095 C Calculate the components of the gradient in DC and X
1096 C
1097             fac=-rrij*(e1+evdwij)
1098             gg(1)=xj*fac
1099             gg(2)=yj*fac
1100             gg(3)=zj*fac
1101             do k=1,3
1102               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1103               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1104               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1105               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1106             enddo
1107 cgrad            do k=i,j-1
1108 cgrad              do l=1,3
1109 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1110 cgrad              enddo
1111 cgrad            enddo
1112 C
1113 C 12/1/95, revised on 5/20/97
1114 C
1115 C Calculate the contact function. The ith column of the array JCONT will
1116 C contain the numbers of atoms that make contacts with the atom I (of numbers
1117 C greater than I). The arrays FACONT and GACONT will contain the values of
1118 C the contact function and its derivative.
1119 C
1120 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1121 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1122 C Uncomment next line, if the correlation interactions are contact function only
1123             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1124               rij=dsqrt(rij)
1125               sigij=sigma(itypi,itypj)
1126               r0ij=rs0(itypi,itypj)
1127 C
1128 C Check whether the SC's are not too far to make a contact.
1129 C
1130               rcut=1.5d0*r0ij
1131               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1132 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1133 C
1134               if (fcont.gt.0.0D0) then
1135 C If the SC-SC distance if close to sigma, apply spline.
1136 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1137 cAdam &             fcont1,fprimcont1)
1138 cAdam           fcont1=1.0d0-fcont1
1139 cAdam           if (fcont1.gt.0.0d0) then
1140 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1141 cAdam             fcont=fcont*fcont1
1142 cAdam           endif
1143 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1144 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1145 cga             do k=1,3
1146 cga               gg(k)=gg(k)*eps0ij
1147 cga             enddo
1148 cga             eps0ij=-evdwij*eps0ij
1149 C Uncomment for AL's type of SC correlation interactions.
1150 cadam           eps0ij=-evdwij
1151                 num_conti=num_conti+1
1152                 jcont(num_conti,i)=j
1153                 facont(num_conti,i)=fcont*eps0ij
1154                 fprimcont=eps0ij*fprimcont/rij
1155                 fcont=expon*fcont
1156 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1157 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1158 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1159 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1160                 gacont(1,num_conti,i)=-fprimcont*xj
1161                 gacont(2,num_conti,i)=-fprimcont*yj
1162                 gacont(3,num_conti,i)=-fprimcont*zj
1163 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1164 cd              write (iout,'(2i3,3f10.5)')
1165 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1166               endif
1167             endif
1168           enddo      ! j
1169         enddo        ! iint
1170 C Change 12/1/95
1171         num_cont(i)=num_conti
1172       enddo          ! i
1173       do i=1,nct
1174         do j=1,3
1175           gvdwc(j,i)=expon*gvdwc(j,i)
1176           gvdwx(j,i)=expon*gvdwx(j,i)
1177         enddo
1178       enddo
1179 C******************************************************************************
1180 C
1181 C                              N O T E !!!
1182 C
1183 C To save time, the factor of EXPON has been extracted from ALL components
1184 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1185 C use!
1186 C
1187 C******************************************************************************
1188       return
1189       end
1190 C-----------------------------------------------------------------------------
1191       subroutine eljk(evdw)
1192 C
1193 C This subroutine calculates the interaction energy of nonbonded side chains
1194 C assuming the LJK potential of interaction.
1195 C
1196       implicit real*8 (a-h,o-z)
1197       include 'DIMENSIONS'
1198       include 'COMMON.GEO'
1199       include 'COMMON.VAR'
1200       include 'COMMON.LOCAL'
1201       include 'COMMON.CHAIN'
1202       include 'COMMON.DERIV'
1203       include 'COMMON.INTERACT'
1204       include 'COMMON.IOUNITS'
1205       include 'COMMON.NAMES'
1206       dimension gg(3)
1207       logical scheck
1208 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1209       evdw=0.0D0
1210       do i=iatsc_s,iatsc_e
1211         itypi=iabs(itype(i))
1212         if (itypi.eq.ntyp1) cycle
1213         itypi1=iabs(itype(i+1))
1214         xi=c(1,nres+i)
1215         yi=c(2,nres+i)
1216         zi=c(3,nres+i)
1217 C
1218 C Calculate SC interaction energy.
1219 C
1220         do iint=1,nint_gr(i)
1221           do j=istart(i,iint),iend(i,iint)
1222             itypj=iabs(itype(j))
1223             if (itypj.eq.ntyp1) cycle
1224             xj=c(1,nres+j)-xi
1225             yj=c(2,nres+j)-yi
1226             zj=c(3,nres+j)-zi
1227             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1228             fac_augm=rrij**expon
1229             e_augm=augm(itypi,itypj)*fac_augm
1230             r_inv_ij=dsqrt(rrij)
1231             rij=1.0D0/r_inv_ij
1232             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1233             fac=r_shift_inv**expon
1234             e1=fac*fac*aa(itypi,itypj)
1235             e2=fac*bb(itypi,itypj)
1236             evdwij=e_augm+e1+e2
1237 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1238 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1239 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1240 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1241 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1242 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1243 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1244             evdw=evdw+evdwij
1245 C
1246 C Calculate the components of the gradient in DC and X
1247 C
1248             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1249             gg(1)=xj*fac
1250             gg(2)=yj*fac
1251             gg(3)=zj*fac
1252             do k=1,3
1253               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1254               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1255               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1256               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1257             enddo
1258 cgrad            do k=i,j-1
1259 cgrad              do l=1,3
1260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1261 cgrad              enddo
1262 cgrad            enddo
1263           enddo      ! j
1264         enddo        ! iint
1265       enddo          ! i
1266       do i=1,nct
1267         do j=1,3
1268           gvdwc(j,i)=expon*gvdwc(j,i)
1269           gvdwx(j,i)=expon*gvdwx(j,i)
1270         enddo
1271       enddo
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine ebp(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the Berne-Pechukas potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.NAMES'
1288       include 'COMMON.INTERACT'
1289       include 'COMMON.IOUNITS'
1290       include 'COMMON.CALC'
1291       common /srutu/ icall
1292 c     double precision rrsave(maxdim)
1293       logical lprn
1294       evdw=0.0D0
1295 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1296       evdw=0.0D0
1297 c     if (icall.eq.0) then
1298 c       lprn=.true.
1299 c     else
1300         lprn=.false.
1301 c     endif
1302       ind=0
1303       do i=iatsc_s,iatsc_e
1304         itypi=iabs(itype(i))
1305         if (itypi.eq.ntyp1) cycle
1306         itypi1=iabs(itype(i+1))
1307         xi=c(1,nres+i)
1308         yi=c(2,nres+i)
1309         zi=c(3,nres+i)
1310         dxi=dc_norm(1,nres+i)
1311         dyi=dc_norm(2,nres+i)
1312         dzi=dc_norm(3,nres+i)
1313 c        dsci_inv=dsc_inv(itypi)
1314         dsci_inv=vbld_inv(i+nres)
1315 C
1316 C Calculate SC interaction energy.
1317 C
1318         do iint=1,nint_gr(i)
1319           do j=istart(i,iint),iend(i,iint)
1320             ind=ind+1
1321             itypj=iabs(itype(j))
1322             if (itypj.eq.ntyp1) cycle
1323 c            dscj_inv=dsc_inv(itypj)
1324             dscj_inv=vbld_inv(j+nres)
1325             chi1=chi(itypi,itypj)
1326             chi2=chi(itypj,itypi)
1327             chi12=chi1*chi2
1328             chip1=chip(itypi)
1329             chip2=chip(itypj)
1330             chip12=chip1*chip2
1331             alf1=alp(itypi)
1332             alf2=alp(itypj)
1333             alf12=0.5D0*(alf1+alf2)
1334 C For diagnostics only!!!
1335 c           chi1=0.0D0
1336 c           chi2=0.0D0
1337 c           chi12=0.0D0
1338 c           chip1=0.0D0
1339 c           chip2=0.0D0
1340 c           chip12=0.0D0
1341 c           alf1=0.0D0
1342 c           alf2=0.0D0
1343 c           alf12=0.0D0
1344             xj=c(1,nres+j)-xi
1345             yj=c(2,nres+j)-yi
1346             zj=c(3,nres+j)-zi
1347             dxj=dc_norm(1,nres+j)
1348             dyj=dc_norm(2,nres+j)
1349             dzj=dc_norm(3,nres+j)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351 cd          if (icall.eq.0) then
1352 cd            rrsave(ind)=rrij
1353 cd          else
1354 cd            rrij=rrsave(ind)
1355 cd          endif
1356             rij=dsqrt(rrij)
1357 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1358             call sc_angular
1359 C Calculate whole angle-dependent part of epsilon and contributions
1360 C to its derivatives
1361             fac=(rrij*sigsq)**expon2
1362             e1=fac*fac*aa(itypi,itypj)
1363             e2=fac*bb(itypi,itypj)
1364             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1365             eps2der=evdwij*eps3rt
1366             eps3der=evdwij*eps2rt
1367             evdwij=evdwij*eps2rt*eps3rt
1368             evdw=evdw+evdwij
1369             if (lprn) then
1370             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1371             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1372 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1373 cd     &        restyp(itypi),i,restyp(itypj),j,
1374 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1375 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1376 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1377 cd     &        evdwij
1378             endif
1379 C Calculate gradient components.
1380             e1=e1*eps1*eps2rt**2*eps3rt**2
1381             fac=-expon*(e1+evdwij)
1382             sigder=fac/sigsq
1383             fac=rrij*fac
1384 C Calculate radial part of the gradient
1385             gg(1)=xj*fac
1386             gg(2)=yj*fac
1387             gg(3)=zj*fac
1388 C Calculate the angular part of the gradient and sum add the contributions
1389 C to the appropriate components of the Cartesian gradient.
1390             call sc_grad
1391           enddo      ! j
1392         enddo        ! iint
1393       enddo          ! i
1394 c     stop
1395       return
1396       end
1397 C-----------------------------------------------------------------------------
1398       subroutine egb(evdw)
1399 C
1400 C This subroutine calculates the interaction energy of nonbonded side chains
1401 C assuming the Gay-Berne potential of interaction.
1402 C
1403       implicit real*8 (a-h,o-z)
1404       include 'DIMENSIONS'
1405       include 'COMMON.GEO'
1406       include 'COMMON.VAR'
1407       include 'COMMON.LOCAL'
1408       include 'COMMON.CHAIN'
1409       include 'COMMON.DERIV'
1410       include 'COMMON.NAMES'
1411       include 'COMMON.INTERACT'
1412       include 'COMMON.IOUNITS'
1413       include 'COMMON.CALC'
1414       include 'COMMON.CONTROL'
1415       logical lprn
1416       evdw=0.0D0
1417 ccccc      energy_dec=.false.
1418 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       lprn=.false.
1421 c     if (icall.eq.0) lprn=.false.
1422       ind=0
1423       do i=iatsc_s,iatsc_e
1424         itypi=iabs(itype(i))
1425         if (itypi.eq.ntyp1) cycle
1426         itypi1=iabs(itype(i+1))
1427         xi=c(1,nres+i)
1428         yi=c(2,nres+i)
1429         zi=c(3,nres+i)
1430         dxi=dc_norm(1,nres+i)
1431         dyi=dc_norm(2,nres+i)
1432         dzi=dc_norm(3,nres+i)
1433 c        dsci_inv=dsc_inv(itypi)
1434         dsci_inv=vbld_inv(i+nres)
1435 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1436 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1437 C
1438 C Calculate SC interaction energy.
1439 C
1440         do iint=1,nint_gr(i)
1441           do j=istart(i,iint),iend(i,iint)
1442             ind=ind+1
1443             itypj=iabs(itype(j))
1444             if (itypj.eq.ntyp1) cycle
1445 c            dscj_inv=dsc_inv(itypj)
1446             dscj_inv=vbld_inv(j+nres)
1447 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1448 c     &       1.0d0/vbld(j+nres)
1449 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1450             sig0ij=sigma(itypi,itypj)
1451             chi1=chi(itypi,itypj)
1452             chi2=chi(itypj,itypi)
1453             chi12=chi1*chi2
1454             chip1=chip(itypi)
1455             chip2=chip(itypj)
1456             chip12=chip1*chip2
1457             alf1=alp(itypi)
1458             alf2=alp(itypj)
1459             alf12=0.5D0*(alf1+alf2)
1460 C For diagnostics only!!!
1461 c           chi1=0.0D0
1462 c           chi2=0.0D0
1463 c           chi12=0.0D0
1464 c           chip1=0.0D0
1465 c           chip2=0.0D0
1466 c           chip12=0.0D0
1467 c           alf1=0.0D0
1468 c           alf2=0.0D0
1469 c           alf12=0.0D0
1470             xj=c(1,nres+j)-xi
1471             yj=c(2,nres+j)-yi
1472             zj=c(3,nres+j)-zi
1473             dxj=dc_norm(1,nres+j)
1474             dyj=dc_norm(2,nres+j)
1475             dzj=dc_norm(3,nres+j)
1476 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1477 c            write (iout,*) "j",j," dc_norm",
1478 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480             rij=dsqrt(rrij)
1481 C Calculate angle-dependent terms of energy and contributions to their
1482 C derivatives.
1483             call sc_angular
1484             sigsq=1.0D0/sigsq
1485             sig=sig0ij*dsqrt(sigsq)
1486             rij_shift=1.0D0/rij-sig+sig0ij
1487 c for diagnostics; uncomment
1488 c            rij_shift=1.2*sig0ij
1489 C I hate to put IF's in the loops, but here don't have another choice!!!!
1490             if (rij_shift.le.0.0D0) then
1491               evdw=1.0D20
1492 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1493 cd     &        restyp(itypi),i,restyp(itypj),j,
1494 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1495               return
1496             endif
1497             sigder=-sig*sigsq
1498 c---------------------------------------------------------------
1499             rij_shift=1.0D0/rij_shift
1500             fac=rij_shift**expon
1501             e1=fac*fac*aa(itypi,itypj)
1502             e2=fac*bb(itypi,itypj)
1503             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1504             eps2der=evdwij*eps3rt
1505             eps3der=evdwij*eps2rt
1506 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1507 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1508             evdwij=evdwij*eps2rt*eps3rt
1509             evdw=evdw+evdwij
1510             if (lprn) then
1511             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1512             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1513             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1514      &        restyp(itypi),i,restyp(itypj),j,
1515      &        epsi,sigm,chi1,chi2,chip1,chip2,
1516      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1517      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1518      &        evdwij
1519             endif
1520
1521             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1522      &                        'evdw',i,j,evdwij
1523
1524 C Calculate gradient components.
1525             e1=e1*eps1*eps2rt**2*eps3rt**2
1526             fac=-expon*(e1+evdwij)*rij_shift
1527             sigder=fac*sigder
1528             fac=rij*fac
1529 c            fac=0.0d0
1530 C Calculate the radial part of the gradient
1531             gg(1)=xj*fac
1532             gg(2)=yj*fac
1533             gg(3)=zj*fac
1534 C Calculate angular part of the gradient.
1535             call sc_grad
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c      write (iout,*) "Number of loop steps in EGB:",ind
1540 cccc      energy_dec=.false.
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egbv(evdw)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne-Vorobjev potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       common /srutu/ icall
1561       logical lprn
1562       evdw=0.0D0
1563 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1564       evdw=0.0D0
1565       lprn=.false.
1566 c     if (icall.eq.0) lprn=.true.
1567       ind=0
1568       do i=iatsc_s,iatsc_e
1569         itypi=iabs(itype(i))
1570         if (itypi.eq.ntyp1) cycle
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 C
1581 C Calculate SC interaction energy.
1582 C
1583         do iint=1,nint_gr(i)
1584           do j=istart(i,iint),iend(i,iint)
1585             ind=ind+1
1586             itypj=iabs(itype(j))
1587             if (itypj.eq.ntyp1) cycle
1588 c            dscj_inv=dsc_inv(itypj)
1589             dscj_inv=vbld_inv(j+nres)
1590             sig0ij=sigma(itypi,itypj)
1591             r0ij=r0(itypi,itypj)
1592             chi1=chi(itypi,itypj)
1593             chi2=chi(itypj,itypi)
1594             chi12=chi1*chi2
1595             chip1=chip(itypi)
1596             chip2=chip(itypj)
1597             chip12=chip1*chip2
1598             alf1=alp(itypi)
1599             alf2=alp(itypj)
1600             alf12=0.5D0*(alf1+alf2)
1601 C For diagnostics only!!!
1602 c           chi1=0.0D0
1603 c           chi2=0.0D0
1604 c           chi12=0.0D0
1605 c           chip1=0.0D0
1606 c           chip2=0.0D0
1607 c           chip12=0.0D0
1608 c           alf1=0.0D0
1609 c           alf2=0.0D0
1610 c           alf12=0.0D0
1611             xj=c(1,nres+j)-xi
1612             yj=c(2,nres+j)-yi
1613             zj=c(3,nres+j)-zi
1614             dxj=dc_norm(1,nres+j)
1615             dyj=dc_norm(2,nres+j)
1616             dzj=dc_norm(3,nres+j)
1617             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1618             rij=dsqrt(rrij)
1619 C Calculate angle-dependent terms of energy and contributions to their
1620 C derivatives.
1621             call sc_angular
1622             sigsq=1.0D0/sigsq
1623             sig=sig0ij*dsqrt(sigsq)
1624             rij_shift=1.0D0/rij-sig+r0ij
1625 C I hate to put IF's in the loops, but here don't have another choice!!!!
1626             if (rij_shift.le.0.0D0) then
1627               evdw=1.0D20
1628               return
1629             endif
1630             sigder=-sig*sigsq
1631 c---------------------------------------------------------------
1632             rij_shift=1.0D0/rij_shift
1633             fac=rij_shift**expon
1634             e1=fac*fac*aa(itypi,itypj)
1635             e2=fac*bb(itypi,itypj)
1636             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1637             eps2der=evdwij*eps3rt
1638             eps3der=evdwij*eps2rt
1639             fac_augm=rrij**expon
1640             e_augm=augm(itypi,itypj)*fac_augm
1641             evdwij=evdwij*eps2rt*eps3rt
1642             evdw=evdw+evdwij+e_augm
1643             if (lprn) then
1644             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1645             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1646             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1647      &        restyp(itypi),i,restyp(itypj),j,
1648      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1649      &        chi1,chi2,chip1,chip2,
1650      &        eps1,eps2rt**2,eps3rt**2,
1651      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1652      &        evdwij+e_augm
1653             endif
1654 C Calculate gradient components.
1655             e1=e1*eps1*eps2rt**2*eps3rt**2
1656             fac=-expon*(e1+evdwij)*rij_shift
1657             sigder=fac*sigder
1658             fac=rij*fac-2*expon*rrij*e_augm
1659 C Calculate the radial part of the gradient
1660             gg(1)=xj*fac
1661             gg(2)=yj*fac
1662             gg(3)=zj*fac
1663 C Calculate angular part of the gradient.
1664             call sc_grad
1665           enddo      ! j
1666         enddo        ! iint
1667       enddo          ! i
1668       end
1669 C-----------------------------------------------------------------------------
1670       subroutine sc_angular
1671 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1672 C om12. Called by ebp, egb, and egbv.
1673       implicit none
1674       include 'COMMON.CALC'
1675       include 'COMMON.IOUNITS'
1676       erij(1)=xj*rij
1677       erij(2)=yj*rij
1678       erij(3)=zj*rij
1679       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1680       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1681       om12=dxi*dxj+dyi*dyj+dzi*dzj
1682       chiom12=chi12*om12
1683 C Calculate eps1(om12) and its derivative in om12
1684       faceps1=1.0D0-om12*chiom12
1685       faceps1_inv=1.0D0/faceps1
1686       eps1=dsqrt(faceps1_inv)
1687 C Following variable is eps1*deps1/dom12
1688       eps1_om12=faceps1_inv*chiom12
1689 c diagnostics only
1690 c      faceps1_inv=om12
1691 c      eps1=om12
1692 c      eps1_om12=1.0d0
1693 c      write (iout,*) "om12",om12," eps1",eps1
1694 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1695 C and om12.
1696       om1om2=om1*om2
1697       chiom1=chi1*om1
1698       chiom2=chi2*om2
1699       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1700       sigsq=1.0D0-facsig*faceps1_inv
1701       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1702       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1703       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1704 c diagnostics only
1705 c      sigsq=1.0d0
1706 c      sigsq_om1=0.0d0
1707 c      sigsq_om2=0.0d0
1708 c      sigsq_om12=0.0d0
1709 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1710 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1711 c     &    " eps1",eps1
1712 C Calculate eps2 and its derivatives in om1, om2, and om12.
1713       chipom1=chip1*om1
1714       chipom2=chip2*om2
1715       chipom12=chip12*om12
1716       facp=1.0D0-om12*chipom12
1717       facp_inv=1.0D0/facp
1718       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1719 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1720 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1721 C Following variable is the square root of eps2
1722       eps2rt=1.0D0-facp1*facp_inv
1723 C Following three variables are the derivatives of the square root of eps
1724 C in om1, om2, and om12.
1725       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1726       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1727       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1728 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1729       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1730 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1731 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1732 c     &  " eps2rt_om12",eps2rt_om12
1733 C Calculate whole angle-dependent part of epsilon and contributions
1734 C to its derivatives
1735       return
1736       end
1737 C----------------------------------------------------------------------------
1738       subroutine sc_grad
1739       implicit real*8 (a-h,o-z)
1740       include 'DIMENSIONS'
1741       include 'COMMON.CHAIN'
1742       include 'COMMON.DERIV'
1743       include 'COMMON.CALC'
1744       include 'COMMON.IOUNITS'
1745       double precision dcosom1(3),dcosom2(3)
1746       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1747       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1748       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1749      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1750 c diagnostics only
1751 c      eom1=0.0d0
1752 c      eom2=0.0d0
1753 c      eom12=evdwij*eps1_om12
1754 c end diagnostics
1755 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1756 c     &  " sigder",sigder
1757 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1758 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1759       do k=1,3
1760         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1761         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1762       enddo
1763       do k=1,3
1764         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1765       enddo
1766 c      write (iout,*) "gg",(gg(k),k=1,3)
1767       do k=1,3
1768         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1769      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1770      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1771         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1772      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1773      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1774 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1775 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1776 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1777 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1778       enddo
1779 C
1780 C Calculate the components of the gradient in DC and X
1781 C
1782 cgrad      do k=i,j-1
1783 cgrad        do l=1,3
1784 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1785 cgrad        enddo
1786 cgrad      enddo
1787       do l=1,3
1788         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1789         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1790       enddo
1791       return
1792       end
1793 C-----------------------------------------------------------------------
1794       subroutine e_softsphere(evdw)
1795 C
1796 C This subroutine calculates the interaction energy of nonbonded side chains
1797 C assuming the LJ potential of interaction.
1798 C
1799       implicit real*8 (a-h,o-z)
1800       include 'DIMENSIONS'
1801       parameter (accur=1.0d-10)
1802       include 'COMMON.GEO'
1803       include 'COMMON.VAR'
1804       include 'COMMON.LOCAL'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.INTERACT'
1808       include 'COMMON.TORSION'
1809       include 'COMMON.SBRIDGE'
1810       include 'COMMON.NAMES'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CONTACTS'
1813       dimension gg(3)
1814 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1815       evdw=0.0D0
1816       do i=iatsc_s,iatsc_e
1817         itypi=iabs(itype(i))
1818         if (itypi.eq.ntyp1) cycle
1819         itypi1=iabs(itype(i+1))
1820         xi=c(1,nres+i)
1821         yi=c(2,nres+i)
1822         zi=c(3,nres+i)
1823 C
1824 C Calculate SC interaction energy.
1825 C
1826         do iint=1,nint_gr(i)
1827 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1828 cd   &                  'iend=',iend(i,iint)
1829           do j=istart(i,iint),iend(i,iint)
1830             itypj=iabs(itype(j))
1831             if (itypj.eq.ntyp1) cycle
1832             xj=c(1,nres+j)-xi
1833             yj=c(2,nres+j)-yi
1834             zj=c(3,nres+j)-zi
1835             rij=xj*xj+yj*yj+zj*zj
1836 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1837             r0ij=r0(itypi,itypj)
1838             r0ijsq=r0ij*r0ij
1839 c            print *,i,j,r0ij,dsqrt(rij)
1840             if (rij.lt.r0ijsq) then
1841               evdwij=0.25d0*(rij-r0ijsq)**2
1842               fac=rij-r0ijsq
1843             else
1844               evdwij=0.0d0
1845               fac=0.0d0
1846             endif
1847             evdw=evdw+evdwij
1848 C
1849 C Calculate the components of the gradient in DC and X
1850 C
1851             gg(1)=xj*fac
1852             gg(2)=yj*fac
1853             gg(3)=zj*fac
1854             do k=1,3
1855               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1856               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1857               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1858               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1859             enddo
1860 cgrad            do k=i,j-1
1861 cgrad              do l=1,3
1862 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1863 cgrad              enddo
1864 cgrad            enddo
1865           enddo ! j
1866         enddo ! iint
1867       enddo ! i
1868       return
1869       end
1870 C--------------------------------------------------------------------------
1871       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1872      &              eello_turn4)
1873 C
1874 C Soft-sphere potential of p-p interaction
1875 C
1876       implicit real*8 (a-h,o-z)
1877       include 'DIMENSIONS'
1878       include 'COMMON.CONTROL'
1879       include 'COMMON.IOUNITS'
1880       include 'COMMON.GEO'
1881       include 'COMMON.VAR'
1882       include 'COMMON.LOCAL'
1883       include 'COMMON.CHAIN'
1884       include 'COMMON.DERIV'
1885       include 'COMMON.INTERACT'
1886       include 'COMMON.CONTACTS'
1887       include 'COMMON.TORSION'
1888       include 'COMMON.VECTORS'
1889       include 'COMMON.FFIELD'
1890       dimension ggg(3)
1891 cd      write(iout,*) 'In EELEC_soft_sphere'
1892       ees=0.0D0
1893       evdw1=0.0D0
1894       eel_loc=0.0d0
1895       eello_turn3=0.0d0
1896       eello_turn4=0.0d0
1897       ind=0
1898       do i=iatel_s,iatel_e
1899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1900         dxi=dc(1,i)
1901         dyi=dc(2,i)
1902         dzi=dc(3,i)
1903         xmedi=c(1,i)+0.5d0*dxi
1904         ymedi=c(2,i)+0.5d0*dyi
1905         zmedi=c(3,i)+0.5d0*dzi
1906         num_conti=0
1907 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1908         do j=ielstart(i),ielend(i)
1909           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1910           ind=ind+1
1911           iteli=itel(i)
1912           itelj=itel(j)
1913           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1914           r0ij=rpp(iteli,itelj)
1915           r0ijsq=r0ij*r0ij
1916           dxj=dc(1,j)
1917           dyj=dc(2,j)
1918           dzj=dc(3,j)
1919           xj=c(1,j)+0.5D0*dxj-xmedi
1920           yj=c(2,j)+0.5D0*dyj-ymedi
1921           zj=c(3,j)+0.5D0*dzj-zmedi
1922           rij=xj*xj+yj*yj+zj*zj
1923           if (rij.lt.r0ijsq) then
1924             evdw1ij=0.25d0*(rij-r0ijsq)**2
1925             fac=rij-r0ijsq
1926           else
1927             evdw1ij=0.0d0
1928             fac=0.0d0
1929           endif
1930           evdw1=evdw1+evdw1ij
1931 C
1932 C Calculate contributions to the Cartesian gradient.
1933 C
1934           ggg(1)=fac*xj
1935           ggg(2)=fac*yj
1936           ggg(3)=fac*zj
1937           do k=1,3
1938             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1940           enddo
1941 *
1942 * Loop over residues i+1 thru j-1.
1943 *
1944 cgrad          do k=i+1,j-1
1945 cgrad            do l=1,3
1946 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1947 cgrad            enddo
1948 cgrad          enddo
1949         enddo ! j
1950       enddo   ! i
1951 cgrad      do i=nnt,nct-1
1952 cgrad        do k=1,3
1953 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1954 cgrad        enddo
1955 cgrad        do j=i+1,nct-1
1956 cgrad          do k=1,3
1957 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1958 cgrad          enddo
1959 cgrad        enddo
1960 cgrad      enddo
1961       return
1962       end
1963 c------------------------------------------------------------------------------
1964       subroutine vec_and_deriv
1965       implicit real*8 (a-h,o-z)
1966       include 'DIMENSIONS'
1967 #ifdef MPI
1968       include 'mpif.h'
1969 #endif
1970       include 'COMMON.IOUNITS'
1971       include 'COMMON.GEO'
1972       include 'COMMON.VAR'
1973       include 'COMMON.LOCAL'
1974       include 'COMMON.CHAIN'
1975       include 'COMMON.VECTORS'
1976       include 'COMMON.SETUP'
1977       include 'COMMON.TIME1'
1978       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1979 C Compute the local reference systems. For reference system (i), the
1980 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1981 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1982 #ifdef PARVEC
1983       do i=ivec_start,ivec_end
1984 #else
1985       do i=1,nres-1
1986 #endif
1987           if (i.eq.nres-1) then
1988 C Case of the last full residue
1989 C Compute the Z-axis
1990             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1991             costh=dcos(pi-theta(nres))
1992             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1993             do k=1,3
1994               uz(k,i)=fac*uz(k,i)
1995             enddo
1996 C Compute the derivatives of uz
1997             uzder(1,1,1)= 0.0d0
1998             uzder(2,1,1)=-dc_norm(3,i-1)
1999             uzder(3,1,1)= dc_norm(2,i-1)
2000             uzder(1,2,1)= dc_norm(3,i-1)
2001             uzder(2,2,1)= 0.0d0
2002             uzder(3,2,1)=-dc_norm(1,i-1)
2003             uzder(1,3,1)=-dc_norm(2,i-1)
2004             uzder(2,3,1)= dc_norm(1,i-1)
2005             uzder(3,3,1)= 0.0d0
2006             uzder(1,1,2)= 0.0d0
2007             uzder(2,1,2)= dc_norm(3,i)
2008             uzder(3,1,2)=-dc_norm(2,i)
2009             uzder(1,2,2)=-dc_norm(3,i)
2010             uzder(2,2,2)= 0.0d0
2011             uzder(3,2,2)= dc_norm(1,i)
2012             uzder(1,3,2)= dc_norm(2,i)
2013             uzder(2,3,2)=-dc_norm(1,i)
2014             uzder(3,3,2)= 0.0d0
2015 C Compute the Y-axis
2016             facy=fac
2017             do k=1,3
2018               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2019             enddo
2020 C Compute the derivatives of uy
2021             do j=1,3
2022               do k=1,3
2023                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2024      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2025                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2026               enddo
2027               uyder(j,j,1)=uyder(j,j,1)-costh
2028               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2029             enddo
2030             do j=1,2
2031               do k=1,3
2032                 do l=1,3
2033                   uygrad(l,k,j,i)=uyder(l,k,j)
2034                   uzgrad(l,k,j,i)=uzder(l,k,j)
2035                 enddo
2036               enddo
2037             enddo
2038             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2039             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2040             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2041             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2042           else
2043 C Other residues
2044 C Compute the Z-axis
2045             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2046             costh=dcos(pi-theta(i+2))
2047             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2048             do k=1,3
2049               uz(k,i)=fac*uz(k,i)
2050             enddo
2051 C Compute the derivatives of uz
2052             uzder(1,1,1)= 0.0d0
2053             uzder(2,1,1)=-dc_norm(3,i+1)
2054             uzder(3,1,1)= dc_norm(2,i+1)
2055             uzder(1,2,1)= dc_norm(3,i+1)
2056             uzder(2,2,1)= 0.0d0
2057             uzder(3,2,1)=-dc_norm(1,i+1)
2058             uzder(1,3,1)=-dc_norm(2,i+1)
2059             uzder(2,3,1)= dc_norm(1,i+1)
2060             uzder(3,3,1)= 0.0d0
2061             uzder(1,1,2)= 0.0d0
2062             uzder(2,1,2)= dc_norm(3,i)
2063             uzder(3,1,2)=-dc_norm(2,i)
2064             uzder(1,2,2)=-dc_norm(3,i)
2065             uzder(2,2,2)= 0.0d0
2066             uzder(3,2,2)= dc_norm(1,i)
2067             uzder(1,3,2)= dc_norm(2,i)
2068             uzder(2,3,2)=-dc_norm(1,i)
2069             uzder(3,3,2)= 0.0d0
2070 C Compute the Y-axis
2071             facy=fac
2072             do k=1,3
2073               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2074             enddo
2075 C Compute the derivatives of uy
2076             do j=1,3
2077               do k=1,3
2078                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2079      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2080                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2081               enddo
2082               uyder(j,j,1)=uyder(j,j,1)-costh
2083               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2084             enddo
2085             do j=1,2
2086               do k=1,3
2087                 do l=1,3
2088                   uygrad(l,k,j,i)=uyder(l,k,j)
2089                   uzgrad(l,k,j,i)=uzder(l,k,j)
2090                 enddo
2091               enddo
2092             enddo
2093             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2094             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2095             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2096             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2097           endif
2098       enddo
2099       do i=1,nres-1
2100         vbld_inv_temp(1)=vbld_inv(i+1)
2101         if (i.lt.nres-1) then
2102           vbld_inv_temp(2)=vbld_inv(i+2)
2103           else
2104           vbld_inv_temp(2)=vbld_inv(i)
2105           endif
2106         do j=1,2
2107           do k=1,3
2108             do l=1,3
2109               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2110               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2111             enddo
2112           enddo
2113         enddo
2114       enddo
2115 #if defined(PARVEC) && defined(MPI)
2116       if (nfgtasks1.gt.1) then
2117         time00=MPI_Wtime()
2118 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2119 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2120 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2121         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2122      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2123      &   FG_COMM1,IERR)
2124         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2125      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2126      &   FG_COMM1,IERR)
2127         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2128      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2129      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2130         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2131      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2132      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2133         time_gather=time_gather+MPI_Wtime()-time00
2134       endif
2135 c      if (fg_rank.eq.0) then
2136 c        write (iout,*) "Arrays UY and UZ"
2137 c        do i=1,nres-1
2138 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2139 c     &     (uz(k,i),k=1,3)
2140 c        enddo
2141 c      endif
2142 #endif
2143       return
2144       end
2145 C-----------------------------------------------------------------------------
2146       subroutine check_vecgrad
2147       implicit real*8 (a-h,o-z)
2148       include 'DIMENSIONS'
2149       include 'COMMON.IOUNITS'
2150       include 'COMMON.GEO'
2151       include 'COMMON.VAR'
2152       include 'COMMON.LOCAL'
2153       include 'COMMON.CHAIN'
2154       include 'COMMON.VECTORS'
2155       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2156       dimension uyt(3,maxres),uzt(3,maxres)
2157       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2158       double precision delta /1.0d-7/
2159       call vec_and_deriv
2160 cd      do i=1,nres
2161 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2162 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2163 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2164 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2165 cd     &     (dc_norm(if90,i),if90=1,3)
2166 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2167 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2168 cd          write(iout,'(a)')
2169 cd      enddo
2170       do i=1,nres
2171         do j=1,2
2172           do k=1,3
2173             do l=1,3
2174               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2175               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2176             enddo
2177           enddo
2178         enddo
2179       enddo
2180       call vec_and_deriv
2181       do i=1,nres
2182         do j=1,3
2183           uyt(j,i)=uy(j,i)
2184           uzt(j,i)=uz(j,i)
2185         enddo
2186       enddo
2187       do i=1,nres
2188 cd        write (iout,*) 'i=',i
2189         do k=1,3
2190           erij(k)=dc_norm(k,i)
2191         enddo
2192         do j=1,3
2193           do k=1,3
2194             dc_norm(k,i)=erij(k)
2195           enddo
2196           dc_norm(j,i)=dc_norm(j,i)+delta
2197 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2198 c          do k=1,3
2199 c            dc_norm(k,i)=dc_norm(k,i)/fac
2200 c          enddo
2201 c          write (iout,*) (dc_norm(k,i),k=1,3)
2202 c          write (iout,*) (erij(k),k=1,3)
2203           call vec_and_deriv
2204           do k=1,3
2205             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2206             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2207             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2208             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2209           enddo
2210 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2211 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2212 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2213         enddo
2214         do k=1,3
2215           dc_norm(k,i)=erij(k)
2216         enddo
2217 cd        do k=1,3
2218 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2219 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2220 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2221 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2222 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2223 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2224 cd          write (iout,'(a)')
2225 cd        enddo
2226       enddo
2227       return
2228       end
2229 C--------------------------------------------------------------------------
2230       subroutine set_matrices
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233 #ifdef MPI
2234       include "mpif.h"
2235       include "COMMON.SETUP"
2236       integer IERR
2237       integer status(MPI_STATUS_SIZE)
2238 #endif
2239       include 'COMMON.IOUNITS'
2240       include 'COMMON.GEO'
2241       include 'COMMON.VAR'
2242       include 'COMMON.LOCAL'
2243       include 'COMMON.CHAIN'
2244       include 'COMMON.DERIV'
2245       include 'COMMON.INTERACT'
2246       include 'COMMON.CONTACTS'
2247       include 'COMMON.TORSION'
2248       include 'COMMON.VECTORS'
2249       include 'COMMON.FFIELD'
2250       double precision auxvec(2),auxmat(2,2)
2251 C
2252 C Compute the virtual-bond-torsional-angle dependent quantities needed
2253 C to calculate the el-loc multibody terms of various order.
2254 C
2255 #ifdef PARMAT
2256       do i=ivec_start+2,ivec_end+2
2257 #else
2258       do i=3,nres+1
2259 #endif
2260         if (i .lt. nres+1) then
2261           sin1=dsin(phi(i))
2262           cos1=dcos(phi(i))
2263           sintab(i-2)=sin1
2264           costab(i-2)=cos1
2265           obrot(1,i-2)=cos1
2266           obrot(2,i-2)=sin1
2267           sin2=dsin(2*phi(i))
2268           cos2=dcos(2*phi(i))
2269           sintab2(i-2)=sin2
2270           costab2(i-2)=cos2
2271           obrot2(1,i-2)=cos2
2272           obrot2(2,i-2)=sin2
2273           Ug(1,1,i-2)=-cos1
2274           Ug(1,2,i-2)=-sin1
2275           Ug(2,1,i-2)=-sin1
2276           Ug(2,2,i-2)= cos1
2277           Ug2(1,1,i-2)=-cos2
2278           Ug2(1,2,i-2)=-sin2
2279           Ug2(2,1,i-2)=-sin2
2280           Ug2(2,2,i-2)= cos2
2281         else
2282           costab(i-2)=1.0d0
2283           sintab(i-2)=0.0d0
2284           obrot(1,i-2)=1.0d0
2285           obrot(2,i-2)=0.0d0
2286           obrot2(1,i-2)=0.0d0
2287           obrot2(2,i-2)=0.0d0
2288           Ug(1,1,i-2)=1.0d0
2289           Ug(1,2,i-2)=0.0d0
2290           Ug(2,1,i-2)=0.0d0
2291           Ug(2,2,i-2)=1.0d0
2292           Ug2(1,1,i-2)=0.0d0
2293           Ug2(1,2,i-2)=0.0d0
2294           Ug2(2,1,i-2)=0.0d0
2295           Ug2(2,2,i-2)=0.0d0
2296         endif
2297         if (i .gt. 3 .and. i .lt. nres+1) then
2298           obrot_der(1,i-2)=-sin1
2299           obrot_der(2,i-2)= cos1
2300           Ugder(1,1,i-2)= sin1
2301           Ugder(1,2,i-2)=-cos1
2302           Ugder(2,1,i-2)=-cos1
2303           Ugder(2,2,i-2)=-sin1
2304           dwacos2=cos2+cos2
2305           dwasin2=sin2+sin2
2306           obrot2_der(1,i-2)=-dwasin2
2307           obrot2_der(2,i-2)= dwacos2
2308           Ug2der(1,1,i-2)= dwasin2
2309           Ug2der(1,2,i-2)=-dwacos2
2310           Ug2der(2,1,i-2)=-dwacos2
2311           Ug2der(2,2,i-2)=-dwasin2
2312         else
2313           obrot_der(1,i-2)=0.0d0
2314           obrot_der(2,i-2)=0.0d0
2315           Ugder(1,1,i-2)=0.0d0
2316           Ugder(1,2,i-2)=0.0d0
2317           Ugder(2,1,i-2)=0.0d0
2318           Ugder(2,2,i-2)=0.0d0
2319           obrot2_der(1,i-2)=0.0d0
2320           obrot2_der(2,i-2)=0.0d0
2321           Ug2der(1,1,i-2)=0.0d0
2322           Ug2der(1,2,i-2)=0.0d0
2323           Ug2der(2,1,i-2)=0.0d0
2324           Ug2der(2,2,i-2)=0.0d0
2325         endif
2326 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2327         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2328           iti = itortyp(itype(i-2))
2329         else
2330           iti=ntortyp+1
2331         endif
2332 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2333         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2334           iti1 = itortyp(itype(i-1))
2335         else
2336           iti1=ntortyp+1
2337         endif
2338 cd        write (iout,*) '*******i',i,' iti1',iti
2339 cd        write (iout,*) 'b1',b1(:,iti)
2340 cd        write (iout,*) 'b2',b2(:,iti)
2341 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2342 c        if (i .gt. iatel_s+2) then
2343         if (i .gt. nnt+2) then
2344           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2345           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2346           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2347      &    then
2348           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2349           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2350           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2351           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2352           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2353           endif
2354         else
2355           do k=1,2
2356             Ub2(k,i-2)=0.0d0
2357             Ctobr(k,i-2)=0.0d0
2358             Dtobr2(k,i-2)=0.0d0
2359             do l=1,2
2360               EUg(l,k,i-2)=0.0d0
2361               CUg(l,k,i-2)=0.0d0
2362               DUg(l,k,i-2)=0.0d0
2363               DtUg2(l,k,i-2)=0.0d0
2364             enddo
2365           enddo
2366         endif
2367         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2368         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2369         do k=1,2
2370           muder(k,i-2)=Ub2der(k,i-2)
2371         enddo
2372 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2373         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2374           if (itype(i-1).le.ntyp) then
2375             iti1 = itortyp(itype(i-1))
2376           else
2377             iti1=ntortyp+1
2378           endif
2379         else
2380           iti1=ntortyp+1
2381         endif
2382         do k=1,2
2383           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2384         enddo
2385 cd        write (iout,*) 'mu ',mu(:,i-2)
2386 cd        write (iout,*) 'mu1',mu1(:,i-2)
2387 cd        write (iout,*) 'mu2',mu2(:,i-2)
2388         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2389      &  then
2390         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2391         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2392         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2393         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2394         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2395 C Vectors and matrices dependent on a single virtual-bond dihedral.
2396         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2397         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2398         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2399         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2400         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2401         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2402         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2403         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2404         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2405         endif
2406       enddo
2407 C Matrices dependent on two consecutive virtual-bond dihedrals.
2408 C The order of matrices is from left to right.
2409       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2410      &then
2411 c      do i=max0(ivec_start,2),ivec_end
2412       do i=2,nres-1
2413         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2414         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2415         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2416         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2417         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2418         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2419         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2420         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2421       enddo
2422       endif
2423 #if defined(MPI) && defined(PARMAT)
2424 #ifdef DEBUG
2425 c      if (fg_rank.eq.0) then
2426         write (iout,*) "Arrays UG and UGDER before GATHER"
2427         do i=1,nres-1
2428           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2429      &     ((ug(l,k,i),l=1,2),k=1,2),
2430      &     ((ugder(l,k,i),l=1,2),k=1,2)
2431         enddo
2432         write (iout,*) "Arrays UG2 and UG2DER"
2433         do i=1,nres-1
2434           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2435      &     ((ug2(l,k,i),l=1,2),k=1,2),
2436      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2437         enddo
2438         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2439         do i=1,nres-1
2440           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2441      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2442      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2443         enddo
2444         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2445         do i=1,nres-1
2446           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2447      &     costab(i),sintab(i),costab2(i),sintab2(i)
2448         enddo
2449         write (iout,*) "Array MUDER"
2450         do i=1,nres-1
2451           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2452         enddo
2453 c      endif
2454 #endif
2455       if (nfgtasks.gt.1) then
2456         time00=MPI_Wtime()
2457 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2458 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2459 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2460 #ifdef MATGATHER
2461         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2462      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2463      &   FG_COMM1,IERR)
2464         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2465      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2466      &   FG_COMM1,IERR)
2467         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2468      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2469      &   FG_COMM1,IERR)
2470         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2471      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2472      &   FG_COMM1,IERR)
2473         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2474      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2475      &   FG_COMM1,IERR)
2476         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2477      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2478      &   FG_COMM1,IERR)
2479         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2480      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2481      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2482         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2483      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2484      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2485         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2486      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2487      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2488         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2489      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2490      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2491         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2492      &  then
2493         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2494      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2495      &   FG_COMM1,IERR)
2496         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2497      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2498      &   FG_COMM1,IERR)
2499         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2500      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2501      &   FG_COMM1,IERR)
2502        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2503      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2504      &   FG_COMM1,IERR)
2505         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2506      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2507      &   FG_COMM1,IERR)
2508         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2509      &   ivec_count(fg_rank1),
2510      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2511      &   FG_COMM1,IERR)
2512         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2513      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2514      &   FG_COMM1,IERR)
2515         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2516      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2517      &   FG_COMM1,IERR)
2518         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2519      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2528      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2529      &   FG_COMM1,IERR)
2530         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2531      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2532      &   FG_COMM1,IERR)
2533         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2534      &   ivec_count(fg_rank1),
2535      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2536      &   FG_COMM1,IERR)
2537         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2538      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2539      &   FG_COMM1,IERR)
2540        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2541      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2542      &   FG_COMM1,IERR)
2543         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2544      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2545      &   FG_COMM1,IERR)
2546        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2547      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2548      &   FG_COMM1,IERR)
2549         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2550      &   ivec_count(fg_rank1),
2551      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2552      &   FG_COMM1,IERR)
2553         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2554      &   ivec_count(fg_rank1),
2555      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2556      &   FG_COMM1,IERR)
2557         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2558      &   ivec_count(fg_rank1),
2559      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2560      &   MPI_MAT2,FG_COMM1,IERR)
2561         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2562      &   ivec_count(fg_rank1),
2563      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2564      &   MPI_MAT2,FG_COMM1,IERR)
2565         endif
2566 #else
2567 c Passes matrix info through the ring
2568       isend=fg_rank1
2569       irecv=fg_rank1-1
2570       if (irecv.lt.0) irecv=nfgtasks1-1
2571       iprev=irecv
2572       inext=fg_rank1+1
2573       if (inext.ge.nfgtasks1) inext=0
2574       do i=1,nfgtasks1-1
2575 c        write (iout,*) "isend",isend," irecv",irecv
2576 c        call flush(iout)
2577         lensend=lentyp(isend)
2578         lenrecv=lentyp(irecv)
2579 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2580 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2581 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2582 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2583 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2584 c        write (iout,*) "Gather ROTAT1"
2585 c        call flush(iout)
2586 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2587 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2588 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2589 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2590 c        write (iout,*) "Gather ROTAT2"
2591 c        call flush(iout)
2592         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2593      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2594      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2595      &   iprev,4400+irecv,FG_COMM,status,IERR)
2596 c        write (iout,*) "Gather ROTAT_OLD"
2597 c        call flush(iout)
2598         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2599      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2600      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2601      &   iprev,5500+irecv,FG_COMM,status,IERR)
2602 c        write (iout,*) "Gather PRECOMP11"
2603 c        call flush(iout)
2604         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2605      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2606      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2607      &   iprev,6600+irecv,FG_COMM,status,IERR)
2608 c        write (iout,*) "Gather PRECOMP12"
2609 c        call flush(iout)
2610         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2611      &  then
2612         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2613      &   MPI_ROTAT2(lensend),inext,7700+isend,
2614      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2615      &   iprev,7700+irecv,FG_COMM,status,IERR)
2616 c        write (iout,*) "Gather PRECOMP21"
2617 c        call flush(iout)
2618         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2619      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2620      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2621      &   iprev,8800+irecv,FG_COMM,status,IERR)
2622 c        write (iout,*) "Gather PRECOMP22"
2623 c        call flush(iout)
2624         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2625      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2626      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2627      &   MPI_PRECOMP23(lenrecv),
2628      &   iprev,9900+irecv,FG_COMM,status,IERR)
2629 c        write (iout,*) "Gather PRECOMP23"
2630 c        call flush(iout)
2631         endif
2632         isend=irecv
2633         irecv=irecv-1
2634         if (irecv.lt.0) irecv=nfgtasks1-1
2635       enddo
2636 #endif
2637         time_gather=time_gather+MPI_Wtime()-time00
2638       endif
2639 #ifdef DEBUG
2640 c      if (fg_rank.eq.0) then
2641         write (iout,*) "Arrays UG and UGDER"
2642         do i=1,nres-1
2643           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2644      &     ((ug(l,k,i),l=1,2),k=1,2),
2645      &     ((ugder(l,k,i),l=1,2),k=1,2)
2646         enddo
2647         write (iout,*) "Arrays UG2 and UG2DER"
2648         do i=1,nres-1
2649           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2650      &     ((ug2(l,k,i),l=1,2),k=1,2),
2651      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2652         enddo
2653         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2654         do i=1,nres-1
2655           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2656      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2657      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2658         enddo
2659         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2660         do i=1,nres-1
2661           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2662      &     costab(i),sintab(i),costab2(i),sintab2(i)
2663         enddo
2664         write (iout,*) "Array MUDER"
2665         do i=1,nres-1
2666           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2667         enddo
2668 c      endif
2669 #endif
2670 #endif
2671 cd      do i=1,nres
2672 cd        iti = itortyp(itype(i))
2673 cd        write (iout,*) i
2674 cd        do j=1,2
2675 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2676 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2677 cd        enddo
2678 cd      enddo
2679       return
2680       end
2681 C--------------------------------------------------------------------------
2682       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2683 C
2684 C This subroutine calculates the average interaction energy and its gradient
2685 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2686 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2687 C The potential depends both on the distance of peptide-group centers and on
2688 C the orientation of the CA-CA virtual bonds.
2689 C
2690       implicit real*8 (a-h,o-z)
2691 #ifdef MPI
2692       include 'mpif.h'
2693 #endif
2694       include 'DIMENSIONS'
2695       include 'COMMON.CONTROL'
2696       include 'COMMON.SETUP'
2697       include 'COMMON.IOUNITS'
2698       include 'COMMON.GEO'
2699       include 'COMMON.VAR'
2700       include 'COMMON.LOCAL'
2701       include 'COMMON.CHAIN'
2702       include 'COMMON.DERIV'
2703       include 'COMMON.INTERACT'
2704       include 'COMMON.CONTACTS'
2705       include 'COMMON.TORSION'
2706       include 'COMMON.VECTORS'
2707       include 'COMMON.FFIELD'
2708       include 'COMMON.TIME1'
2709       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2710      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2711       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2712      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2713       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2714      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2715      &    num_conti,j1,j2
2716 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2717 #ifdef MOMENT
2718       double precision scal_el /1.0d0/
2719 #else
2720       double precision scal_el /0.5d0/
2721 #endif
2722 C 12/13/98
2723 C 13-go grudnia roku pamietnego...
2724       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2725      &                   0.0d0,1.0d0,0.0d0,
2726      &                   0.0d0,0.0d0,1.0d0/
2727 cd      write(iout,*) 'In EELEC'
2728 cd      do i=1,nloctyp
2729 cd        write(iout,*) 'Type',i
2730 cd        write(iout,*) 'B1',B1(:,i)
2731 cd        write(iout,*) 'B2',B2(:,i)
2732 cd        write(iout,*) 'CC',CC(:,:,i)
2733 cd        write(iout,*) 'DD',DD(:,:,i)
2734 cd        write(iout,*) 'EE',EE(:,:,i)
2735 cd      enddo
2736 cd      call check_vecgrad
2737 cd      stop
2738       if (icheckgrad.eq.1) then
2739         do i=1,nres-1
2740           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2741           do k=1,3
2742             dc_norm(k,i)=dc(k,i)*fac
2743           enddo
2744 c          write (iout,*) 'i',i,' fac',fac
2745         enddo
2746       endif
2747       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2748      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2749      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2750 c        call vec_and_deriv
2751 #ifdef TIMING
2752         time01=MPI_Wtime()
2753 #endif
2754         call set_matrices
2755 #ifdef TIMING
2756         time_mat=time_mat+MPI_Wtime()-time01
2757 #endif
2758       endif
2759 cd      do i=1,nres-1
2760 cd        write (iout,*) 'i=',i
2761 cd        do k=1,3
2762 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2763 cd        enddo
2764 cd        do k=1,3
2765 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2766 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2767 cd        enddo
2768 cd      enddo
2769       t_eelecij=0.0d0
2770       ees=0.0D0
2771       evdw1=0.0D0
2772       eel_loc=0.0d0
2773       eello_turn3=0.0d0
2774       eello_turn4=0.0d0
2775       ind=0
2776       do i=1,nres
2777         num_cont_hb(i)=0
2778       enddo
2779 cd      print '(a)','Enter EELEC'
2780 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2781       do i=1,nres
2782         gel_loc_loc(i)=0.0d0
2783         gcorr_loc(i)=0.0d0
2784       enddo
2785 c
2786 c
2787 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2788 C
2789 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2790 C
2791       do i=iturn3_start,iturn3_end
2792         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2793      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2794         dxi=dc(1,i)
2795         dyi=dc(2,i)
2796         dzi=dc(3,i)
2797         dx_normi=dc_norm(1,i)
2798         dy_normi=dc_norm(2,i)
2799         dz_normi=dc_norm(3,i)
2800         xmedi=c(1,i)+0.5d0*dxi
2801         ymedi=c(2,i)+0.5d0*dyi
2802         zmedi=c(3,i)+0.5d0*dzi
2803         num_conti=0
2804         call eelecij(i,i+2,ees,evdw1,eel_loc)
2805         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2806         num_cont_hb(i)=num_conti
2807       enddo
2808       do i=iturn4_start,iturn4_end
2809         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2810      &    .or. itype(i+3).eq.ntyp1
2811      &    .or. itype(i+4).eq.ntyp1) cycle
2812         dxi=dc(1,i)
2813         dyi=dc(2,i)
2814         dzi=dc(3,i)
2815         dx_normi=dc_norm(1,i)
2816         dy_normi=dc_norm(2,i)
2817         dz_normi=dc_norm(3,i)
2818         xmedi=c(1,i)+0.5d0*dxi
2819         ymedi=c(2,i)+0.5d0*dyi
2820         zmedi=c(3,i)+0.5d0*dzi
2821         num_conti=num_cont_hb(i)
2822         call eelecij(i,i+3,ees,evdw1,eel_loc)
2823         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2824      &   call eturn4(i,eello_turn4)
2825         num_cont_hb(i)=num_conti
2826       enddo   ! i
2827 c
2828 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2829 c
2830       do i=iatel_s,iatel_e
2831         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2832         dxi=dc(1,i)
2833         dyi=dc(2,i)
2834         dzi=dc(3,i)
2835         dx_normi=dc_norm(1,i)
2836         dy_normi=dc_norm(2,i)
2837         dz_normi=dc_norm(3,i)
2838         xmedi=c(1,i)+0.5d0*dxi
2839         ymedi=c(2,i)+0.5d0*dyi
2840         zmedi=c(3,i)+0.5d0*dzi
2841 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2842         num_conti=num_cont_hb(i)
2843         do j=ielstart(i),ielend(i)
2844 c          write (iout,*) i,j,itype(i),itype(j)
2845           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2846           call eelecij(i,j,ees,evdw1,eel_loc)
2847         enddo ! j
2848         num_cont_hb(i)=num_conti
2849       enddo   ! i
2850 c      write (iout,*) "Number of loop steps in EELEC:",ind
2851 cd      do i=1,nres
2852 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2853 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2854 cd      enddo
2855 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2856 ccc      eel_loc=eel_loc+eello_turn3
2857 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2858       return
2859       end
2860 C-------------------------------------------------------------------------------
2861       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2862       implicit real*8 (a-h,o-z)
2863       include 'DIMENSIONS'
2864 #ifdef MPI
2865       include "mpif.h"
2866 #endif
2867       include 'COMMON.CONTROL'
2868       include 'COMMON.IOUNITS'
2869       include 'COMMON.GEO'
2870       include 'COMMON.VAR'
2871       include 'COMMON.LOCAL'
2872       include 'COMMON.CHAIN'
2873       include 'COMMON.DERIV'
2874       include 'COMMON.INTERACT'
2875       include 'COMMON.CONTACTS'
2876       include 'COMMON.TORSION'
2877       include 'COMMON.VECTORS'
2878       include 'COMMON.FFIELD'
2879       include 'COMMON.TIME1'
2880       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2881      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2882       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2883      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2884       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2885      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2886      &    num_conti,j1,j2
2887 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2888 #ifdef MOMENT
2889       double precision scal_el /1.0d0/
2890 #else
2891       double precision scal_el /0.5d0/
2892 #endif
2893 C 12/13/98
2894 C 13-go grudnia roku pamietnego...
2895       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2896      &                   0.0d0,1.0d0,0.0d0,
2897      &                   0.0d0,0.0d0,1.0d0/
2898 c          time00=MPI_Wtime()
2899 cd      write (iout,*) "eelecij",i,j
2900 c          ind=ind+1
2901           iteli=itel(i)
2902           itelj=itel(j)
2903           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2904           aaa=app(iteli,itelj)
2905           bbb=bpp(iteli,itelj)
2906           ael6i=ael6(iteli,itelj)
2907           ael3i=ael3(iteli,itelj)
2908           dxj=dc(1,j)
2909           dyj=dc(2,j)
2910           dzj=dc(3,j)
2911           dx_normj=dc_norm(1,j)
2912           dy_normj=dc_norm(2,j)
2913           dz_normj=dc_norm(3,j)
2914           xj=c(1,j)+0.5D0*dxj-xmedi
2915           yj=c(2,j)+0.5D0*dyj-ymedi
2916           zj=c(3,j)+0.5D0*dzj-zmedi
2917           rij=xj*xj+yj*yj+zj*zj
2918           rrmij=1.0D0/rij
2919           rij=dsqrt(rij)
2920           rmij=1.0D0/rij
2921           r3ij=rrmij*rmij
2922           r6ij=r3ij*r3ij
2923           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2924           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2925           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2926           fac=cosa-3.0D0*cosb*cosg
2927           ev1=aaa*r6ij*r6ij
2928 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2929           if (j.eq.i+2) ev1=scal_el*ev1
2930           ev2=bbb*r6ij
2931           fac3=ael6i*r6ij
2932           fac4=ael3i*r3ij
2933           evdwij=ev1+ev2
2934           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2935           el2=fac4*fac
2936           eesij=el1+el2
2937 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2938           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2939           ees=ees+eesij
2940           evdw1=evdw1+evdwij
2941 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2942 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2943 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2944 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2945
2946           if (energy_dec) then
2947               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2948      &'evdw1',i,j,evdwij
2949      &,iteli,itelj,aaa,evdw1
2950               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2951           endif
2952
2953 C
2954 C Calculate contributions to the Cartesian gradient.
2955 C
2956 #ifdef SPLITELE
2957           facvdw=-6*rrmij*(ev1+evdwij)
2958           facel=-3*rrmij*(el1+eesij)
2959           fac1=fac
2960           erij(1)=xj*rmij
2961           erij(2)=yj*rmij
2962           erij(3)=zj*rmij
2963 *
2964 * Radial derivatives. First process both termini of the fragment (i,j)
2965 *
2966           ggg(1)=facel*xj
2967           ggg(2)=facel*yj
2968           ggg(3)=facel*zj
2969 c          do k=1,3
2970 c            ghalf=0.5D0*ggg(k)
2971 c            gelc(k,i)=gelc(k,i)+ghalf
2972 c            gelc(k,j)=gelc(k,j)+ghalf
2973 c          enddo
2974 c 9/28/08 AL Gradient compotents will be summed only at the end
2975           do k=1,3
2976             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2977             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2978           enddo
2979 *
2980 * Loop over residues i+1 thru j-1.
2981 *
2982 cgrad          do k=i+1,j-1
2983 cgrad            do l=1,3
2984 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2985 cgrad            enddo
2986 cgrad          enddo
2987           ggg(1)=facvdw*xj
2988           ggg(2)=facvdw*yj
2989           ggg(3)=facvdw*zj
2990 c          do k=1,3
2991 c            ghalf=0.5D0*ggg(k)
2992 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2993 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2994 c          enddo
2995 c 9/28/08 AL Gradient compotents will be summed only at the end
2996           do k=1,3
2997             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2998             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2999           enddo
3000 *
3001 * Loop over residues i+1 thru j-1.
3002 *
3003 cgrad          do k=i+1,j-1
3004 cgrad            do l=1,3
3005 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3006 cgrad            enddo
3007 cgrad          enddo
3008 #else
3009           facvdw=ev1+evdwij
3010           facel=el1+eesij
3011           fac1=fac
3012           fac=-3*rrmij*(facvdw+facvdw+facel)
3013           erij(1)=xj*rmij
3014           erij(2)=yj*rmij
3015           erij(3)=zj*rmij
3016 *
3017 * Radial derivatives. First process both termini of the fragment (i,j)
3018 *
3019           ggg(1)=fac*xj
3020           ggg(2)=fac*yj
3021           ggg(3)=fac*zj
3022 c          do k=1,3
3023 c            ghalf=0.5D0*ggg(k)
3024 c            gelc(k,i)=gelc(k,i)+ghalf
3025 c            gelc(k,j)=gelc(k,j)+ghalf
3026 c          enddo
3027 c 9/28/08 AL Gradient compotents will be summed only at the end
3028           do k=1,3
3029             gelc_long(k,j)=gelc(k,j)+ggg(k)
3030             gelc_long(k,i)=gelc(k,i)-ggg(k)
3031           enddo
3032 *
3033 * Loop over residues i+1 thru j-1.
3034 *
3035 cgrad          do k=i+1,j-1
3036 cgrad            do l=1,3
3037 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3038 cgrad            enddo
3039 cgrad          enddo
3040 c 9/28/08 AL Gradient compotents will be summed only at the end
3041           ggg(1)=facvdw*xj
3042           ggg(2)=facvdw*yj
3043           ggg(3)=facvdw*zj
3044           do k=1,3
3045             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3046             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3047           enddo
3048 #endif
3049 *
3050 * Angular part
3051 *
3052           ecosa=2.0D0*fac3*fac1+fac4
3053           fac4=-3.0D0*fac4
3054           fac3=-6.0D0*fac3
3055           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3056           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3057           do k=1,3
3058             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3059             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3060           enddo
3061 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3062 cd   &          (dcosg(k),k=1,3)
3063           do k=1,3
3064             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3065           enddo
3066 c          do k=1,3
3067 c            ghalf=0.5D0*ggg(k)
3068 c            gelc(k,i)=gelc(k,i)+ghalf
3069 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3070 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3071 c            gelc(k,j)=gelc(k,j)+ghalf
3072 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3073 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3074 c          enddo
3075 cgrad          do k=i+1,j-1
3076 cgrad            do l=1,3
3077 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3078 cgrad            enddo
3079 cgrad          enddo
3080           do k=1,3
3081             gelc(k,i)=gelc(k,i)
3082      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3083      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3084             gelc(k,j)=gelc(k,j)
3085      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3086      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3087             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3088             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3089           enddo
3090           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3091      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3092      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3093 C
3094 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3095 C   energy of a peptide unit is assumed in the form of a second-order
3096 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3097 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3098 C   are computed for EVERY pair of non-contiguous peptide groups.
3099 C
3100           if (j.lt.nres-1) then
3101             j1=j+1
3102             j2=j-1
3103           else
3104             j1=j-1
3105             j2=j-2
3106           endif
3107           kkk=0
3108           do k=1,2
3109             do l=1,2
3110               kkk=kkk+1
3111               muij(kkk)=mu(k,i)*mu(l,j)
3112             enddo
3113           enddo
3114 cd         write (iout,*) 'EELEC: i',i,' j',j
3115 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3116 cd          write(iout,*) 'muij',muij
3117           ury=scalar(uy(1,i),erij)
3118           urz=scalar(uz(1,i),erij)
3119           vry=scalar(uy(1,j),erij)
3120           vrz=scalar(uz(1,j),erij)
3121           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3122           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3123           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3124           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3125           fac=dsqrt(-ael6i)*r3ij
3126           a22=a22*fac
3127           a23=a23*fac
3128           a32=a32*fac
3129           a33=a33*fac
3130 cd          write (iout,'(4i5,4f10.5)')
3131 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3132 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3133 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3134 cd     &      uy(:,j),uz(:,j)
3135 cd          write (iout,'(4f10.5)')
3136 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3137 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3138 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3139 cd           write (iout,'(9f10.5/)')
3140 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3141 C Derivatives of the elements of A in virtual-bond vectors
3142           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3143           do k=1,3
3144             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3145             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3146             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3147             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3148             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3149             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3150             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3151             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3152             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3153             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3154             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3155             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3156           enddo
3157 C Compute radial contributions to the gradient
3158           facr=-3.0d0*rrmij
3159           a22der=a22*facr
3160           a23der=a23*facr
3161           a32der=a32*facr
3162           a33der=a33*facr
3163           agg(1,1)=a22der*xj
3164           agg(2,1)=a22der*yj
3165           agg(3,1)=a22der*zj
3166           agg(1,2)=a23der*xj
3167           agg(2,2)=a23der*yj
3168           agg(3,2)=a23der*zj
3169           agg(1,3)=a32der*xj
3170           agg(2,3)=a32der*yj
3171           agg(3,3)=a32der*zj
3172           agg(1,4)=a33der*xj
3173           agg(2,4)=a33der*yj
3174           agg(3,4)=a33der*zj
3175 C Add the contributions coming from er
3176           fac3=-3.0d0*fac
3177           do k=1,3
3178             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3179             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3180             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3181             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3182           enddo
3183           do k=1,3
3184 C Derivatives in DC(i)
3185 cgrad            ghalf1=0.5d0*agg(k,1)
3186 cgrad            ghalf2=0.5d0*agg(k,2)
3187 cgrad            ghalf3=0.5d0*agg(k,3)
3188 cgrad            ghalf4=0.5d0*agg(k,4)
3189             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3190      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3191             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3192      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3193             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3194      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3195             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3196      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3197 C Derivatives in DC(i+1)
3198             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3199      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3200             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3201      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3202             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3203      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3204             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3205      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3206 C Derivatives in DC(j)
3207             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3208      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3209             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3210      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3211             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3212      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3213             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3214      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3215 C Derivatives in DC(j+1) or DC(nres-1)
3216             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3217      &      -3.0d0*vryg(k,3)*ury)
3218             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3219      &      -3.0d0*vrzg(k,3)*ury)
3220             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3221      &      -3.0d0*vryg(k,3)*urz)
3222             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3223      &      -3.0d0*vrzg(k,3)*urz)
3224 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3225 cgrad              do l=1,4
3226 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3227 cgrad              enddo
3228 cgrad            endif
3229           enddo
3230           acipa(1,1)=a22
3231           acipa(1,2)=a23
3232           acipa(2,1)=a32
3233           acipa(2,2)=a33
3234           a22=-a22
3235           a23=-a23
3236           do l=1,2
3237             do k=1,3
3238               agg(k,l)=-agg(k,l)
3239               aggi(k,l)=-aggi(k,l)
3240               aggi1(k,l)=-aggi1(k,l)
3241               aggj(k,l)=-aggj(k,l)
3242               aggj1(k,l)=-aggj1(k,l)
3243             enddo
3244           enddo
3245           if (j.lt.nres-1) then
3246             a22=-a22
3247             a32=-a32
3248             do l=1,3,2
3249               do k=1,3
3250                 agg(k,l)=-agg(k,l)
3251                 aggi(k,l)=-aggi(k,l)
3252                 aggi1(k,l)=-aggi1(k,l)
3253                 aggj(k,l)=-aggj(k,l)
3254                 aggj1(k,l)=-aggj1(k,l)
3255               enddo
3256             enddo
3257           else
3258             a22=-a22
3259             a23=-a23
3260             a32=-a32
3261             a33=-a33
3262             do l=1,4
3263               do k=1,3
3264                 agg(k,l)=-agg(k,l)
3265                 aggi(k,l)=-aggi(k,l)
3266                 aggi1(k,l)=-aggi1(k,l)
3267                 aggj(k,l)=-aggj(k,l)
3268                 aggj1(k,l)=-aggj1(k,l)
3269               enddo
3270             enddo
3271           endif
3272           ENDIF ! WCORR
3273           IF (wel_loc.gt.0.0d0) THEN
3274 C Contribution to the local-electrostatic energy coming from the i-j pair
3275           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3276      &     +a33*muij(4)
3277 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3278
3279           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3280      &            'eelloc',i,j,eel_loc_ij
3281 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3282
3283           eel_loc=eel_loc+eel_loc_ij
3284 C Partial derivatives in virtual-bond dihedral angles gamma
3285           if (i.gt.1)
3286      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3287      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3288      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3289           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3290      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3291      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3292 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3293           do l=1,3
3294             ggg(l)=agg(l,1)*muij(1)+
3295      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3296             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3297             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3298 cgrad            ghalf=0.5d0*ggg(l)
3299 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3300 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3301           enddo
3302 cgrad          do k=i+1,j2
3303 cgrad            do l=1,3
3304 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3305 cgrad            enddo
3306 cgrad          enddo
3307 C Remaining derivatives of eello
3308           do l=1,3
3309             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3310      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3311             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3312      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3313             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3314      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3315             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3316      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3317           enddo
3318           ENDIF
3319 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3320 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3321           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3322      &       .and. num_conti.le.maxconts) then
3323 c            write (iout,*) i,j," entered corr"
3324 C
3325 C Calculate the contact function. The ith column of the array JCONT will
3326 C contain the numbers of atoms that make contacts with the atom I (of numbers
3327 C greater than I). The arrays FACONT and GACONT will contain the values of
3328 C the contact function and its derivative.
3329 c           r0ij=1.02D0*rpp(iteli,itelj)
3330 c           r0ij=1.11D0*rpp(iteli,itelj)
3331             r0ij=2.20D0*rpp(iteli,itelj)
3332 c           r0ij=1.55D0*rpp(iteli,itelj)
3333             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3334             if (fcont.gt.0.0D0) then
3335               num_conti=num_conti+1
3336               if (num_conti.gt.maxconts) then
3337                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3338      &                         ' will skip next contacts for this conf.'
3339               else
3340                 jcont_hb(num_conti,i)=j
3341 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3342 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3343                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3344      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3345 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3346 C  terms.
3347                 d_cont(num_conti,i)=rij
3348 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3349 C     --- Electrostatic-interaction matrix ---
3350                 a_chuj(1,1,num_conti,i)=a22
3351                 a_chuj(1,2,num_conti,i)=a23
3352                 a_chuj(2,1,num_conti,i)=a32
3353                 a_chuj(2,2,num_conti,i)=a33
3354 C     --- Gradient of rij
3355                 do kkk=1,3
3356                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3357                 enddo
3358                 kkll=0
3359                 do k=1,2
3360                   do l=1,2
3361                     kkll=kkll+1
3362                     do m=1,3
3363                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3364                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3365                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3366                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3367                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3368                     enddo
3369                   enddo
3370                 enddo
3371                 ENDIF
3372                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3373 C Calculate contact energies
3374                 cosa4=4.0D0*cosa
3375                 wij=cosa-3.0D0*cosb*cosg
3376                 cosbg1=cosb+cosg
3377                 cosbg2=cosb-cosg
3378 c               fac3=dsqrt(-ael6i)/r0ij**3
3379                 fac3=dsqrt(-ael6i)*r3ij
3380 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3381                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3382                 if (ees0tmp.gt.0) then
3383                   ees0pij=dsqrt(ees0tmp)
3384                 else
3385                   ees0pij=0
3386                 endif
3387 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3388                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3389                 if (ees0tmp.gt.0) then
3390                   ees0mij=dsqrt(ees0tmp)
3391                 else
3392                   ees0mij=0
3393                 endif
3394 c               ees0mij=0.0D0
3395                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3396                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3397 C Diagnostics. Comment out or remove after debugging!
3398 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3399 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3400 c               ees0m(num_conti,i)=0.0D0
3401 C End diagnostics.
3402 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3403 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3404 C Angular derivatives of the contact function
3405                 ees0pij1=fac3/ees0pij
3406                 ees0mij1=fac3/ees0mij
3407                 fac3p=-3.0D0*fac3*rrmij
3408                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3409                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3410 c               ees0mij1=0.0D0
3411                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3412                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3413                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3414                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3415                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3416                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3417                 ecosap=ecosa1+ecosa2
3418                 ecosbp=ecosb1+ecosb2
3419                 ecosgp=ecosg1+ecosg2
3420                 ecosam=ecosa1-ecosa2
3421                 ecosbm=ecosb1-ecosb2
3422                 ecosgm=ecosg1-ecosg2
3423 C Diagnostics
3424 c               ecosap=ecosa1
3425 c               ecosbp=ecosb1
3426 c               ecosgp=ecosg1
3427 c               ecosam=0.0D0
3428 c               ecosbm=0.0D0
3429 c               ecosgm=0.0D0
3430 C End diagnostics
3431                 facont_hb(num_conti,i)=fcont
3432                 fprimcont=fprimcont/rij
3433 cd              facont_hb(num_conti,i)=1.0D0
3434 C Following line is for diagnostics.
3435 cd              fprimcont=0.0D0
3436                 do k=1,3
3437                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3438                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3439                 enddo
3440                 do k=1,3
3441                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3442                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3443                 enddo
3444                 gggp(1)=gggp(1)+ees0pijp*xj
3445                 gggp(2)=gggp(2)+ees0pijp*yj
3446                 gggp(3)=gggp(3)+ees0pijp*zj
3447                 gggm(1)=gggm(1)+ees0mijp*xj
3448                 gggm(2)=gggm(2)+ees0mijp*yj
3449                 gggm(3)=gggm(3)+ees0mijp*zj
3450 C Derivatives due to the contact function
3451                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3452                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3453                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3454                 do k=1,3
3455 c
3456 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3457 c          following the change of gradient-summation algorithm.
3458 c
3459 cgrad                  ghalfp=0.5D0*gggp(k)
3460 cgrad                  ghalfm=0.5D0*gggm(k)
3461                   gacontp_hb1(k,num_conti,i)=!ghalfp
3462      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3463      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3464                   gacontp_hb2(k,num_conti,i)=!ghalfp
3465      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3466      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3467                   gacontp_hb3(k,num_conti,i)=gggp(k)
3468                   gacontm_hb1(k,num_conti,i)=!ghalfm
3469      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3470      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3471                   gacontm_hb2(k,num_conti,i)=!ghalfm
3472      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3473      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3474                   gacontm_hb3(k,num_conti,i)=gggm(k)
3475                 enddo
3476 C Diagnostics. Comment out or remove after debugging!
3477 cdiag           do k=1,3
3478 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3479 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3480 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3481 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3482 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3483 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3484 cdiag           enddo
3485               ENDIF ! wcorr
3486               endif  ! num_conti.le.maxconts
3487             endif  ! fcont.gt.0
3488           endif    ! j.gt.i+1
3489           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3490             do k=1,4
3491               do l=1,3
3492                 ghalf=0.5d0*agg(l,k)
3493                 aggi(l,k)=aggi(l,k)+ghalf
3494                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3495                 aggj(l,k)=aggj(l,k)+ghalf
3496               enddo
3497             enddo
3498             if (j.eq.nres-1 .and. i.lt.j-2) then
3499               do k=1,4
3500                 do l=1,3
3501                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3502                 enddo
3503               enddo
3504             endif
3505           endif
3506 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3507       return
3508       end
3509 C-----------------------------------------------------------------------------
3510       subroutine eturn3(i,eello_turn3)
3511 C Third- and fourth-order contributions from turns
3512       implicit real*8 (a-h,o-z)
3513       include 'DIMENSIONS'
3514       include 'COMMON.IOUNITS'
3515       include 'COMMON.GEO'
3516       include 'COMMON.VAR'
3517       include 'COMMON.LOCAL'
3518       include 'COMMON.CHAIN'
3519       include 'COMMON.DERIV'
3520       include 'COMMON.INTERACT'
3521       include 'COMMON.CONTACTS'
3522       include 'COMMON.TORSION'
3523       include 'COMMON.VECTORS'
3524       include 'COMMON.FFIELD'
3525       include 'COMMON.CONTROL'
3526       dimension ggg(3)
3527       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3528      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3529      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3530       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3531      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3532       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3533      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3534      &    num_conti,j1,j2
3535       j=i+2
3536 c      write (iout,*) "eturn3",i,j,j1,j2
3537       a_temp(1,1)=a22
3538       a_temp(1,2)=a23
3539       a_temp(2,1)=a32
3540       a_temp(2,2)=a33
3541 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3542 C
3543 C               Third-order contributions
3544 C
3545 C                 (i+2)o----(i+3)
3546 C                      | |
3547 C                      | |
3548 C                 (i+1)o----i
3549 C
3550 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3551 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3552         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3553         call transpose2(auxmat(1,1),auxmat1(1,1))
3554         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3555         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3556         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3557      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3558 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3559 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3560 cd     &    ' eello_turn3_num',4*eello_turn3_num
3561 C Derivatives in gamma(i)
3562         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3563         call transpose2(auxmat2(1,1),auxmat3(1,1))
3564         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3565         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3566 C Derivatives in gamma(i+1)
3567         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3568         call transpose2(auxmat2(1,1),auxmat3(1,1))
3569         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3570         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3571      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3572 C Cartesian derivatives
3573         do l=1,3
3574 c            ghalf1=0.5d0*agg(l,1)
3575 c            ghalf2=0.5d0*agg(l,2)
3576 c            ghalf3=0.5d0*agg(l,3)
3577 c            ghalf4=0.5d0*agg(l,4)
3578           a_temp(1,1)=aggi(l,1)!+ghalf1
3579           a_temp(1,2)=aggi(l,2)!+ghalf2
3580           a_temp(2,1)=aggi(l,3)!+ghalf3
3581           a_temp(2,2)=aggi(l,4)!+ghalf4
3582           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3583           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3584      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3585           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3586           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3587           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3588           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3589           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3590           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3591      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3592           a_temp(1,1)=aggj(l,1)!+ghalf1
3593           a_temp(1,2)=aggj(l,2)!+ghalf2
3594           a_temp(2,1)=aggj(l,3)!+ghalf3
3595           a_temp(2,2)=aggj(l,4)!+ghalf4
3596           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3597           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3598      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3599           a_temp(1,1)=aggj1(l,1)
3600           a_temp(1,2)=aggj1(l,2)
3601           a_temp(2,1)=aggj1(l,3)
3602           a_temp(2,2)=aggj1(l,4)
3603           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3604           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3605      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3606         enddo
3607       return
3608       end
3609 C-------------------------------------------------------------------------------
3610       subroutine eturn4(i,eello_turn4)
3611 C Third- and fourth-order contributions from turns
3612       implicit real*8 (a-h,o-z)
3613       include 'DIMENSIONS'
3614       include 'COMMON.IOUNITS'
3615       include 'COMMON.GEO'
3616       include 'COMMON.VAR'
3617       include 'COMMON.LOCAL'
3618       include 'COMMON.CHAIN'
3619       include 'COMMON.DERIV'
3620       include 'COMMON.INTERACT'
3621       include 'COMMON.CONTACTS'
3622       include 'COMMON.TORSION'
3623       include 'COMMON.VECTORS'
3624       include 'COMMON.FFIELD'
3625       include 'COMMON.CONTROL'
3626       dimension ggg(3)
3627       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3628      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3629      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3630       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3631      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3632       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3633      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3634      &    num_conti,j1,j2
3635       j=i+3
3636 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3637 C
3638 C               Fourth-order contributions
3639 C
3640 C                 (i+3)o----(i+4)
3641 C                     /  |
3642 C               (i+2)o   |
3643 C                     \  |
3644 C                 (i+1)o----i
3645 C
3646 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3647 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3648 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3649         a_temp(1,1)=a22
3650         a_temp(1,2)=a23
3651         a_temp(2,1)=a32
3652         a_temp(2,2)=a33
3653         iti1=itortyp(itype(i+1))
3654         iti2=itortyp(itype(i+2))
3655         iti3=itortyp(itype(i+3))
3656 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3657         call transpose2(EUg(1,1,i+1),e1t(1,1))
3658         call transpose2(Eug(1,1,i+2),e2t(1,1))
3659         call transpose2(Eug(1,1,i+3),e3t(1,1))
3660         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3661         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3662         s1=scalar2(b1(1,iti2),auxvec(1))
3663         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3664         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3665         s2=scalar2(b1(1,iti1),auxvec(1))
3666         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3667         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3668         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3669         eello_turn4=eello_turn4-(s1+s2+s3)
3670         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3671      &      'eturn4',i,j,-(s1+s2+s3)
3672 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3673 cd     &    ' eello_turn4_num',8*eello_turn4_num
3674 C Derivatives in gamma(i)
3675         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3676         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3677         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3678         s1=scalar2(b1(1,iti2),auxvec(1))
3679         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3680         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3681         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3682 C Derivatives in gamma(i+1)
3683         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3684         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3685         s2=scalar2(b1(1,iti1),auxvec(1))
3686         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3687         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3688         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3689         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3690 C Derivatives in gamma(i+2)
3691         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3692         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3693         s1=scalar2(b1(1,iti2),auxvec(1))
3694         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3695         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3696         s2=scalar2(b1(1,iti1),auxvec(1))
3697         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3698         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3699         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3700         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3701 C Cartesian derivatives
3702 C Derivatives of this turn contributions in DC(i+2)
3703         if (j.lt.nres-1) then
3704           do l=1,3
3705             a_temp(1,1)=agg(l,1)
3706             a_temp(1,2)=agg(l,2)
3707             a_temp(2,1)=agg(l,3)
3708             a_temp(2,2)=agg(l,4)
3709             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3710             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3711             s1=scalar2(b1(1,iti2),auxvec(1))
3712             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3713             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3714             s2=scalar2(b1(1,iti1),auxvec(1))
3715             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3716             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3717             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3718             ggg(l)=-(s1+s2+s3)
3719             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3720           enddo
3721         endif
3722 C Remaining derivatives of this turn contribution
3723         do l=1,3
3724           a_temp(1,1)=aggi(l,1)
3725           a_temp(1,2)=aggi(l,2)
3726           a_temp(2,1)=aggi(l,3)
3727           a_temp(2,2)=aggi(l,4)
3728           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3729           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3730           s1=scalar2(b1(1,iti2),auxvec(1))
3731           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3732           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3733           s2=scalar2(b1(1,iti1),auxvec(1))
3734           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3735           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3736           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3737           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3738           a_temp(1,1)=aggi1(l,1)
3739           a_temp(1,2)=aggi1(l,2)
3740           a_temp(2,1)=aggi1(l,3)
3741           a_temp(2,2)=aggi1(l,4)
3742           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3743           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3744           s1=scalar2(b1(1,iti2),auxvec(1))
3745           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3746           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3747           s2=scalar2(b1(1,iti1),auxvec(1))
3748           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3749           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3750           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3751           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3752           a_temp(1,1)=aggj(l,1)
3753           a_temp(1,2)=aggj(l,2)
3754           a_temp(2,1)=aggj(l,3)
3755           a_temp(2,2)=aggj(l,4)
3756           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3757           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3758           s1=scalar2(b1(1,iti2),auxvec(1))
3759           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3760           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3761           s2=scalar2(b1(1,iti1),auxvec(1))
3762           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3763           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3764           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3765           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3766           a_temp(1,1)=aggj1(l,1)
3767           a_temp(1,2)=aggj1(l,2)
3768           a_temp(2,1)=aggj1(l,3)
3769           a_temp(2,2)=aggj1(l,4)
3770           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3771           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3772           s1=scalar2(b1(1,iti2),auxvec(1))
3773           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3774           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3775           s2=scalar2(b1(1,iti1),auxvec(1))
3776           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3777           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3778           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3779 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3780           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3781         enddo
3782       return
3783       end
3784 C-----------------------------------------------------------------------------
3785       subroutine vecpr(u,v,w)
3786       implicit real*8(a-h,o-z)
3787       dimension u(3),v(3),w(3)
3788       w(1)=u(2)*v(3)-u(3)*v(2)
3789       w(2)=-u(1)*v(3)+u(3)*v(1)
3790       w(3)=u(1)*v(2)-u(2)*v(1)
3791       return
3792       end
3793 C-----------------------------------------------------------------------------
3794       subroutine unormderiv(u,ugrad,unorm,ungrad)
3795 C This subroutine computes the derivatives of a normalized vector u, given
3796 C the derivatives computed without normalization conditions, ugrad. Returns
3797 C ungrad.
3798       implicit none
3799       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3800       double precision vec(3)
3801       double precision scalar
3802       integer i,j
3803 c      write (2,*) 'ugrad',ugrad
3804 c      write (2,*) 'u',u
3805       do i=1,3
3806         vec(i)=scalar(ugrad(1,i),u(1))
3807       enddo
3808 c      write (2,*) 'vec',vec
3809       do i=1,3
3810         do j=1,3
3811           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3812         enddo
3813       enddo
3814 c      write (2,*) 'ungrad',ungrad
3815       return
3816       end
3817 C-----------------------------------------------------------------------------
3818       subroutine escp_soft_sphere(evdw2,evdw2_14)
3819 C
3820 C This subroutine calculates the excluded-volume interaction energy between
3821 C peptide-group centers and side chains and its gradient in virtual-bond and
3822 C side-chain vectors.
3823 C
3824       implicit real*8 (a-h,o-z)
3825       include 'DIMENSIONS'
3826       include 'COMMON.GEO'
3827       include 'COMMON.VAR'
3828       include 'COMMON.LOCAL'
3829       include 'COMMON.CHAIN'
3830       include 'COMMON.DERIV'
3831       include 'COMMON.INTERACT'
3832       include 'COMMON.FFIELD'
3833       include 'COMMON.IOUNITS'
3834       include 'COMMON.CONTROL'
3835       dimension ggg(3)
3836       evdw2=0.0D0
3837       evdw2_14=0.0d0
3838       r0_scp=4.5d0
3839 cd    print '(a)','Enter ESCP'
3840 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3841       do i=iatscp_s,iatscp_e
3842         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3843         iteli=itel(i)
3844         xi=0.5D0*(c(1,i)+c(1,i+1))
3845         yi=0.5D0*(c(2,i)+c(2,i+1))
3846         zi=0.5D0*(c(3,i)+c(3,i+1))
3847
3848         do iint=1,nscp_gr(i)
3849
3850         do j=iscpstart(i,iint),iscpend(i,iint)
3851           if (itype(j).eq.ntyp1) cycle
3852           itypj=iabs(itype(j))
3853 C Uncomment following three lines for SC-p interactions
3854 c         xj=c(1,nres+j)-xi
3855 c         yj=c(2,nres+j)-yi
3856 c         zj=c(3,nres+j)-zi
3857 C Uncomment following three lines for Ca-p interactions
3858           xj=c(1,j)-xi
3859           yj=c(2,j)-yi
3860           zj=c(3,j)-zi
3861           rij=xj*xj+yj*yj+zj*zj
3862           r0ij=r0_scp
3863           r0ijsq=r0ij*r0ij
3864           if (rij.lt.r0ijsq) then
3865             evdwij=0.25d0*(rij-r0ijsq)**2
3866             fac=rij-r0ijsq
3867           else
3868             evdwij=0.0d0
3869             fac=0.0d0
3870           endif
3871           evdw2=evdw2+evdwij
3872 C
3873 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3874 C
3875           ggg(1)=xj*fac
3876           ggg(2)=yj*fac
3877           ggg(3)=zj*fac
3878 cgrad          if (j.lt.i) then
3879 cd          write (iout,*) 'j<i'
3880 C Uncomment following three lines for SC-p interactions
3881 c           do k=1,3
3882 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3883 c           enddo
3884 cgrad          else
3885 cd          write (iout,*) 'j>i'
3886 cgrad            do k=1,3
3887 cgrad              ggg(k)=-ggg(k)
3888 C Uncomment following line for SC-p interactions
3889 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3890 cgrad            enddo
3891 cgrad          endif
3892 cgrad          do k=1,3
3893 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3894 cgrad          enddo
3895 cgrad          kstart=min0(i+1,j)
3896 cgrad          kend=max0(i-1,j-1)
3897 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3898 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3899 cgrad          do k=kstart,kend
3900 cgrad            do l=1,3
3901 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3902 cgrad            enddo
3903 cgrad          enddo
3904           do k=1,3
3905             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3906             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3907           enddo
3908         enddo
3909
3910         enddo ! iint
3911       enddo ! i
3912       return
3913       end
3914 C-----------------------------------------------------------------------------
3915       subroutine escp(evdw2,evdw2_14)
3916 C
3917 C This subroutine calculates the excluded-volume interaction energy between
3918 C peptide-group centers and side chains and its gradient in virtual-bond and
3919 C side-chain vectors.
3920 C
3921       implicit real*8 (a-h,o-z)
3922       include 'DIMENSIONS'
3923       include 'COMMON.GEO'
3924       include 'COMMON.VAR'
3925       include 'COMMON.LOCAL'
3926       include 'COMMON.CHAIN'
3927       include 'COMMON.DERIV'
3928       include 'COMMON.INTERACT'
3929       include 'COMMON.FFIELD'
3930       include 'COMMON.IOUNITS'
3931       include 'COMMON.CONTROL'
3932       dimension ggg(3)
3933       evdw2=0.0D0
3934       evdw2_14=0.0d0
3935 cd    print '(a)','Enter ESCP'
3936 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3937       do i=iatscp_s,iatscp_e
3938         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3939         iteli=itel(i)
3940         xi=0.5D0*(c(1,i)+c(1,i+1))
3941         yi=0.5D0*(c(2,i)+c(2,i+1))
3942         zi=0.5D0*(c(3,i)+c(3,i+1))
3943
3944         do iint=1,nscp_gr(i)
3945
3946         do j=iscpstart(i,iint),iscpend(i,iint)
3947           itypj=iabs(itype(j))
3948           if (itypj.eq.ntyp1) cycle
3949 C Uncomment following three lines for SC-p interactions
3950 c         xj=c(1,nres+j)-xi
3951 c         yj=c(2,nres+j)-yi
3952 c         zj=c(3,nres+j)-zi
3953 C Uncomment following three lines for Ca-p interactions
3954           xj=c(1,j)-xi
3955           yj=c(2,j)-yi
3956           zj=c(3,j)-zi
3957           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3958           fac=rrij**expon2
3959           e1=fac*fac*aad(itypj,iteli)
3960           e2=fac*bad(itypj,iteli)
3961           if (iabs(j-i) .le. 2) then
3962             e1=scal14*e1
3963             e2=scal14*e2
3964             evdw2_14=evdw2_14+e1+e2
3965           endif
3966           evdwij=e1+e2
3967           evdw2=evdw2+evdwij
3968           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3969      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3970      &       bad(itypj,iteli)
3971 C
3972 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3973 C
3974           fac=-(evdwij+e1)*rrij
3975           ggg(1)=xj*fac
3976           ggg(2)=yj*fac
3977           ggg(3)=zj*fac
3978 cgrad          if (j.lt.i) then
3979 cd          write (iout,*) 'j<i'
3980 C Uncomment following three lines for SC-p interactions
3981 c           do k=1,3
3982 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3983 c           enddo
3984 cgrad          else
3985 cd          write (iout,*) 'j>i'
3986 cgrad            do k=1,3
3987 cgrad              ggg(k)=-ggg(k)
3988 C Uncomment following line for SC-p interactions
3989 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3990 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3991 cgrad            enddo
3992 cgrad          endif
3993 cgrad          do k=1,3
3994 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3995 cgrad          enddo
3996 cgrad          kstart=min0(i+1,j)
3997 cgrad          kend=max0(i-1,j-1)
3998 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3999 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4000 cgrad          do k=kstart,kend
4001 cgrad            do l=1,3
4002 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4003 cgrad            enddo
4004 cgrad          enddo
4005           do k=1,3
4006             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4007             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4008           enddo
4009         enddo
4010
4011         enddo ! iint
4012       enddo ! i
4013       do i=1,nct
4014         do j=1,3
4015           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4016           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4017           gradx_scp(j,i)=expon*gradx_scp(j,i)
4018         enddo
4019       enddo
4020 C******************************************************************************
4021 C
4022 C                              N O T E !!!
4023 C
4024 C To save time the factor EXPON has been extracted from ALL components
4025 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4026 C use!
4027 C
4028 C******************************************************************************
4029       return
4030       end
4031 C--------------------------------------------------------------------------
4032       subroutine edis(ehpb)
4033 C
4034 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4035 C
4036       implicit real*8 (a-h,o-z)
4037       include 'DIMENSIONS'
4038       include 'COMMON.SBRIDGE'
4039       include 'COMMON.CHAIN'
4040       include 'COMMON.DERIV'
4041       include 'COMMON.VAR'
4042       include 'COMMON.INTERACT'
4043       include 'COMMON.IOUNITS'
4044       dimension ggg(3)
4045       ehpb=0.0D0
4046 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4047 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4048       if (link_end.eq.0) return
4049       do i=link_start,link_end
4050 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4051 C CA-CA distance used in regularization of structure.
4052         ii=ihpb(i)
4053         jj=jhpb(i)
4054 C iii and jjj point to the residues for which the distance is assigned.
4055         if (ii.gt.nres) then
4056           iii=ii-nres
4057           jjj=jj-nres
4058         else
4059           iii=ii
4060           jjj=jj
4061         endif
4062 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4063 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4064 C    distance and angle dependent SS bond potential.
4065         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4066      & iabs(itype(jjj)).eq.1) then
4067           call ssbond_ene(iii,jjj,eij)
4068           ehpb=ehpb+2*eij
4069 cd          write (iout,*) "eij",eij
4070         else
4071 C Calculate the distance between the two points and its difference from the
4072 C target distance.
4073         dd=dist(ii,jj)
4074         rdis=dd-dhpb(i)
4075 C Get the force constant corresponding to this distance.
4076         waga=forcon(i)
4077 C Calculate the contribution to energy.
4078         ehpb=ehpb+waga*rdis*rdis
4079 C
4080 C Evaluate gradient.
4081 C
4082         fac=waga*rdis/dd
4083 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4084 cd   &   ' waga=',waga,' fac=',fac
4085         do j=1,3
4086           ggg(j)=fac*(c(j,jj)-c(j,ii))
4087         enddo
4088 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4089 C If this is a SC-SC distance, we need to calculate the contributions to the
4090 C Cartesian gradient in the SC vectors (ghpbx).
4091         if (iii.lt.ii) then
4092           do j=1,3
4093             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4094             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4095           enddo
4096         endif
4097 cgrad        do j=iii,jjj-1
4098 cgrad          do k=1,3
4099 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4100 cgrad          enddo
4101 cgrad        enddo
4102         do k=1,3
4103           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4104           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4105         enddo
4106         endif
4107       enddo
4108       ehpb=0.5D0*ehpb
4109       return
4110       end
4111 C--------------------------------------------------------------------------
4112       subroutine ssbond_ene(i,j,eij)
4113 C
4114 C Calculate the distance and angle dependent SS-bond potential energy
4115 C using a free-energy function derived based on RHF/6-31G** ab initio
4116 C calculations of diethyl disulfide.
4117 C
4118 C A. Liwo and U. Kozlowska, 11/24/03
4119 C
4120       implicit real*8 (a-h,o-z)
4121       include 'DIMENSIONS'
4122       include 'COMMON.SBRIDGE'
4123       include 'COMMON.CHAIN'
4124       include 'COMMON.DERIV'
4125       include 'COMMON.LOCAL'
4126       include 'COMMON.INTERACT'
4127       include 'COMMON.VAR'
4128       include 'COMMON.IOUNITS'
4129       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4130       itypi=iabs(itype(i))
4131       xi=c(1,nres+i)
4132       yi=c(2,nres+i)
4133       zi=c(3,nres+i)
4134       dxi=dc_norm(1,nres+i)
4135       dyi=dc_norm(2,nres+i)
4136       dzi=dc_norm(3,nres+i)
4137 c      dsci_inv=dsc_inv(itypi)
4138       dsci_inv=vbld_inv(nres+i)
4139       itypj=iabs(itype(j))
4140 c      dscj_inv=dsc_inv(itypj)
4141       dscj_inv=vbld_inv(nres+j)
4142       xj=c(1,nres+j)-xi
4143       yj=c(2,nres+j)-yi
4144       zj=c(3,nres+j)-zi
4145       dxj=dc_norm(1,nres+j)
4146       dyj=dc_norm(2,nres+j)
4147       dzj=dc_norm(3,nres+j)
4148       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4149       rij=dsqrt(rrij)
4150       erij(1)=xj*rij
4151       erij(2)=yj*rij
4152       erij(3)=zj*rij
4153       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4154       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4155       om12=dxi*dxj+dyi*dyj+dzi*dzj
4156       do k=1,3
4157         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4158         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4159       enddo
4160       rij=1.0d0/rij
4161       deltad=rij-d0cm
4162       deltat1=1.0d0-om1
4163       deltat2=1.0d0+om2
4164       deltat12=om2-om1+2.0d0
4165       cosphi=om12-om1*om2
4166       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4167      &  +akct*deltad*deltat12
4168      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4169 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4170 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4171 c     &  " deltat12",deltat12," eij",eij
4172       ed=2*akcm*deltad+akct*deltat12
4173       pom1=akct*deltad
4174       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4175       eom1=-2*akth*deltat1-pom1-om2*pom2
4176       eom2= 2*akth*deltat2+pom1-om1*pom2
4177       eom12=pom2
4178       do k=1,3
4179         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4180         ghpbx(k,i)=ghpbx(k,i)-ggk
4181      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4182      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4183         ghpbx(k,j)=ghpbx(k,j)+ggk
4184      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4185      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4186         ghpbc(k,i)=ghpbc(k,i)-ggk
4187         ghpbc(k,j)=ghpbc(k,j)+ggk
4188       enddo
4189 C
4190 C Calculate the components of the gradient in DC and X
4191 C
4192 cgrad      do k=i,j-1
4193 cgrad        do l=1,3
4194 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4195 cgrad        enddo
4196 cgrad      enddo
4197       return
4198       end
4199 C--------------------------------------------------------------------------
4200       subroutine ebond(estr)
4201 c
4202 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4203 c
4204       implicit real*8 (a-h,o-z)
4205       include 'DIMENSIONS'
4206       include 'COMMON.LOCAL'
4207       include 'COMMON.GEO'
4208       include 'COMMON.INTERACT'
4209       include 'COMMON.DERIV'
4210       include 'COMMON.VAR'
4211       include 'COMMON.CHAIN'
4212       include 'COMMON.IOUNITS'
4213       include 'COMMON.NAMES'
4214       include 'COMMON.FFIELD'
4215       include 'COMMON.CONTROL'
4216       include 'COMMON.SETUP'
4217       double precision u(3),ud(3)
4218       estr=0.0d0
4219       estr1=0.0d0
4220       do i=ibondp_start,ibondp_end
4221         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4222           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4223           do j=1,3
4224           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4225      &      *dc(j,i-1)/vbld(i)
4226           enddo
4227           if (energy_dec) write(iout,*)
4228      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4229         else
4230         diff = vbld(i)-vbldp0
4231         if (energy_dec) write (iout,*)
4232      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4233         estr=estr+diff*diff
4234         do j=1,3
4235           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4236         enddo
4237 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4238         endif
4239       enddo
4240       estr=0.5d0*AKP*estr+estr1
4241 c
4242 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4243 c
4244       do i=ibond_start,ibond_end
4245         iti=iabs(itype(i))
4246         if (iti.ne.10 .and. iti.ne.ntyp1) then
4247           nbi=nbondterm(iti)
4248           if (nbi.eq.1) then
4249             diff=vbld(i+nres)-vbldsc0(1,iti)
4250             if (energy_dec) write (iout,*)
4251      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4252      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4253             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4254             do j=1,3
4255               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4256             enddo
4257           else
4258             do j=1,nbi
4259               diff=vbld(i+nres)-vbldsc0(j,iti)
4260               ud(j)=aksc(j,iti)*diff
4261               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4262             enddo
4263             uprod=u(1)
4264             do j=2,nbi
4265               uprod=uprod*u(j)
4266             enddo
4267             usum=0.0d0
4268             usumsqder=0.0d0
4269             do j=1,nbi
4270               uprod1=1.0d0
4271               uprod2=1.0d0
4272               do k=1,nbi
4273                 if (k.ne.j) then
4274                   uprod1=uprod1*u(k)
4275                   uprod2=uprod2*u(k)*u(k)
4276                 endif
4277               enddo
4278               usum=usum+uprod1
4279               usumsqder=usumsqder+ud(j)*uprod2
4280             enddo
4281             estr=estr+uprod/usum
4282             do j=1,3
4283              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4284             enddo
4285           endif
4286         endif
4287       enddo
4288       return
4289       end
4290 #ifdef CRYST_THETA
4291 C--------------------------------------------------------------------------
4292       subroutine ebend(etheta)
4293 C
4294 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4295 C angles gamma and its derivatives in consecutive thetas and gammas.
4296 C
4297       implicit real*8 (a-h,o-z)
4298       include 'DIMENSIONS'
4299       include 'COMMON.LOCAL'
4300       include 'COMMON.GEO'
4301       include 'COMMON.INTERACT'
4302       include 'COMMON.DERIV'
4303       include 'COMMON.VAR'
4304       include 'COMMON.CHAIN'
4305       include 'COMMON.IOUNITS'
4306       include 'COMMON.NAMES'
4307       include 'COMMON.FFIELD'
4308       include 'COMMON.CONTROL'
4309       common /calcthet/ term1,term2,termm,diffak,ratak,
4310      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4311      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4312       double precision y(2),z(2)
4313       delta=0.02d0*pi
4314 c      time11=dexp(-2*time)
4315 c      time12=1.0d0
4316       etheta=0.0D0
4317 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4318       do i=ithet_start,ithet_end
4319         if (itype(i-1).eq.ntyp1) cycle
4320 C Zero the energy function and its derivative at 0 or pi.
4321         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4322         it=itype(i-1)
4323         ichir1=isign(1,itype(i-2))
4324         ichir2=isign(1,itype(i))
4325          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4326          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4327          if (itype(i-1).eq.10) then
4328           itype1=isign(10,itype(i-2))
4329           ichir11=isign(1,itype(i-2))
4330           ichir12=isign(1,itype(i-2))
4331           itype2=isign(10,itype(i))
4332           ichir21=isign(1,itype(i))
4333           ichir22=isign(1,itype(i))
4334          endif
4335
4336         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4337 #ifdef OSF
4338           phii=phi(i)
4339           if (phii.ne.phii) phii=150.0
4340 #else
4341           phii=phi(i)
4342 #endif
4343           y(1)=dcos(phii)
4344           y(2)=dsin(phii)
4345         else
4346           y(1)=0.0D0
4347           y(2)=0.0D0
4348         endif
4349         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4350 #ifdef OSF
4351           phii1=phi(i+1)
4352           if (phii1.ne.phii1) phii1=150.0
4353           phii1=pinorm(phii1)
4354           z(1)=cos(phii1)
4355 #else
4356           phii1=phi(i+1)
4357           z(1)=dcos(phii1)
4358 #endif
4359           z(2)=dsin(phii1)
4360         else
4361           z(1)=0.0D0
4362           z(2)=0.0D0
4363         endif
4364 C Calculate the "mean" value of theta from the part of the distribution
4365 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4366 C In following comments this theta will be referred to as t_c.
4367         thet_pred_mean=0.0d0
4368         do k=1,2
4369             athetk=athet(k,it,ichir1,ichir2)
4370             bthetk=bthet(k,it,ichir1,ichir2)
4371           if (it.eq.10) then
4372              athetk=athet(k,itype1,ichir11,ichir12)
4373              bthetk=bthet(k,itype2,ichir21,ichir22)
4374           endif
4375          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4376         enddo
4377         dthett=thet_pred_mean*ssd
4378         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4379 C Derivatives of the "mean" values in gamma1 and gamma2.
4380         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4381      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4382          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4383      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4384          if (it.eq.10) then
4385       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4386      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4387         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4388      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4389          endif
4390         if (theta(i).gt.pi-delta) then
4391           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4392      &         E_tc0)
4393           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4394           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4395           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4396      &        E_theta)
4397           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4398      &        E_tc)
4399         else if (theta(i).lt.delta) then
4400           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4401           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4402           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4403      &        E_theta)
4404           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4405           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4406      &        E_tc)
4407         else
4408           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4409      &        E_theta,E_tc)
4410         endif
4411         etheta=etheta+ethetai
4412         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4413      &      'ebend',i,ethetai
4414         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4415         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4416         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4417       enddo
4418 C Ufff.... We've done all this!!!
4419       return
4420       end
4421 C---------------------------------------------------------------------------
4422       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4423      &     E_tc)
4424       implicit real*8 (a-h,o-z)
4425       include 'DIMENSIONS'
4426       include 'COMMON.LOCAL'
4427       include 'COMMON.IOUNITS'
4428       common /calcthet/ term1,term2,termm,diffak,ratak,
4429      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4430      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4431 C Calculate the contributions to both Gaussian lobes.
4432 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4433 C The "polynomial part" of the "standard deviation" of this part of
4434 C the distribution.
4435         sig=polthet(3,it)
4436         do j=2,0,-1
4437           sig=sig*thet_pred_mean+polthet(j,it)
4438         enddo
4439 C Derivative of the "interior part" of the "standard deviation of the"
4440 C gamma-dependent Gaussian lobe in t_c.
4441         sigtc=3*polthet(3,it)
4442         do j=2,1,-1
4443           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4444         enddo
4445         sigtc=sig*sigtc
4446 C Set the parameters of both Gaussian lobes of the distribution.
4447 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4448         fac=sig*sig+sigc0(it)
4449         sigcsq=fac+fac
4450         sigc=1.0D0/sigcsq
4451 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4452         sigsqtc=-4.0D0*sigcsq*sigtc
4453 c       print *,i,sig,sigtc,sigsqtc
4454 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4455         sigtc=-sigtc/(fac*fac)
4456 C Following variable is sigma(t_c)**(-2)
4457         sigcsq=sigcsq*sigcsq
4458         sig0i=sig0(it)
4459         sig0inv=1.0D0/sig0i**2
4460         delthec=thetai-thet_pred_mean
4461         delthe0=thetai-theta0i
4462         term1=-0.5D0*sigcsq*delthec*delthec
4463         term2=-0.5D0*sig0inv*delthe0*delthe0
4464 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4465 C NaNs in taking the logarithm. We extract the largest exponent which is added
4466 C to the energy (this being the log of the distribution) at the end of energy
4467 C term evaluation for this virtual-bond angle.
4468         if (term1.gt.term2) then
4469           termm=term1
4470           term2=dexp(term2-termm)
4471           term1=1.0d0
4472         else
4473           termm=term2
4474           term1=dexp(term1-termm)
4475           term2=1.0d0
4476         endif
4477 C The ratio between the gamma-independent and gamma-dependent lobes of
4478 C the distribution is a Gaussian function of thet_pred_mean too.
4479         diffak=gthet(2,it)-thet_pred_mean
4480         ratak=diffak/gthet(3,it)**2
4481         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4482 C Let's differentiate it in thet_pred_mean NOW.
4483         aktc=ak*ratak
4484 C Now put together the distribution terms to make complete distribution.
4485         termexp=term1+ak*term2
4486         termpre=sigc+ak*sig0i
4487 C Contribution of the bending energy from this theta is just the -log of
4488 C the sum of the contributions from the two lobes and the pre-exponential
4489 C factor. Simple enough, isn't it?
4490         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4491 C NOW the derivatives!!!
4492 C 6/6/97 Take into account the deformation.
4493         E_theta=(delthec*sigcsq*term1
4494      &       +ak*delthe0*sig0inv*term2)/termexp
4495         E_tc=((sigtc+aktc*sig0i)/termpre
4496      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4497      &       aktc*term2)/termexp)
4498       return
4499       end
4500 c-----------------------------------------------------------------------------
4501       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4502       implicit real*8 (a-h,o-z)
4503       include 'DIMENSIONS'
4504       include 'COMMON.LOCAL'
4505       include 'COMMON.IOUNITS'
4506       common /calcthet/ term1,term2,termm,diffak,ratak,
4507      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4508      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4509       delthec=thetai-thet_pred_mean
4510       delthe0=thetai-theta0i
4511 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4512       t3 = thetai-thet_pred_mean
4513       t6 = t3**2
4514       t9 = term1
4515       t12 = t3*sigcsq
4516       t14 = t12+t6*sigsqtc
4517       t16 = 1.0d0
4518       t21 = thetai-theta0i
4519       t23 = t21**2
4520       t26 = term2
4521       t27 = t21*t26
4522       t32 = termexp
4523       t40 = t32**2
4524       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4525      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4526      & *(-t12*t9-ak*sig0inv*t27)
4527       return
4528       end
4529 #else
4530 C--------------------------------------------------------------------------
4531       subroutine ebend(etheta)
4532 C
4533 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4534 C angles gamma and its derivatives in consecutive thetas and gammas.
4535 C ab initio-derived potentials from
4536 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4537 C
4538       implicit real*8 (a-h,o-z)
4539       include 'DIMENSIONS'
4540       include 'COMMON.LOCAL'
4541       include 'COMMON.GEO'
4542       include 'COMMON.INTERACT'
4543       include 'COMMON.DERIV'
4544       include 'COMMON.VAR'
4545       include 'COMMON.CHAIN'
4546       include 'COMMON.IOUNITS'
4547       include 'COMMON.NAMES'
4548       include 'COMMON.FFIELD'
4549       include 'COMMON.CONTROL'
4550       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4551      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4552      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4553      & sinph1ph2(maxdouble,maxdouble)
4554       logical lprn /.false./, lprn1 /.false./
4555       etheta=0.0D0
4556       do i=ithet_start,ithet_end
4557         if (itype(i-1).eq.ntyp1) cycle
4558         if (iabs(itype(i+1)).eq.20) iblock=2
4559         if (iabs(itype(i+1)).ne.20) iblock=1
4560         dethetai=0.0d0
4561         dephii=0.0d0
4562         dephii1=0.0d0
4563         theti2=0.5d0*theta(i)
4564         ityp2=ithetyp((itype(i-1)))
4565         do k=1,nntheterm
4566           coskt(k)=dcos(k*theti2)
4567           sinkt(k)=dsin(k*theti2)
4568         enddo
4569         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4570 #ifdef OSF
4571           phii=phi(i)
4572           if (phii.ne.phii) phii=150.0
4573 #else
4574           phii=phi(i)
4575 #endif
4576           ityp1=ithetyp((itype(i-2)))
4577 C propagation of chirality for glycine type
4578           do k=1,nsingle
4579             cosph1(k)=dcos(k*phii)
4580             sinph1(k)=dsin(k*phii)
4581           enddo
4582         else
4583           phii=0.0d0
4584           ityp1=nthetyp+1
4585           do k=1,nsingle
4586             cosph1(k)=0.0d0
4587             sinph1(k)=0.0d0
4588           enddo
4589         endif
4590         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4591 #ifdef OSF
4592           phii1=phi(i+1)
4593           if (phii1.ne.phii1) phii1=150.0
4594           phii1=pinorm(phii1)
4595 #else
4596           phii1=phi(i+1)
4597 #endif
4598           ityp3=ithetyp((itype(i)))
4599           do k=1,nsingle
4600             cosph2(k)=dcos(k*phii1)
4601             sinph2(k)=dsin(k*phii1)
4602           enddo
4603         else
4604           phii1=0.0d0
4605           ityp3=nthetyp+1
4606           do k=1,nsingle
4607             cosph2(k)=0.0d0
4608             sinph2(k)=0.0d0
4609           enddo
4610         endif
4611         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4612         do k=1,ndouble
4613           do l=1,k-1
4614             ccl=cosph1(l)*cosph2(k-l)
4615             ssl=sinph1(l)*sinph2(k-l)
4616             scl=sinph1(l)*cosph2(k-l)
4617             csl=cosph1(l)*sinph2(k-l)
4618             cosph1ph2(l,k)=ccl-ssl
4619             cosph1ph2(k,l)=ccl+ssl
4620             sinph1ph2(l,k)=scl+csl
4621             sinph1ph2(k,l)=scl-csl
4622           enddo
4623         enddo
4624         if (lprn) then
4625         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4626      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4627         write (iout,*) "coskt and sinkt"
4628         do k=1,nntheterm
4629           write (iout,*) k,coskt(k),sinkt(k)
4630         enddo
4631         endif
4632         do k=1,ntheterm
4633           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4634           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4635      &      *coskt(k)
4636           if (lprn)
4637      &    write (iout,*) "k",k,"
4638      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4639      &     " ethetai",ethetai
4640         enddo
4641         if (lprn) then
4642         write (iout,*) "cosph and sinph"
4643         do k=1,nsingle
4644           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4645         enddo
4646         write (iout,*) "cosph1ph2 and sinph2ph2"
4647         do k=2,ndouble
4648           do l=1,k-1
4649             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4650      &         sinph1ph2(l,k),sinph1ph2(k,l)
4651           enddo
4652         enddo
4653         write(iout,*) "ethetai",ethetai
4654         endif
4655         do m=1,ntheterm2
4656           do k=1,nsingle
4657             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4658      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4659      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4660      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4661             ethetai=ethetai+sinkt(m)*aux
4662             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4663             dephii=dephii+k*sinkt(m)*(
4664      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4665      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4666             dephii1=dephii1+k*sinkt(m)*(
4667      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4668      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4669             if (lprn)
4670      &      write (iout,*) "m",m," k",k," bbthet",
4671      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4672      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4673      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4674      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4675           enddo
4676         enddo
4677         if (lprn)
4678      &  write(iout,*) "ethetai",ethetai
4679         do m=1,ntheterm3
4680           do k=2,ndouble
4681             do l=1,k-1
4682               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4683      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4684      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4685      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4686               ethetai=ethetai+sinkt(m)*aux
4687               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4688               dephii=dephii+l*sinkt(m)*(
4689      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4690      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4691      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4692      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4693               dephii1=dephii1+(k-l)*sinkt(m)*(
4694      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4695      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4696      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4697      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4698               if (lprn) then
4699               write (iout,*) "m",m," k",k," l",l," ffthet",
4700      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4701      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4702      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4703      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4704      &            " ethetai",ethetai
4705               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4706      &            cosph1ph2(k,l)*sinkt(m),
4707      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4708               endif
4709             enddo
4710           enddo
4711         enddo
4712 10      continue
4713 c        lprn1=.true.
4714         if (lprn1)
4715      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4716      &   i,theta(i)*rad2deg,phii*rad2deg,
4717      &   phii1*rad2deg,ethetai
4718 c        lprn1=.false.
4719         etheta=etheta+ethetai
4720         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4721         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4722         gloc(nphi+i-2,icg)=wang*dethetai
4723       enddo
4724       return
4725       end
4726 #endif
4727 #ifdef CRYST_SC
4728 c-----------------------------------------------------------------------------
4729       subroutine esc(escloc)
4730 C Calculate the local energy of a side chain and its derivatives in the
4731 C corresponding virtual-bond valence angles THETA and the spherical angles
4732 C ALPHA and OMEGA.
4733       implicit real*8 (a-h,o-z)
4734       include 'DIMENSIONS'
4735       include 'COMMON.GEO'
4736       include 'COMMON.LOCAL'
4737       include 'COMMON.VAR'
4738       include 'COMMON.INTERACT'
4739       include 'COMMON.DERIV'
4740       include 'COMMON.CHAIN'
4741       include 'COMMON.IOUNITS'
4742       include 'COMMON.NAMES'
4743       include 'COMMON.FFIELD'
4744       include 'COMMON.CONTROL'
4745       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4746      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4747       common /sccalc/ time11,time12,time112,theti,it,nlobit
4748       delta=0.02d0*pi
4749       escloc=0.0D0
4750 c     write (iout,'(a)') 'ESC'
4751       do i=loc_start,loc_end
4752         it=itype(i)
4753         if (it.eq.ntyp1) cycle
4754         if (it.eq.10) goto 1
4755         nlobit=nlob(iabs(it))
4756 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4757 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4758         theti=theta(i+1)-pipol
4759         x(1)=dtan(theti)
4760         x(2)=alph(i)
4761         x(3)=omeg(i)
4762
4763         if (x(2).gt.pi-delta) then
4764           xtemp(1)=x(1)
4765           xtemp(2)=pi-delta
4766           xtemp(3)=x(3)
4767           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4768           xtemp(2)=pi
4769           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4770           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4771      &        escloci,dersc(2))
4772           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4773      &        ddersc0(1),dersc(1))
4774           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4775      &        ddersc0(3),dersc(3))
4776           xtemp(2)=pi-delta
4777           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4778           xtemp(2)=pi
4779           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4780           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4781      &            dersc0(2),esclocbi,dersc02)
4782           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4783      &            dersc12,dersc01)
4784           call splinthet(x(2),0.5d0*delta,ss,ssd)
4785           dersc0(1)=dersc01
4786           dersc0(2)=dersc02
4787           dersc0(3)=0.0d0
4788           do k=1,3
4789             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4790           enddo
4791           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4792 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4793 c    &             esclocbi,ss,ssd
4794           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4795 c         escloci=esclocbi
4796 c         write (iout,*) escloci
4797         else if (x(2).lt.delta) then
4798           xtemp(1)=x(1)
4799           xtemp(2)=delta
4800           xtemp(3)=x(3)
4801           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4802           xtemp(2)=0.0d0
4803           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4804           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4805      &        escloci,dersc(2))
4806           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4807      &        ddersc0(1),dersc(1))
4808           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4809      &        ddersc0(3),dersc(3))
4810           xtemp(2)=delta
4811           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4812           xtemp(2)=0.0d0
4813           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4814           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4815      &            dersc0(2),esclocbi,dersc02)
4816           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4817      &            dersc12,dersc01)
4818           dersc0(1)=dersc01
4819           dersc0(2)=dersc02
4820           dersc0(3)=0.0d0
4821           call splinthet(x(2),0.5d0*delta,ss,ssd)
4822           do k=1,3
4823             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4824           enddo
4825           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4826 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4827 c    &             esclocbi,ss,ssd
4828           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4829 c         write (iout,*) escloci
4830         else
4831           call enesc(x,escloci,dersc,ddummy,.false.)
4832         endif
4833
4834         escloc=escloc+escloci
4835         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4836      &     'escloc',i,escloci
4837 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4838
4839         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4840      &   wscloc*dersc(1)
4841         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4842         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4843     1   continue
4844       enddo
4845       return
4846       end
4847 C---------------------------------------------------------------------------
4848       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4849       implicit real*8 (a-h,o-z)
4850       include 'DIMENSIONS'
4851       include 'COMMON.GEO'
4852       include 'COMMON.LOCAL'
4853       include 'COMMON.IOUNITS'
4854       common /sccalc/ time11,time12,time112,theti,it,nlobit
4855       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4856       double precision contr(maxlob,-1:1)
4857       logical mixed
4858 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4859         escloc_i=0.0D0
4860         do j=1,3
4861           dersc(j)=0.0D0
4862           if (mixed) ddersc(j)=0.0d0
4863         enddo
4864         x3=x(3)
4865
4866 C Because of periodicity of the dependence of the SC energy in omega we have
4867 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4868 C To avoid underflows, first compute & store the exponents.
4869
4870         do iii=-1,1
4871
4872           x(3)=x3+iii*dwapi
4873
4874           do j=1,nlobit
4875             do k=1,3
4876               z(k)=x(k)-censc(k,j,it)
4877             enddo
4878             do k=1,3
4879               Axk=0.0D0
4880               do l=1,3
4881                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4882               enddo
4883               Ax(k,j,iii)=Axk
4884             enddo
4885             expfac=0.0D0
4886             do k=1,3
4887               expfac=expfac+Ax(k,j,iii)*z(k)
4888             enddo
4889             contr(j,iii)=expfac
4890           enddo ! j
4891
4892         enddo ! iii
4893
4894         x(3)=x3
4895 C As in the case of ebend, we want to avoid underflows in exponentiation and
4896 C subsequent NaNs and INFs in energy calculation.
4897 C Find the largest exponent
4898         emin=contr(1,-1)
4899         do iii=-1,1
4900           do j=1,nlobit
4901             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4902           enddo
4903         enddo
4904         emin=0.5D0*emin
4905 cd      print *,'it=',it,' emin=',emin
4906
4907 C Compute the contribution to SC energy and derivatives
4908         do iii=-1,1
4909
4910           do j=1,nlobit
4911 #ifdef OSF
4912             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4913             if(adexp.ne.adexp) adexp=1.0
4914             expfac=dexp(adexp)
4915 #else
4916             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4917 #endif
4918 cd          print *,'j=',j,' expfac=',expfac
4919             escloc_i=escloc_i+expfac
4920             do k=1,3
4921               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4922             enddo
4923             if (mixed) then
4924               do k=1,3,2
4925                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4926      &            +gaussc(k,2,j,it))*expfac
4927               enddo
4928             endif
4929           enddo
4930
4931         enddo ! iii
4932
4933         dersc(1)=dersc(1)/cos(theti)**2
4934         ddersc(1)=ddersc(1)/cos(theti)**2
4935         ddersc(3)=ddersc(3)
4936
4937         escloci=-(dlog(escloc_i)-emin)
4938         do j=1,3
4939           dersc(j)=dersc(j)/escloc_i
4940         enddo
4941         if (mixed) then
4942           do j=1,3,2
4943             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4944           enddo
4945         endif
4946       return
4947       end
4948 C------------------------------------------------------------------------------
4949       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4950       implicit real*8 (a-h,o-z)
4951       include 'DIMENSIONS'
4952       include 'COMMON.GEO'
4953       include 'COMMON.LOCAL'
4954       include 'COMMON.IOUNITS'
4955       common /sccalc/ time11,time12,time112,theti,it,nlobit
4956       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4957       double precision contr(maxlob)
4958       logical mixed
4959
4960       escloc_i=0.0D0
4961
4962       do j=1,3
4963         dersc(j)=0.0D0
4964       enddo
4965
4966       do j=1,nlobit
4967         do k=1,2
4968           z(k)=x(k)-censc(k,j,it)
4969         enddo
4970         z(3)=dwapi
4971         do k=1,3
4972           Axk=0.0D0
4973           do l=1,3
4974             Axk=Axk+gaussc(l,k,j,it)*z(l)
4975           enddo
4976           Ax(k,j)=Axk
4977         enddo
4978         expfac=0.0D0
4979         do k=1,3
4980           expfac=expfac+Ax(k,j)*z(k)
4981         enddo
4982         contr(j)=expfac
4983       enddo ! j
4984
4985 C As in the case of ebend, we want to avoid underflows in exponentiation and
4986 C subsequent NaNs and INFs in energy calculation.
4987 C Find the largest exponent
4988       emin=contr(1)
4989       do j=1,nlobit
4990         if (emin.gt.contr(j)) emin=contr(j)
4991       enddo
4992       emin=0.5D0*emin
4993
4994 C Compute the contribution to SC energy and derivatives
4995
4996       dersc12=0.0d0
4997       do j=1,nlobit
4998         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4999         escloc_i=escloc_i+expfac
5000         do k=1,2
5001           dersc(k)=dersc(k)+Ax(k,j)*expfac
5002         enddo
5003         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5004      &            +gaussc(1,2,j,it))*expfac
5005         dersc(3)=0.0d0
5006       enddo
5007
5008       dersc(1)=dersc(1)/cos(theti)**2
5009       dersc12=dersc12/cos(theti)**2
5010       escloci=-(dlog(escloc_i)-emin)
5011       do j=1,2
5012         dersc(j)=dersc(j)/escloc_i
5013       enddo
5014       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5015       return
5016       end
5017 #else
5018 c----------------------------------------------------------------------------------
5019       subroutine esc(escloc)
5020 C Calculate the local energy of a side chain and its derivatives in the
5021 C corresponding virtual-bond valence angles THETA and the spherical angles
5022 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5023 C added by Urszula Kozlowska. 07/11/2007
5024 C
5025       implicit real*8 (a-h,o-z)
5026       include 'DIMENSIONS'
5027       include 'COMMON.GEO'
5028       include 'COMMON.LOCAL'
5029       include 'COMMON.VAR'
5030       include 'COMMON.SCROT'
5031       include 'COMMON.INTERACT'
5032       include 'COMMON.DERIV'
5033       include 'COMMON.CHAIN'
5034       include 'COMMON.IOUNITS'
5035       include 'COMMON.NAMES'
5036       include 'COMMON.FFIELD'
5037       include 'COMMON.CONTROL'
5038       include 'COMMON.VECTORS'
5039       double precision x_prime(3),y_prime(3),z_prime(3)
5040      &    , sumene,dsc_i,dp2_i,x(65),
5041      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5042      &    de_dxx,de_dyy,de_dzz,de_dt
5043       double precision s1_t,s1_6_t,s2_t,s2_6_t
5044       double precision
5045      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5046      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5047      & dt_dCi(3),dt_dCi1(3)
5048       common /sccalc/ time11,time12,time112,theti,it,nlobit
5049       delta=0.02d0*pi
5050       escloc=0.0D0
5051       do i=loc_start,loc_end
5052         if (itype(i).eq.ntyp1) cycle
5053         costtab(i+1) =dcos(theta(i+1))
5054         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5055         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5056         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5057         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5058         cosfac=dsqrt(cosfac2)
5059         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5060         sinfac=dsqrt(sinfac2)
5061         it=iabs(itype(i))
5062         if (it.eq.10) goto 1
5063 c
5064 C  Compute the axes of tghe local cartesian coordinates system; store in
5065 c   x_prime, y_prime and z_prime
5066 c
5067         do j=1,3
5068           x_prime(j) = 0.00
5069           y_prime(j) = 0.00
5070           z_prime(j) = 0.00
5071         enddo
5072 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5073 C     &   dc_norm(3,i+nres)
5074         do j = 1,3
5075           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5076           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5077         enddo
5078         do j = 1,3
5079           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5080         enddo
5081 c       write (2,*) "i",i
5082 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5083 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5084 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5085 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5086 c      & " xy",scalar(x_prime(1),y_prime(1)),
5087 c      & " xz",scalar(x_prime(1),z_prime(1)),
5088 c      & " yy",scalar(y_prime(1),y_prime(1)),
5089 c      & " yz",scalar(y_prime(1),z_prime(1)),
5090 c      & " zz",scalar(z_prime(1),z_prime(1))
5091 c
5092 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5093 C to local coordinate system. Store in xx, yy, zz.
5094 c
5095         xx=0.0d0
5096         yy=0.0d0
5097         zz=0.0d0
5098         do j = 1,3
5099           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5100           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5101           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5102         enddo
5103
5104         xxtab(i)=xx
5105         yytab(i)=yy
5106         zztab(i)=zz
5107 C
5108 C Compute the energy of the ith side cbain
5109 C
5110 c        write (2,*) "xx",xx," yy",yy," zz",zz
5111         it=iabs(itype(i))
5112         do j = 1,65
5113           x(j) = sc_parmin(j,it)
5114         enddo
5115 #ifdef CHECK_COORD
5116 Cc diagnostics - remove later
5117         xx1 = dcos(alph(2))
5118         yy1 = dsin(alph(2))*dcos(omeg(2))
5119         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5120         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5121      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5122      &    xx1,yy1,zz1
5123 C,"  --- ", xx_w,yy_w,zz_w
5124 c end diagnostics
5125 #endif
5126         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5127      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5128      &   + x(10)*yy*zz
5129         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5130      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5131      & + x(20)*yy*zz
5132         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5133      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5134      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5135      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5136      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5137      &  +x(40)*xx*yy*zz
5138         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5139      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5140      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5141      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5142      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5143      &  +x(60)*xx*yy*zz
5144         dsc_i   = 0.743d0+x(61)
5145         dp2_i   = 1.9d0+x(62)
5146         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5147      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5148         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5149      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5150         s1=(1+x(63))/(0.1d0 + dscp1)
5151         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5152         s2=(1+x(65))/(0.1d0 + dscp2)
5153         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5154         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5155      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5156 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5157 c     &   sumene4,
5158 c     &   dscp1,dscp2,sumene
5159 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5160         escloc = escloc + sumene
5161 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5162 c     & ,zz,xx,yy
5163 c#define DEBUG
5164 #ifdef DEBUG
5165 C
5166 C This section to check the numerical derivatives of the energy of ith side
5167 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5168 C #define DEBUG in the code to turn it on.
5169 C
5170         write (2,*) "sumene               =",sumene
5171         aincr=1.0d-7
5172         xxsave=xx
5173         xx=xx+aincr
5174         write (2,*) xx,yy,zz
5175         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5176         de_dxx_num=(sumenep-sumene)/aincr
5177         xx=xxsave
5178         write (2,*) "xx+ sumene from enesc=",sumenep
5179         yysave=yy
5180         yy=yy+aincr
5181         write (2,*) xx,yy,zz
5182         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5183         de_dyy_num=(sumenep-sumene)/aincr
5184         yy=yysave
5185         write (2,*) "yy+ sumene from enesc=",sumenep
5186         zzsave=zz
5187         zz=zz+aincr
5188         write (2,*) xx,yy,zz
5189         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5190         de_dzz_num=(sumenep-sumene)/aincr
5191         zz=zzsave
5192         write (2,*) "zz+ sumene from enesc=",sumenep
5193         costsave=cost2tab(i+1)
5194         sintsave=sint2tab(i+1)
5195         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5196         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5197         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5198         de_dt_num=(sumenep-sumene)/aincr
5199         write (2,*) " t+ sumene from enesc=",sumenep
5200         cost2tab(i+1)=costsave
5201         sint2tab(i+1)=sintsave
5202 C End of diagnostics section.
5203 #endif
5204 C
5205 C Compute the gradient of esc
5206 C
5207 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5208         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5209         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5210         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5211         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5212         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5213         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5214         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5215         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5216         pom1=(sumene3*sint2tab(i+1)+sumene1)
5217      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5218         pom2=(sumene4*cost2tab(i+1)+sumene2)
5219      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5220         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5221         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5222      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5223      &  +x(40)*yy*zz
5224         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5225         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5226      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5227      &  +x(60)*yy*zz
5228         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5229      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5230      &        +(pom1+pom2)*pom_dx
5231 #ifdef DEBUG
5232         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5233 #endif
5234 C
5235         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5236         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5237      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5238      &  +x(40)*xx*zz
5239         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5240         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5241      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5242      &  +x(59)*zz**2 +x(60)*xx*zz
5243         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5244      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5245      &        +(pom1-pom2)*pom_dy
5246 #ifdef DEBUG
5247         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5248 #endif
5249 C
5250         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5251      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5252      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5253      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5254      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5255      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5256      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5257      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5258 #ifdef DEBUG
5259         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5260 #endif
5261 C
5262         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5263      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5264      &  +pom1*pom_dt1+pom2*pom_dt2
5265 #ifdef DEBUG
5266         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5267 #endif
5268 c#undef DEBUG
5269 c
5270 C
5271        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5272        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5273        cosfac2xx=cosfac2*xx
5274        sinfac2yy=sinfac2*yy
5275        do k = 1,3
5276          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5277      &      vbld_inv(i+1)
5278          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5279      &      vbld_inv(i)
5280          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5281          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5282 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5283 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5284 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5285 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5286          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5287          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5288          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5289          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5290          dZZ_Ci1(k)=0.0d0
5291          dZZ_Ci(k)=0.0d0
5292          do j=1,3
5293            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5294      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5295            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5296      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5297          enddo
5298
5299          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5300          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5301          dZZ_XYZ(k)=vbld_inv(i+nres)*
5302      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5303 c
5304          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5305          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5306        enddo
5307
5308        do k=1,3
5309          dXX_Ctab(k,i)=dXX_Ci(k)
5310          dXX_C1tab(k,i)=dXX_Ci1(k)
5311          dYY_Ctab(k,i)=dYY_Ci(k)
5312          dYY_C1tab(k,i)=dYY_Ci1(k)
5313          dZZ_Ctab(k,i)=dZZ_Ci(k)
5314          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5315          dXX_XYZtab(k,i)=dXX_XYZ(k)
5316          dYY_XYZtab(k,i)=dYY_XYZ(k)
5317          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5318        enddo
5319
5320        do k = 1,3
5321 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5322 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5323 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5324 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5325 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5326 c     &    dt_dci(k)
5327 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5328 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5329          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5330      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5331          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5332      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5333          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5334      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5335        enddo
5336 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5337 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5338
5339 C to check gradient call subroutine check_grad
5340
5341     1 continue
5342       enddo
5343       return
5344       end
5345 c------------------------------------------------------------------------------
5346       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5347       implicit none
5348       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5349      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5350       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5351      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5352      &   + x(10)*yy*zz
5353       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5354      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5355      & + x(20)*yy*zz
5356       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5357      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5358      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5359      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5360      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5361      &  +x(40)*xx*yy*zz
5362       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5363      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5364      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5365      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5366      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5367      &  +x(60)*xx*yy*zz
5368       dsc_i   = 0.743d0+x(61)
5369       dp2_i   = 1.9d0+x(62)
5370       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5371      &          *(xx*cost2+yy*sint2))
5372       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5373      &          *(xx*cost2-yy*sint2))
5374       s1=(1+x(63))/(0.1d0 + dscp1)
5375       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5376       s2=(1+x(65))/(0.1d0 + dscp2)
5377       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5378       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5379      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5380       enesc=sumene
5381       return
5382       end
5383 #endif
5384 c------------------------------------------------------------------------------
5385       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5386 C
5387 C This procedure calculates two-body contact function g(rij) and its derivative:
5388 C
5389 C           eps0ij                                     !       x < -1
5390 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5391 C            0                                         !       x > 1
5392 C
5393 C where x=(rij-r0ij)/delta
5394 C
5395 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5396 C
5397       implicit none
5398       double precision rij,r0ij,eps0ij,fcont,fprimcont
5399       double precision x,x2,x4,delta
5400 c     delta=0.02D0*r0ij
5401 c      delta=0.2D0*r0ij
5402       x=(rij-r0ij)/delta
5403       if (x.lt.-1.0D0) then
5404         fcont=eps0ij
5405         fprimcont=0.0D0
5406       else if (x.le.1.0D0) then
5407         x2=x*x
5408         x4=x2*x2
5409         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5410         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5411       else
5412         fcont=0.0D0
5413         fprimcont=0.0D0
5414       endif
5415       return
5416       end
5417 c------------------------------------------------------------------------------
5418       subroutine splinthet(theti,delta,ss,ssder)
5419       implicit real*8 (a-h,o-z)
5420       include 'DIMENSIONS'
5421       include 'COMMON.VAR'
5422       include 'COMMON.GEO'
5423       thetup=pi-delta
5424       thetlow=delta
5425       if (theti.gt.pipol) then
5426         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5427       else
5428         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5429         ssder=-ssder
5430       endif
5431       return
5432       end
5433 c------------------------------------------------------------------------------
5434       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5435       implicit none
5436       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5437       double precision ksi,ksi2,ksi3,a1,a2,a3
5438       a1=fprim0*delta/(f1-f0)
5439       a2=3.0d0-2.0d0*a1
5440       a3=a1-2.0d0
5441       ksi=(x-x0)/delta
5442       ksi2=ksi*ksi
5443       ksi3=ksi2*ksi
5444       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5445       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5446       return
5447       end
5448 c------------------------------------------------------------------------------
5449       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5450       implicit none
5451       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5452       double precision ksi,ksi2,ksi3,a1,a2,a3
5453       ksi=(x-x0)/delta
5454       ksi2=ksi*ksi
5455       ksi3=ksi2*ksi
5456       a1=fprim0x*delta
5457       a2=3*(f1x-f0x)-2*fprim0x*delta
5458       a3=fprim0x*delta-2*(f1x-f0x)
5459       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5460       return
5461       end
5462 C-----------------------------------------------------------------------------
5463 #ifdef CRYST_TOR
5464 C-----------------------------------------------------------------------------
5465       subroutine etor(etors,edihcnstr)
5466       implicit real*8 (a-h,o-z)
5467       include 'DIMENSIONS'
5468       include 'COMMON.VAR'
5469       include 'COMMON.GEO'
5470       include 'COMMON.LOCAL'
5471       include 'COMMON.TORSION'
5472       include 'COMMON.INTERACT'
5473       include 'COMMON.DERIV'
5474       include 'COMMON.CHAIN'
5475       include 'COMMON.NAMES'
5476       include 'COMMON.IOUNITS'
5477       include 'COMMON.FFIELD'
5478       include 'COMMON.TORCNSTR'
5479       include 'COMMON.CONTROL'
5480       logical lprn
5481 C Set lprn=.true. for debugging
5482       lprn=.false.
5483 c      lprn=.true.
5484       etors=0.0D0
5485       do i=iphi_start,iphi_end
5486       etors_ii=0.0D0
5487         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5488      &      .or. itype(i).eq.ntyp1) cycle
5489         itori=itortyp(itype(i-2))
5490         itori1=itortyp(itype(i-1))
5491         phii=phi(i)
5492         gloci=0.0D0
5493 C Proline-Proline pair is a special case...
5494         if (itori.eq.3 .and. itori1.eq.3) then
5495           if (phii.gt.-dwapi3) then
5496             cosphi=dcos(3*phii)
5497             fac=1.0D0/(1.0D0-cosphi)
5498             etorsi=v1(1,3,3)*fac
5499             etorsi=etorsi+etorsi
5500             etors=etors+etorsi-v1(1,3,3)
5501             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5502             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5503           endif
5504           do j=1,3
5505             v1ij=v1(j+1,itori,itori1)
5506             v2ij=v2(j+1,itori,itori1)
5507             cosphi=dcos(j*phii)
5508             sinphi=dsin(j*phii)
5509             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5510             if (energy_dec) etors_ii=etors_ii+
5511      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5512             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5513           enddo
5514         else
5515           do j=1,nterm_old
5516             v1ij=v1(j,itori,itori1)
5517             v2ij=v2(j,itori,itori1)
5518             cosphi=dcos(j*phii)
5519             sinphi=dsin(j*phii)
5520             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5521             if (energy_dec) etors_ii=etors_ii+
5522      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5523             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5524           enddo
5525         endif
5526         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5527              'etor',i,etors_ii
5528         if (lprn)
5529      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5530      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5531      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5532         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5533 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5534       enddo
5535 ! 6/20/98 - dihedral angle constraints
5536       edihcnstr=0.0d0
5537       do i=1,ndih_constr
5538         itori=idih_constr(i)
5539         phii=phi(itori)
5540         difi=phii-phi0(i)
5541         if (difi.gt.drange(i)) then
5542           difi=difi-drange(i)
5543           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5544           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5545         else if (difi.lt.-drange(i)) then
5546           difi=difi+drange(i)
5547           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5548           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5549         endif
5550 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5551 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5552       enddo
5553 !      write (iout,*) 'edihcnstr',edihcnstr
5554       return
5555       end
5556 c------------------------------------------------------------------------------
5557       subroutine etor_d(etors_d)
5558       etors_d=0.0d0
5559       return
5560       end
5561 c----------------------------------------------------------------------------
5562 #else
5563       subroutine etor(etors,edihcnstr)
5564       implicit real*8 (a-h,o-z)
5565       include 'DIMENSIONS'
5566       include 'COMMON.VAR'
5567       include 'COMMON.GEO'
5568       include 'COMMON.LOCAL'
5569       include 'COMMON.TORSION'
5570       include 'COMMON.INTERACT'
5571       include 'COMMON.DERIV'
5572       include 'COMMON.CHAIN'
5573       include 'COMMON.NAMES'
5574       include 'COMMON.IOUNITS'
5575       include 'COMMON.FFIELD'
5576       include 'COMMON.TORCNSTR'
5577       include 'COMMON.CONTROL'
5578       logical lprn
5579 C Set lprn=.true. for debugging
5580       lprn=.false.
5581 c     lprn=.true.
5582       etors=0.0D0
5583       do i=iphi_start,iphi_end
5584         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5585      &       .or. itype(i).eq.ntyp1) cycle
5586         etors_ii=0.0D0
5587          if (iabs(itype(i)).eq.20) then
5588          iblock=2
5589          else
5590          iblock=1
5591          endif
5592         itori=itortyp(itype(i-2))
5593         itori1=itortyp(itype(i-1))
5594         phii=phi(i)
5595         gloci=0.0D0
5596 C Regular cosine and sine terms
5597         do j=1,nterm(itori,itori1,iblock)
5598           v1ij=v1(j,itori,itori1,iblock)
5599           v2ij=v2(j,itori,itori1,iblock)
5600           cosphi=dcos(j*phii)
5601           sinphi=dsin(j*phii)
5602           etors=etors+v1ij*cosphi+v2ij*sinphi
5603           if (energy_dec) etors_ii=etors_ii+
5604      &                v1ij*cosphi+v2ij*sinphi
5605           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5606         enddo
5607 C Lorentz terms
5608 C                         v1
5609 C  E = SUM ----------------------------------- - v1
5610 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5611 C
5612         cosphi=dcos(0.5d0*phii)
5613         sinphi=dsin(0.5d0*phii)
5614         do j=1,nlor(itori,itori1,iblock)
5615           vl1ij=vlor1(j,itori,itori1)
5616           vl2ij=vlor2(j,itori,itori1)
5617           vl3ij=vlor3(j,itori,itori1)
5618           pom=vl2ij*cosphi+vl3ij*sinphi
5619           pom1=1.0d0/(pom*pom+1.0d0)
5620           etors=etors+vl1ij*pom1
5621           if (energy_dec) etors_ii=etors_ii+
5622      &                vl1ij*pom1
5623           pom=-pom*pom1*pom1
5624           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5625         enddo
5626 C Subtract the constant term
5627         etors=etors-v0(itori,itori1,iblock)
5628           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5629      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5630         if (lprn)
5631      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5632      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5633      &  (v1(j,itori,itori1,iblock),j=1,6),
5634      &  (v2(j,itori,itori1,iblock),j=1,6)
5635         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5636 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5637       enddo
5638 ! 6/20/98 - dihedral angle constraints
5639       edihcnstr=0.0d0
5640 c      do i=1,ndih_constr
5641       do i=idihconstr_start,idihconstr_end
5642         itori=idih_constr(i)
5643         phii=phi(itori)
5644         difi=pinorm(phii-phi0(i))
5645         if (difi.gt.drange(i)) then
5646           difi=difi-drange(i)
5647           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5648           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5649         else if (difi.lt.-drange(i)) then
5650           difi=difi+drange(i)
5651           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5652           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5653         else
5654           difi=0.0
5655         endif
5656 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5657 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5658 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5659       enddo
5660 cd       write (iout,*) 'edihcnstr',edihcnstr
5661       return
5662       end
5663 c----------------------------------------------------------------------------
5664       subroutine etor_d(etors_d)
5665 C 6/23/01 Compute double torsional energy
5666       implicit real*8 (a-h,o-z)
5667       include 'DIMENSIONS'
5668       include 'COMMON.VAR'
5669       include 'COMMON.GEO'
5670       include 'COMMON.LOCAL'
5671       include 'COMMON.TORSION'
5672       include 'COMMON.INTERACT'
5673       include 'COMMON.DERIV'
5674       include 'COMMON.CHAIN'
5675       include 'COMMON.NAMES'
5676       include 'COMMON.IOUNITS'
5677       include 'COMMON.FFIELD'
5678       include 'COMMON.TORCNSTR'
5679       logical lprn
5680 C Set lprn=.true. for debugging
5681       lprn=.false.
5682 c     lprn=.true.
5683       etors_d=0.0D0
5684 c      write(iout,*) "a tu??"
5685       do i=iphid_start,iphid_end
5686         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5687      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5688         itori=itortyp(itype(i-2))
5689         itori1=itortyp(itype(i-1))
5690         itori2=itortyp(itype(i))
5691         phii=phi(i)
5692         phii1=phi(i+1)
5693         gloci1=0.0D0
5694         gloci2=0.0D0
5695         iblock=1
5696         if (iabs(itype(i+1)).eq.20) iblock=2
5697
5698 C Regular cosine and sine terms
5699         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5700           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5701           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5702           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5703           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5704           cosphi1=dcos(j*phii)
5705           sinphi1=dsin(j*phii)
5706           cosphi2=dcos(j*phii1)
5707           sinphi2=dsin(j*phii1)
5708           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5709      &     v2cij*cosphi2+v2sij*sinphi2
5710           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5711           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5712         enddo
5713         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5714           do l=1,k-1
5715             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5716             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5717             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5718             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5719             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5720             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5721             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5722             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5723             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5724      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5725             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5726      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5727             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5728      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5729           enddo
5730         enddo
5731         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5732         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5733       enddo
5734       return
5735       end
5736 #endif
5737 c------------------------------------------------------------------------------
5738       subroutine eback_sc_corr(esccor)
5739 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5740 c        conformational states; temporarily implemented as differences
5741 c        between UNRES torsional potentials (dependent on three types of
5742 c        residues) and the torsional potentials dependent on all 20 types
5743 c        of residues computed from AM1  energy surfaces of terminally-blocked
5744 c        amino-acid residues.
5745       implicit real*8 (a-h,o-z)
5746       include 'DIMENSIONS'
5747       include 'COMMON.VAR'
5748       include 'COMMON.GEO'
5749       include 'COMMON.LOCAL'
5750       include 'COMMON.TORSION'
5751       include 'COMMON.SCCOR'
5752       include 'COMMON.INTERACT'
5753       include 'COMMON.DERIV'
5754       include 'COMMON.CHAIN'
5755       include 'COMMON.NAMES'
5756       include 'COMMON.IOUNITS'
5757       include 'COMMON.FFIELD'
5758       include 'COMMON.CONTROL'
5759       logical lprn
5760 C Set lprn=.true. for debugging
5761       lprn=.false.
5762 c      lprn=.true.
5763 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5764       esccor=0.0D0
5765       do i=itau_start,itau_end
5766         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5767         esccor_ii=0.0D0
5768         isccori=isccortyp(itype(i-2))
5769         isccori1=isccortyp(itype(i-1))
5770 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5771         phii=phi(i)
5772         do intertyp=1,3 !intertyp
5773 cc Added 09 May 2012 (Adasko)
5774 cc  Intertyp means interaction type of backbone mainchain correlation:
5775 c   1 = SC...Ca...Ca...Ca
5776 c   2 = Ca...Ca...Ca...SC
5777 c   3 = SC...Ca...Ca...SCi
5778         gloci=0.0D0
5779         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5780      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5781      &      (itype(i-1).eq.ntyp1)))
5782      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5783      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5784      &     .or.(itype(i).eq.ntyp1)))
5785      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5786      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5787      &      (itype(i-3).eq.ntyp1)))) cycle
5788         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5789         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5790      & cycle
5791        do j=1,nterm_sccor(isccori,isccori1)
5792           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5793           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5794           cosphi=dcos(j*tauangle(intertyp,i))
5795           sinphi=dsin(j*tauangle(intertyp,i))
5796           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5797           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5798         enddo
5799 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5800         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5801         if (lprn)
5802      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5803      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5804      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5805      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5806         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5807        enddo !intertyp
5808       enddo
5809
5810       return
5811       end
5812 c----------------------------------------------------------------------------
5813       subroutine multibody(ecorr)
5814 C This subroutine calculates multi-body contributions to energy following
5815 C the idea of Skolnick et al. If side chains I and J make a contact and
5816 C at the same time side chains I+1 and J+1 make a contact, an extra
5817 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5818       implicit real*8 (a-h,o-z)
5819       include 'DIMENSIONS'
5820       include 'COMMON.IOUNITS'
5821       include 'COMMON.DERIV'
5822       include 'COMMON.INTERACT'
5823       include 'COMMON.CONTACTS'
5824       double precision gx(3),gx1(3)
5825       logical lprn
5826
5827 C Set lprn=.true. for debugging
5828       lprn=.false.
5829
5830       if (lprn) then
5831         write (iout,'(a)') 'Contact function values:'
5832         do i=nnt,nct-2
5833           write (iout,'(i2,20(1x,i2,f10.5))')
5834      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5835         enddo
5836       endif
5837       ecorr=0.0D0
5838       do i=nnt,nct
5839         do j=1,3
5840           gradcorr(j,i)=0.0D0
5841           gradxorr(j,i)=0.0D0
5842         enddo
5843       enddo
5844       do i=nnt,nct-2
5845
5846         DO ISHIFT = 3,4
5847
5848         i1=i+ishift
5849         num_conti=num_cont(i)
5850         num_conti1=num_cont(i1)
5851         do jj=1,num_conti
5852           j=jcont(jj,i)
5853           do kk=1,num_conti1
5854             j1=jcont(kk,i1)
5855             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5856 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5857 cd   &                   ' ishift=',ishift
5858 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5859 C The system gains extra energy.
5860               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5861             endif   ! j1==j+-ishift
5862           enddo     ! kk
5863         enddo       ! jj
5864
5865         ENDDO ! ISHIFT
5866
5867       enddo         ! i
5868       return
5869       end
5870 c------------------------------------------------------------------------------
5871       double precision function esccorr(i,j,k,l,jj,kk)
5872       implicit real*8 (a-h,o-z)
5873       include 'DIMENSIONS'
5874       include 'COMMON.IOUNITS'
5875       include 'COMMON.DERIV'
5876       include 'COMMON.INTERACT'
5877       include 'COMMON.CONTACTS'
5878       double precision gx(3),gx1(3)
5879       logical lprn
5880       lprn=.false.
5881       eij=facont(jj,i)
5882       ekl=facont(kk,k)
5883 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5884 C Calculate the multi-body contribution to energy.
5885 C Calculate multi-body contributions to the gradient.
5886 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5887 cd   & k,l,(gacont(m,kk,k),m=1,3)
5888       do m=1,3
5889         gx(m) =ekl*gacont(m,jj,i)
5890         gx1(m)=eij*gacont(m,kk,k)
5891         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5892         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5893         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5894         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5895       enddo
5896       do m=i,j-1
5897         do ll=1,3
5898           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5899         enddo
5900       enddo
5901       do m=k,l-1
5902         do ll=1,3
5903           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5904         enddo
5905       enddo
5906       esccorr=-eij*ekl
5907       return
5908       end
5909 c------------------------------------------------------------------------------
5910       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5911 C This subroutine calculates multi-body contributions to hydrogen-bonding
5912       implicit real*8 (a-h,o-z)
5913       include 'DIMENSIONS'
5914       include 'COMMON.IOUNITS'
5915 #ifdef MPI
5916       include "mpif.h"
5917       parameter (max_cont=maxconts)
5918       parameter (max_dim=26)
5919       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5920       double precision zapas(max_dim,maxconts,max_fg_procs),
5921      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5922       common /przechowalnia/ zapas
5923       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5924      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5925 #endif
5926       include 'COMMON.SETUP'
5927       include 'COMMON.FFIELD'
5928       include 'COMMON.DERIV'
5929       include 'COMMON.INTERACT'
5930       include 'COMMON.CONTACTS'
5931       include 'COMMON.CONTROL'
5932       include 'COMMON.LOCAL'
5933       double precision gx(3),gx1(3),time00
5934       logical lprn,ldone
5935
5936 C Set lprn=.true. for debugging
5937       lprn=.false.
5938 #ifdef MPI
5939       n_corr=0
5940       n_corr1=0
5941       if (nfgtasks.le.1) goto 30
5942       if (lprn) then
5943         write (iout,'(a)') 'Contact function values before RECEIVE:'
5944         do i=nnt,nct-2
5945           write (iout,'(2i3,50(1x,i2,f5.2))')
5946      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5947      &    j=1,num_cont_hb(i))
5948         enddo
5949       endif
5950       call flush(iout)
5951       do i=1,ntask_cont_from
5952         ncont_recv(i)=0
5953       enddo
5954       do i=1,ntask_cont_to
5955         ncont_sent(i)=0
5956       enddo
5957 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5958 c     & ntask_cont_to
5959 C Make the list of contacts to send to send to other procesors
5960 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5961 c      call flush(iout)
5962       do i=iturn3_start,iturn3_end
5963 c        write (iout,*) "make contact list turn3",i," num_cont",
5964 c     &    num_cont_hb(i)
5965         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5966       enddo
5967       do i=iturn4_start,iturn4_end
5968 c        write (iout,*) "make contact list turn4",i," num_cont",
5969 c     &   num_cont_hb(i)
5970         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5971       enddo
5972       do ii=1,nat_sent
5973         i=iat_sent(ii)
5974 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5975 c     &    num_cont_hb(i)
5976         do j=1,num_cont_hb(i)
5977         do k=1,4
5978           jjc=jcont_hb(j,i)
5979           iproc=iint_sent_local(k,jjc,ii)
5980 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5981           if (iproc.gt.0) then
5982             ncont_sent(iproc)=ncont_sent(iproc)+1
5983             nn=ncont_sent(iproc)
5984             zapas(1,nn,iproc)=i
5985             zapas(2,nn,iproc)=jjc
5986             zapas(3,nn,iproc)=facont_hb(j,i)
5987             zapas(4,nn,iproc)=ees0p(j,i)
5988             zapas(5,nn,iproc)=ees0m(j,i)
5989             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5990             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5991             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5992             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5993             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5994             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5995             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5996             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5997             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5998             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5999             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6000             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6001             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6002             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6003             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6004             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6005             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6006             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6007             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6008             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6009             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6010           endif
6011         enddo
6012         enddo
6013       enddo
6014       if (lprn) then
6015       write (iout,*)
6016      &  "Numbers of contacts to be sent to other processors",
6017      &  (ncont_sent(i),i=1,ntask_cont_to)
6018       write (iout,*) "Contacts sent"
6019       do ii=1,ntask_cont_to
6020         nn=ncont_sent(ii)
6021         iproc=itask_cont_to(ii)
6022         write (iout,*) nn," contacts to processor",iproc,
6023      &   " of CONT_TO_COMM group"
6024         do i=1,nn
6025           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6026         enddo
6027       enddo
6028       call flush(iout)
6029       endif
6030       CorrelType=477
6031       CorrelID=fg_rank+1
6032       CorrelType1=478
6033       CorrelID1=nfgtasks+fg_rank+1
6034       ireq=0
6035 C Receive the numbers of needed contacts from other processors
6036       do ii=1,ntask_cont_from
6037         iproc=itask_cont_from(ii)
6038         ireq=ireq+1
6039         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6040      &    FG_COMM,req(ireq),IERR)
6041       enddo
6042 c      write (iout,*) "IRECV ended"
6043 c      call flush(iout)
6044 C Send the number of contacts needed by other processors
6045       do ii=1,ntask_cont_to
6046         iproc=itask_cont_to(ii)
6047         ireq=ireq+1
6048         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6049      &    FG_COMM,req(ireq),IERR)
6050       enddo
6051 c      write (iout,*) "ISEND ended"
6052 c      write (iout,*) "number of requests (nn)",ireq
6053       call flush(iout)
6054       if (ireq.gt.0)
6055      &  call MPI_Waitall(ireq,req,status_array,ierr)
6056 c      write (iout,*)
6057 c     &  "Numbers of contacts to be received from other processors",
6058 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6059 c      call flush(iout)
6060 C Receive contacts
6061       ireq=0
6062       do ii=1,ntask_cont_from
6063         iproc=itask_cont_from(ii)
6064         nn=ncont_recv(ii)
6065 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6066 c     &   " of CONT_TO_COMM group"
6067         call flush(iout)
6068         if (nn.gt.0) then
6069           ireq=ireq+1
6070           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6071      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6072 c          write (iout,*) "ireq,req",ireq,req(ireq)
6073         endif
6074       enddo
6075 C Send the contacts to processors that need them
6076       do ii=1,ntask_cont_to
6077         iproc=itask_cont_to(ii)
6078         nn=ncont_sent(ii)
6079 c        write (iout,*) nn," contacts to processor",iproc,
6080 c     &   " of CONT_TO_COMM group"
6081         if (nn.gt.0) then
6082           ireq=ireq+1
6083           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6084      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6085 c          write (iout,*) "ireq,req",ireq,req(ireq)
6086 c          do i=1,nn
6087 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6088 c          enddo
6089         endif
6090       enddo
6091 c      write (iout,*) "number of requests (contacts)",ireq
6092 c      write (iout,*) "req",(req(i),i=1,4)
6093 c      call flush(iout)
6094       if (ireq.gt.0)
6095      & call MPI_Waitall(ireq,req,status_array,ierr)
6096       do iii=1,ntask_cont_from
6097         iproc=itask_cont_from(iii)
6098         nn=ncont_recv(iii)
6099         if (lprn) then
6100         write (iout,*) "Received",nn," contacts from processor",iproc,
6101      &   " of CONT_FROM_COMM group"
6102         call flush(iout)
6103         do i=1,nn
6104           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6105         enddo
6106         call flush(iout)
6107         endif
6108         do i=1,nn
6109           ii=zapas_recv(1,i,iii)
6110 c Flag the received contacts to prevent double-counting
6111           jj=-zapas_recv(2,i,iii)
6112 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6113 c          call flush(iout)
6114           nnn=num_cont_hb(ii)+1
6115           num_cont_hb(ii)=nnn
6116           jcont_hb(nnn,ii)=jj
6117           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6118           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6119           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6120           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6121           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6122           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6123           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6124           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6125           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6126           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6127           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6128           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6129           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6130           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6131           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6132           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6133           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6134           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6135           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6136           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6137           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6138           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6139           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6140           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6141         enddo
6142       enddo
6143       call flush(iout)
6144       if (lprn) then
6145         write (iout,'(a)') 'Contact function values after receive:'
6146         do i=nnt,nct-2
6147           write (iout,'(2i3,50(1x,i3,f5.2))')
6148      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6149      &    j=1,num_cont_hb(i))
6150         enddo
6151         call flush(iout)
6152       endif
6153    30 continue
6154 #endif
6155       if (lprn) then
6156         write (iout,'(a)') 'Contact function values:'
6157         do i=nnt,nct-2
6158           write (iout,'(2i3,50(1x,i3,f5.2))')
6159      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6160      &    j=1,num_cont_hb(i))
6161         enddo
6162       endif
6163       ecorr=0.0D0
6164 C Remove the loop below after debugging !!!
6165       do i=nnt,nct
6166         do j=1,3
6167           gradcorr(j,i)=0.0D0
6168           gradxorr(j,i)=0.0D0
6169         enddo
6170       enddo
6171 C Calculate the local-electrostatic correlation terms
6172       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6173         i1=i+1
6174         num_conti=num_cont_hb(i)
6175         num_conti1=num_cont_hb(i+1)
6176         do jj=1,num_conti
6177           j=jcont_hb(jj,i)
6178           jp=iabs(j)
6179           do kk=1,num_conti1
6180             j1=jcont_hb(kk,i1)
6181             jp1=iabs(j1)
6182 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6183 c     &         ' jj=',jj,' kk=',kk
6184             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6185      &          .or. j.lt.0 .and. j1.gt.0) .and.
6186      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6187 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6188 C The system gains extra energy.
6189               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6190               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6191      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6192               n_corr=n_corr+1
6193             else if (j1.eq.j) then
6194 C Contacts I-J and I-(J+1) occur simultaneously.
6195 C The system loses extra energy.
6196 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6197             endif
6198           enddo ! kk
6199           do kk=1,num_conti
6200             j1=jcont_hb(kk,i)
6201 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6202 c    &         ' jj=',jj,' kk=',kk
6203             if (j1.eq.j+1) then
6204 C Contacts I-J and (I+1)-J occur simultaneously.
6205 C The system loses extra energy.
6206 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6207             endif ! j1==j+1
6208           enddo ! kk
6209         enddo ! jj
6210       enddo ! i
6211       return
6212       end
6213 c------------------------------------------------------------------------------
6214       subroutine add_hb_contact(ii,jj,itask)
6215       implicit real*8 (a-h,o-z)
6216       include "DIMENSIONS"
6217       include "COMMON.IOUNITS"
6218       integer max_cont
6219       integer max_dim
6220       parameter (max_cont=maxconts)
6221       parameter (max_dim=26)
6222       include "COMMON.CONTACTS"
6223       double precision zapas(max_dim,maxconts,max_fg_procs),
6224      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6225       common /przechowalnia/ zapas
6226       integer i,j,ii,jj,iproc,itask(4),nn
6227 c      write (iout,*) "itask",itask
6228       do i=1,2
6229         iproc=itask(i)
6230         if (iproc.gt.0) then
6231           do j=1,num_cont_hb(ii)
6232             jjc=jcont_hb(j,ii)
6233 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6234             if (jjc.eq.jj) then
6235               ncont_sent(iproc)=ncont_sent(iproc)+1
6236               nn=ncont_sent(iproc)
6237               zapas(1,nn,iproc)=ii
6238               zapas(2,nn,iproc)=jjc
6239               zapas(3,nn,iproc)=facont_hb(j,ii)
6240               zapas(4,nn,iproc)=ees0p(j,ii)
6241               zapas(5,nn,iproc)=ees0m(j,ii)
6242               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6243               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6244               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6245               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6246               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6247               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6248               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6249               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6250               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6251               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6252               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6253               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6254               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6255               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6256               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6257               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6258               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6259               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6260               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6261               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6262               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6263               exit
6264             endif
6265           enddo
6266         endif
6267       enddo
6268       return
6269       end
6270 c------------------------------------------------------------------------------
6271       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6272      &  n_corr1)
6273 C This subroutine calculates multi-body contributions to hydrogen-bonding
6274       implicit real*8 (a-h,o-z)
6275       include 'DIMENSIONS'
6276       include 'COMMON.IOUNITS'
6277 #ifdef MPI
6278       include "mpif.h"
6279       parameter (max_cont=maxconts)
6280       parameter (max_dim=70)
6281       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6282       double precision zapas(max_dim,maxconts,max_fg_procs),
6283      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6284       common /przechowalnia/ zapas
6285       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6286      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6287 #endif
6288       include 'COMMON.SETUP'
6289       include 'COMMON.FFIELD'
6290       include 'COMMON.DERIV'
6291       include 'COMMON.LOCAL'
6292       include 'COMMON.INTERACT'
6293       include 'COMMON.CONTACTS'
6294       include 'COMMON.CHAIN'
6295       include 'COMMON.CONTROL'
6296       double precision gx(3),gx1(3)
6297       integer num_cont_hb_old(maxres)
6298       logical lprn,ldone
6299       double precision eello4,eello5,eelo6,eello_turn6
6300       external eello4,eello5,eello6,eello_turn6
6301 C Set lprn=.true. for debugging
6302       lprn=.false.
6303       eturn6=0.0d0
6304 #ifdef MPI
6305       do i=1,nres
6306         num_cont_hb_old(i)=num_cont_hb(i)
6307       enddo
6308       n_corr=0
6309       n_corr1=0
6310       if (nfgtasks.le.1) goto 30
6311       if (lprn) then
6312         write (iout,'(a)') 'Contact function values before RECEIVE:'
6313         do i=nnt,nct-2
6314           write (iout,'(2i3,50(1x,i2,f5.2))')
6315      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6316      &    j=1,num_cont_hb(i))
6317         enddo
6318       endif
6319       call flush(iout)
6320       do i=1,ntask_cont_from
6321         ncont_recv(i)=0
6322       enddo
6323       do i=1,ntask_cont_to
6324         ncont_sent(i)=0
6325       enddo
6326 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6327 c     & ntask_cont_to
6328 C Make the list of contacts to send to send to other procesors
6329       do i=iturn3_start,iturn3_end
6330 c        write (iout,*) "make contact list turn3",i," num_cont",
6331 c     &    num_cont_hb(i)
6332         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6333       enddo
6334       do i=iturn4_start,iturn4_end
6335 c        write (iout,*) "make contact list turn4",i," num_cont",
6336 c     &   num_cont_hb(i)
6337         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6338       enddo
6339       do ii=1,nat_sent
6340         i=iat_sent(ii)
6341 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6342 c     &    num_cont_hb(i)
6343         do j=1,num_cont_hb(i)
6344         do k=1,4
6345           jjc=jcont_hb(j,i)
6346           iproc=iint_sent_local(k,jjc,ii)
6347 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6348           if (iproc.ne.0) then
6349             ncont_sent(iproc)=ncont_sent(iproc)+1
6350             nn=ncont_sent(iproc)
6351             zapas(1,nn,iproc)=i
6352             zapas(2,nn,iproc)=jjc
6353             zapas(3,nn,iproc)=d_cont(j,i)
6354             ind=3
6355             do kk=1,3
6356               ind=ind+1
6357               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6358             enddo
6359             do kk=1,2
6360               do ll=1,2
6361                 ind=ind+1
6362                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6363               enddo
6364             enddo
6365             do jj=1,5
6366               do kk=1,3
6367                 do ll=1,2
6368                   do mm=1,2
6369                     ind=ind+1
6370                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6371                   enddo
6372                 enddo
6373               enddo
6374             enddo
6375           endif
6376         enddo
6377         enddo
6378       enddo
6379       if (lprn) then
6380       write (iout,*)
6381      &  "Numbers of contacts to be sent to other processors",
6382      &  (ncont_sent(i),i=1,ntask_cont_to)
6383       write (iout,*) "Contacts sent"
6384       do ii=1,ntask_cont_to
6385         nn=ncont_sent(ii)
6386         iproc=itask_cont_to(ii)
6387         write (iout,*) nn," contacts to processor",iproc,
6388      &   " of CONT_TO_COMM group"
6389         do i=1,nn
6390           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6391         enddo
6392       enddo
6393       call flush(iout)
6394       endif
6395       CorrelType=477
6396       CorrelID=fg_rank+1
6397       CorrelType1=478
6398       CorrelID1=nfgtasks+fg_rank+1
6399       ireq=0
6400 C Receive the numbers of needed contacts from other processors
6401       do ii=1,ntask_cont_from
6402         iproc=itask_cont_from(ii)
6403         ireq=ireq+1
6404         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6405      &    FG_COMM,req(ireq),IERR)
6406       enddo
6407 c      write (iout,*) "IRECV ended"
6408 c      call flush(iout)
6409 C Send the number of contacts needed by other processors
6410       do ii=1,ntask_cont_to
6411         iproc=itask_cont_to(ii)
6412         ireq=ireq+1
6413         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6414      &    FG_COMM,req(ireq),IERR)
6415       enddo
6416 c      write (iout,*) "ISEND ended"
6417 c      write (iout,*) "number of requests (nn)",ireq
6418       call flush(iout)
6419       if (ireq.gt.0)
6420      &  call MPI_Waitall(ireq,req,status_array,ierr)
6421 c      write (iout,*)
6422 c     &  "Numbers of contacts to be received from other processors",
6423 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6424 c      call flush(iout)
6425 C Receive contacts
6426       ireq=0
6427       do ii=1,ntask_cont_from
6428         iproc=itask_cont_from(ii)
6429         nn=ncont_recv(ii)
6430 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6431 c     &   " of CONT_TO_COMM group"
6432         call flush(iout)
6433         if (nn.gt.0) then
6434           ireq=ireq+1
6435           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6436      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6437 c          write (iout,*) "ireq,req",ireq,req(ireq)
6438         endif
6439       enddo
6440 C Send the contacts to processors that need them
6441       do ii=1,ntask_cont_to
6442         iproc=itask_cont_to(ii)
6443         nn=ncont_sent(ii)
6444 c        write (iout,*) nn," contacts to processor",iproc,
6445 c     &   " of CONT_TO_COMM group"
6446         if (nn.gt.0) then
6447           ireq=ireq+1
6448           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6449      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6450 c          write (iout,*) "ireq,req",ireq,req(ireq)
6451 c          do i=1,nn
6452 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6453 c          enddo
6454         endif
6455       enddo
6456 c      write (iout,*) "number of requests (contacts)",ireq
6457 c      write (iout,*) "req",(req(i),i=1,4)
6458 c      call flush(iout)
6459       if (ireq.gt.0)
6460      & call MPI_Waitall(ireq,req,status_array,ierr)
6461       do iii=1,ntask_cont_from
6462         iproc=itask_cont_from(iii)
6463         nn=ncont_recv(iii)
6464         if (lprn) then
6465         write (iout,*) "Received",nn," contacts from processor",iproc,
6466      &   " of CONT_FROM_COMM group"
6467         call flush(iout)
6468         do i=1,nn
6469           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6470         enddo
6471         call flush(iout)
6472         endif
6473         do i=1,nn
6474           ii=zapas_recv(1,i,iii)
6475 c Flag the received contacts to prevent double-counting
6476           jj=-zapas_recv(2,i,iii)
6477 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6478 c          call flush(iout)
6479           nnn=num_cont_hb(ii)+1
6480           num_cont_hb(ii)=nnn
6481           jcont_hb(nnn,ii)=jj
6482           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6483           ind=3
6484           do kk=1,3
6485             ind=ind+1
6486             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6487           enddo
6488           do kk=1,2
6489             do ll=1,2
6490               ind=ind+1
6491               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6492             enddo
6493           enddo
6494           do jj=1,5
6495             do kk=1,3
6496               do ll=1,2
6497                 do mm=1,2
6498                   ind=ind+1
6499                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6500                 enddo
6501               enddo
6502             enddo
6503           enddo
6504         enddo
6505       enddo
6506       call flush(iout)
6507       if (lprn) then
6508         write (iout,'(a)') 'Contact function values after receive:'
6509         do i=nnt,nct-2
6510           write (iout,'(2i3,50(1x,i3,5f6.3))')
6511      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6512      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6513         enddo
6514         call flush(iout)
6515       endif
6516    30 continue
6517 #endif
6518       if (lprn) then
6519         write (iout,'(a)') 'Contact function values:'
6520         do i=nnt,nct-2
6521           write (iout,'(2i3,50(1x,i2,5f6.3))')
6522      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6523      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6524         enddo
6525       endif
6526       ecorr=0.0D0
6527       ecorr5=0.0d0
6528       ecorr6=0.0d0
6529 C Remove the loop below after debugging !!!
6530       do i=nnt,nct
6531         do j=1,3
6532           gradcorr(j,i)=0.0D0
6533           gradxorr(j,i)=0.0D0
6534         enddo
6535       enddo
6536 C Calculate the dipole-dipole interaction energies
6537       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6538       do i=iatel_s,iatel_e+1
6539         num_conti=num_cont_hb(i)
6540         do jj=1,num_conti
6541           j=jcont_hb(jj,i)
6542 #ifdef MOMENT
6543           call dipole(i,j,jj)
6544 #endif
6545         enddo
6546       enddo
6547       endif
6548 C Calculate the local-electrostatic correlation terms
6549 c                write (iout,*) "gradcorr5 in eello5 before loop"
6550 c                do iii=1,nres
6551 c                  write (iout,'(i5,3f10.5)')
6552 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6553 c                enddo
6554       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6555 c        write (iout,*) "corr loop i",i
6556         i1=i+1
6557         num_conti=num_cont_hb(i)
6558         num_conti1=num_cont_hb(i+1)
6559         do jj=1,num_conti
6560           j=jcont_hb(jj,i)
6561           jp=iabs(j)
6562           do kk=1,num_conti1
6563             j1=jcont_hb(kk,i1)
6564             jp1=iabs(j1)
6565 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6566 c     &         ' jj=',jj,' kk=',kk
6567 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6568             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6569      &          .or. j.lt.0 .and. j1.gt.0) .and.
6570      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6571 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6572 C The system gains extra energy.
6573               n_corr=n_corr+1
6574               sqd1=dsqrt(d_cont(jj,i))
6575               sqd2=dsqrt(d_cont(kk,i1))
6576               sred_geom = sqd1*sqd2
6577               IF (sred_geom.lt.cutoff_corr) THEN
6578                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6579      &            ekont,fprimcont)
6580 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6581 cd     &         ' jj=',jj,' kk=',kk
6582                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6583                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6584                 do l=1,3
6585                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6586                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6587                 enddo
6588                 n_corr1=n_corr1+1
6589 cd               write (iout,*) 'sred_geom=',sred_geom,
6590 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6591 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6592 cd               write (iout,*) "g_contij",g_contij
6593 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6594 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6595                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6596                 if (wcorr4.gt.0.0d0)
6597      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6598                   if (energy_dec.and.wcorr4.gt.0.0d0)
6599      1                 write (iout,'(a6,4i5,0pf7.3)')
6600      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6601 c                write (iout,*) "gradcorr5 before eello5"
6602 c                do iii=1,nres
6603 c                  write (iout,'(i5,3f10.5)')
6604 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6605 c                enddo
6606                 if (wcorr5.gt.0.0d0)
6607      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6608 c                write (iout,*) "gradcorr5 after eello5"
6609 c                do iii=1,nres
6610 c                  write (iout,'(i5,3f10.5)')
6611 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6612 c                enddo
6613                   if (energy_dec.and.wcorr5.gt.0.0d0)
6614      1                 write (iout,'(a6,4i5,0pf7.3)')
6615      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6616 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6617 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6618                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6619      &               .or. wturn6.eq.0.0d0))then
6620 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6621                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6622                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6623      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6624 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6625 cd     &            'ecorr6=',ecorr6
6626 cd                write (iout,'(4e15.5)') sred_geom,
6627 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6628 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6629 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6630                 else if (wturn6.gt.0.0d0
6631      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6632 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6633                   eturn6=eturn6+eello_turn6(i,jj,kk)
6634                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6635      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6636 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6637                 endif
6638               ENDIF
6639 1111          continue
6640             endif
6641           enddo ! kk
6642         enddo ! jj
6643       enddo ! i
6644       do i=1,nres
6645         num_cont_hb(i)=num_cont_hb_old(i)
6646       enddo
6647 c                write (iout,*) "gradcorr5 in eello5"
6648 c                do iii=1,nres
6649 c                  write (iout,'(i5,3f10.5)')
6650 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6651 c                enddo
6652       return
6653       end
6654 c------------------------------------------------------------------------------
6655       subroutine add_hb_contact_eello(ii,jj,itask)
6656       implicit real*8 (a-h,o-z)
6657       include "DIMENSIONS"
6658       include "COMMON.IOUNITS"
6659       integer max_cont
6660       integer max_dim
6661       parameter (max_cont=maxconts)
6662       parameter (max_dim=70)
6663       include "COMMON.CONTACTS"
6664       double precision zapas(max_dim,maxconts,max_fg_procs),
6665      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6666       common /przechowalnia/ zapas
6667       integer i,j,ii,jj,iproc,itask(4),nn
6668 c      write (iout,*) "itask",itask
6669       do i=1,2
6670         iproc=itask(i)
6671         if (iproc.gt.0) then
6672           do j=1,num_cont_hb(ii)
6673             jjc=jcont_hb(j,ii)
6674 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6675             if (jjc.eq.jj) then
6676               ncont_sent(iproc)=ncont_sent(iproc)+1
6677               nn=ncont_sent(iproc)
6678               zapas(1,nn,iproc)=ii
6679               zapas(2,nn,iproc)=jjc
6680               zapas(3,nn,iproc)=d_cont(j,ii)
6681               ind=3
6682               do kk=1,3
6683                 ind=ind+1
6684                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6685               enddo
6686               do kk=1,2
6687                 do ll=1,2
6688                   ind=ind+1
6689                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6690                 enddo
6691               enddo
6692               do jj=1,5
6693                 do kk=1,3
6694                   do ll=1,2
6695                     do mm=1,2
6696                       ind=ind+1
6697                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6698                     enddo
6699                   enddo
6700                 enddo
6701               enddo
6702               exit
6703             endif
6704           enddo
6705         endif
6706       enddo
6707       return
6708       end
6709 c------------------------------------------------------------------------------
6710       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6711       implicit real*8 (a-h,o-z)
6712       include 'DIMENSIONS'
6713       include 'COMMON.IOUNITS'
6714       include 'COMMON.DERIV'
6715       include 'COMMON.INTERACT'
6716       include 'COMMON.CONTACTS'
6717       double precision gx(3),gx1(3)
6718       logical lprn
6719       lprn=.false.
6720       eij=facont_hb(jj,i)
6721       ekl=facont_hb(kk,k)
6722       ees0pij=ees0p(jj,i)
6723       ees0pkl=ees0p(kk,k)
6724       ees0mij=ees0m(jj,i)
6725       ees0mkl=ees0m(kk,k)
6726       ekont=eij*ekl
6727       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6728 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6729 C Following 4 lines for diagnostics.
6730 cd    ees0pkl=0.0D0
6731 cd    ees0pij=1.0D0
6732 cd    ees0mkl=0.0D0
6733 cd    ees0mij=1.0D0
6734 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6735 c     & 'Contacts ',i,j,
6736 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6737 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6738 c     & 'gradcorr_long'
6739 C Calculate the multi-body contribution to energy.
6740 c      ecorr=ecorr+ekont*ees
6741 C Calculate multi-body contributions to the gradient.
6742       coeffpees0pij=coeffp*ees0pij
6743       coeffmees0mij=coeffm*ees0mij
6744       coeffpees0pkl=coeffp*ees0pkl
6745       coeffmees0mkl=coeffm*ees0mkl
6746       do ll=1,3
6747 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6748         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6749      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6750      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6751         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6752      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6753      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6754 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6755         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6756      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6757      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6758         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6759      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6760      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6761         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6762      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6763      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6764         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6765         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6766         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6767      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6768      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6769         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6770         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6771 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6772       enddo
6773 c      write (iout,*)
6774 cgrad      do m=i+1,j-1
6775 cgrad        do ll=1,3
6776 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6777 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6778 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6779 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6780 cgrad        enddo
6781 cgrad      enddo
6782 cgrad      do m=k+1,l-1
6783 cgrad        do ll=1,3
6784 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6785 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6786 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6787 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6788 cgrad        enddo
6789 cgrad      enddo
6790 c      write (iout,*) "ehbcorr",ekont*ees
6791       ehbcorr=ekont*ees
6792       return
6793       end
6794 #ifdef MOMENT
6795 C---------------------------------------------------------------------------
6796       subroutine dipole(i,j,jj)
6797       implicit real*8 (a-h,o-z)
6798       include 'DIMENSIONS'
6799       include 'COMMON.IOUNITS'
6800       include 'COMMON.CHAIN'
6801       include 'COMMON.FFIELD'
6802       include 'COMMON.DERIV'
6803       include 'COMMON.INTERACT'
6804       include 'COMMON.CONTACTS'
6805       include 'COMMON.TORSION'
6806       include 'COMMON.VAR'
6807       include 'COMMON.GEO'
6808       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6809      &  auxmat(2,2)
6810       iti1 = itortyp(itype(i+1))
6811       if (j.lt.nres-1) then
6812         itj1 = itortyp(itype(j+1))
6813       else
6814         itj1=ntortyp+1
6815       endif
6816       do iii=1,2
6817         dipi(iii,1)=Ub2(iii,i)
6818         dipderi(iii)=Ub2der(iii,i)
6819         dipi(iii,2)=b1(iii,iti1)
6820         dipj(iii,1)=Ub2(iii,j)
6821         dipderj(iii)=Ub2der(iii,j)
6822         dipj(iii,2)=b1(iii,itj1)
6823       enddo
6824       kkk=0
6825       do iii=1,2
6826         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6827         do jjj=1,2
6828           kkk=kkk+1
6829           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6830         enddo
6831       enddo
6832       do kkk=1,5
6833         do lll=1,3
6834           mmm=0
6835           do iii=1,2
6836             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6837      &        auxvec(1))
6838             do jjj=1,2
6839               mmm=mmm+1
6840               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6841             enddo
6842           enddo
6843         enddo
6844       enddo
6845       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6846       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6847       do iii=1,2
6848         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6849       enddo
6850       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6851       do iii=1,2
6852         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6853       enddo
6854       return
6855       end
6856 #endif
6857 C---------------------------------------------------------------------------
6858       subroutine calc_eello(i,j,k,l,jj,kk)
6859 C
6860 C This subroutine computes matrices and vectors needed to calculate
6861 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6862 C
6863       implicit real*8 (a-h,o-z)
6864       include 'DIMENSIONS'
6865       include 'COMMON.IOUNITS'
6866       include 'COMMON.CHAIN'
6867       include 'COMMON.DERIV'
6868       include 'COMMON.INTERACT'
6869       include 'COMMON.CONTACTS'
6870       include 'COMMON.TORSION'
6871       include 'COMMON.VAR'
6872       include 'COMMON.GEO'
6873       include 'COMMON.FFIELD'
6874       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6875      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6876       logical lprn
6877       common /kutas/ lprn
6878 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6879 cd     & ' jj=',jj,' kk=',kk
6880 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6881 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6882 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6883       do iii=1,2
6884         do jjj=1,2
6885           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6886           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6887         enddo
6888       enddo
6889       call transpose2(aa1(1,1),aa1t(1,1))
6890       call transpose2(aa2(1,1),aa2t(1,1))
6891       do kkk=1,5
6892         do lll=1,3
6893           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6894      &      aa1tder(1,1,lll,kkk))
6895           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6896      &      aa2tder(1,1,lll,kkk))
6897         enddo
6898       enddo
6899       if (l.eq.j+1) then
6900 C parallel orientation of the two CA-CA-CA frames.
6901         if (i.gt.1) then
6902           iti=itortyp(itype(i))
6903         else
6904           iti=ntortyp+1
6905         endif
6906         itk1=itortyp(itype(k+1))
6907         itj=itortyp(itype(j))
6908         if (l.lt.nres-1) then
6909           itl1=itortyp(itype(l+1))
6910         else
6911           itl1=ntortyp+1
6912         endif
6913 C A1 kernel(j+1) A2T
6914 cd        do iii=1,2
6915 cd          write (iout,'(3f10.5,5x,3f10.5)')
6916 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6917 cd        enddo
6918         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6919      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6920      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6921 C Following matrices are needed only for 6-th order cumulants
6922         IF (wcorr6.gt.0.0d0) THEN
6923         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6924      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6925      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6926         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6927      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6928      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6929      &   ADtEAderx(1,1,1,1,1,1))
6930         lprn=.false.
6931         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6932      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6933      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6934      &   ADtEA1derx(1,1,1,1,1,1))
6935         ENDIF
6936 C End 6-th order cumulants
6937 cd        lprn=.false.
6938 cd        if (lprn) then
6939 cd        write (2,*) 'In calc_eello6'
6940 cd        do iii=1,2
6941 cd          write (2,*) 'iii=',iii
6942 cd          do kkk=1,5
6943 cd            write (2,*) 'kkk=',kkk
6944 cd            do jjj=1,2
6945 cd              write (2,'(3(2f10.5),5x)')
6946 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6947 cd            enddo
6948 cd          enddo
6949 cd        enddo
6950 cd        endif
6951         call transpose2(EUgder(1,1,k),auxmat(1,1))
6952         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6953         call transpose2(EUg(1,1,k),auxmat(1,1))
6954         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6955         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6956         do iii=1,2
6957           do kkk=1,5
6958             do lll=1,3
6959               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6960      &          EAEAderx(1,1,lll,kkk,iii,1))
6961             enddo
6962           enddo
6963         enddo
6964 C A1T kernel(i+1) A2
6965         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6966      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6967      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6968 C Following matrices are needed only for 6-th order cumulants
6969         IF (wcorr6.gt.0.0d0) THEN
6970         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6971      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6972      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6973         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6974      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6975      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6976      &   ADtEAderx(1,1,1,1,1,2))
6977         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6978      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6979      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6980      &   ADtEA1derx(1,1,1,1,1,2))
6981         ENDIF
6982 C End 6-th order cumulants
6983         call transpose2(EUgder(1,1,l),auxmat(1,1))
6984         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6985         call transpose2(EUg(1,1,l),auxmat(1,1))
6986         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6987         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6988         do iii=1,2
6989           do kkk=1,5
6990             do lll=1,3
6991               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6992      &          EAEAderx(1,1,lll,kkk,iii,2))
6993             enddo
6994           enddo
6995         enddo
6996 C AEAb1 and AEAb2
6997 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6998 C They are needed only when the fifth- or the sixth-order cumulants are
6999 C indluded.
7000         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7001         call transpose2(AEA(1,1,1),auxmat(1,1))
7002         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7003         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7004         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7005         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7006         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7007         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7008         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7009         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7010         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7011         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7012         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7013         call transpose2(AEA(1,1,2),auxmat(1,1))
7014         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7015         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7016         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7017         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7018         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7019         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7020         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7021         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7022         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7023         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7024         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7025 C Calculate the Cartesian derivatives of the vectors.
7026         do iii=1,2
7027           do kkk=1,5
7028             do lll=1,3
7029               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7030               call matvec2(auxmat(1,1),b1(1,iti),
7031      &          AEAb1derx(1,lll,kkk,iii,1,1))
7032               call matvec2(auxmat(1,1),Ub2(1,i),
7033      &          AEAb2derx(1,lll,kkk,iii,1,1))
7034               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7035      &          AEAb1derx(1,lll,kkk,iii,2,1))
7036               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7037      &          AEAb2derx(1,lll,kkk,iii,2,1))
7038               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7039               call matvec2(auxmat(1,1),b1(1,itj),
7040      &          AEAb1derx(1,lll,kkk,iii,1,2))
7041               call matvec2(auxmat(1,1),Ub2(1,j),
7042      &          AEAb2derx(1,lll,kkk,iii,1,2))
7043               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7044      &          AEAb1derx(1,lll,kkk,iii,2,2))
7045               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7046      &          AEAb2derx(1,lll,kkk,iii,2,2))
7047             enddo
7048           enddo
7049         enddo
7050         ENDIF
7051 C End vectors
7052       else
7053 C Antiparallel orientation of the two CA-CA-CA frames.
7054         if (i.gt.1) then
7055           iti=itortyp(itype(i))
7056         else
7057           iti=ntortyp+1
7058         endif
7059         itk1=itortyp(itype(k+1))
7060         itl=itortyp(itype(l))
7061         itj=itortyp(itype(j))
7062         if (j.lt.nres-1) then
7063           itj1=itortyp(itype(j+1))
7064         else
7065           itj1=ntortyp+1
7066         endif
7067 C A2 kernel(j-1)T A1T
7068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7069      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7070      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7071 C Following matrices are needed only for 6-th order cumulants
7072         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7073      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7074         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7075      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7076      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7077         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7078      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7079      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7080      &   ADtEAderx(1,1,1,1,1,1))
7081         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7082      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7083      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7084      &   ADtEA1derx(1,1,1,1,1,1))
7085         ENDIF
7086 C End 6-th order cumulants
7087         call transpose2(EUgder(1,1,k),auxmat(1,1))
7088         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7089         call transpose2(EUg(1,1,k),auxmat(1,1))
7090         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7091         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7092         do iii=1,2
7093           do kkk=1,5
7094             do lll=1,3
7095               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7096      &          EAEAderx(1,1,lll,kkk,iii,1))
7097             enddo
7098           enddo
7099         enddo
7100 C A2T kernel(i+1)T A1
7101         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7102      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7103      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7104 C Following matrices are needed only for 6-th order cumulants
7105         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7106      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7107         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7108      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7109      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7110         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7111      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7112      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7113      &   ADtEAderx(1,1,1,1,1,2))
7114         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7115      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7116      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7117      &   ADtEA1derx(1,1,1,1,1,2))
7118         ENDIF
7119 C End 6-th order cumulants
7120         call transpose2(EUgder(1,1,j),auxmat(1,1))
7121         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7122         call transpose2(EUg(1,1,j),auxmat(1,1))
7123         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7124         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7125         do iii=1,2
7126           do kkk=1,5
7127             do lll=1,3
7128               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7129      &          EAEAderx(1,1,lll,kkk,iii,2))
7130             enddo
7131           enddo
7132         enddo
7133 C AEAb1 and AEAb2
7134 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7135 C They are needed only when the fifth- or the sixth-order cumulants are
7136 C indluded.
7137         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7138      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7139         call transpose2(AEA(1,1,1),auxmat(1,1))
7140         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7141         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7142         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7143         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7144         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7145         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7146         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7147         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7148         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7149         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7150         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7151         call transpose2(AEA(1,1,2),auxmat(1,1))
7152         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7153         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7154         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7155         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7156         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7157         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7158         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7159         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7160         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7161         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7162         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7163 C Calculate the Cartesian derivatives of the vectors.
7164         do iii=1,2
7165           do kkk=1,5
7166             do lll=1,3
7167               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7168               call matvec2(auxmat(1,1),b1(1,iti),
7169      &          AEAb1derx(1,lll,kkk,iii,1,1))
7170               call matvec2(auxmat(1,1),Ub2(1,i),
7171      &          AEAb2derx(1,lll,kkk,iii,1,1))
7172               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7173      &          AEAb1derx(1,lll,kkk,iii,2,1))
7174               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7175      &          AEAb2derx(1,lll,kkk,iii,2,1))
7176               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7177               call matvec2(auxmat(1,1),b1(1,itl),
7178      &          AEAb1derx(1,lll,kkk,iii,1,2))
7179               call matvec2(auxmat(1,1),Ub2(1,l),
7180      &          AEAb2derx(1,lll,kkk,iii,1,2))
7181               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7182      &          AEAb1derx(1,lll,kkk,iii,2,2))
7183               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7184      &          AEAb2derx(1,lll,kkk,iii,2,2))
7185             enddo
7186           enddo
7187         enddo
7188         ENDIF
7189 C End vectors
7190       endif
7191       return
7192       end
7193 C---------------------------------------------------------------------------
7194       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7195      &  KK,KKderg,AKA,AKAderg,AKAderx)
7196       implicit none
7197       integer nderg
7198       logical transp
7199       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7200      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7201      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7202       integer iii,kkk,lll
7203       integer jjj,mmm
7204       logical lprn
7205       common /kutas/ lprn
7206       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7207       do iii=1,nderg
7208         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7209      &    AKAderg(1,1,iii))
7210       enddo
7211 cd      if (lprn) write (2,*) 'In kernel'
7212       do kkk=1,5
7213 cd        if (lprn) write (2,*) 'kkk=',kkk
7214         do lll=1,3
7215           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7216      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7217 cd          if (lprn) then
7218 cd            write (2,*) 'lll=',lll
7219 cd            write (2,*) 'iii=1'
7220 cd            do jjj=1,2
7221 cd              write (2,'(3(2f10.5),5x)')
7222 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7223 cd            enddo
7224 cd          endif
7225           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7226      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7227 cd          if (lprn) then
7228 cd            write (2,*) 'lll=',lll
7229 cd            write (2,*) 'iii=2'
7230 cd            do jjj=1,2
7231 cd              write (2,'(3(2f10.5),5x)')
7232 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7233 cd            enddo
7234 cd          endif
7235         enddo
7236       enddo
7237       return
7238       end
7239 C---------------------------------------------------------------------------
7240       double precision function eello4(i,j,k,l,jj,kk)
7241       implicit real*8 (a-h,o-z)
7242       include 'DIMENSIONS'
7243       include 'COMMON.IOUNITS'
7244       include 'COMMON.CHAIN'
7245       include 'COMMON.DERIV'
7246       include 'COMMON.INTERACT'
7247       include 'COMMON.CONTACTS'
7248       include 'COMMON.TORSION'
7249       include 'COMMON.VAR'
7250       include 'COMMON.GEO'
7251       double precision pizda(2,2),ggg1(3),ggg2(3)
7252 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7253 cd        eello4=0.0d0
7254 cd        return
7255 cd      endif
7256 cd      print *,'eello4:',i,j,k,l,jj,kk
7257 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7258 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7259 cold      eij=facont_hb(jj,i)
7260 cold      ekl=facont_hb(kk,k)
7261 cold      ekont=eij*ekl
7262       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7263 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7264       gcorr_loc(k-1)=gcorr_loc(k-1)
7265      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7266       if (l.eq.j+1) then
7267         gcorr_loc(l-1)=gcorr_loc(l-1)
7268      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7269       else
7270         gcorr_loc(j-1)=gcorr_loc(j-1)
7271      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7272       endif
7273       do iii=1,2
7274         do kkk=1,5
7275           do lll=1,3
7276             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7277      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7278 cd            derx(lll,kkk,iii)=0.0d0
7279           enddo
7280         enddo
7281       enddo
7282 cd      gcorr_loc(l-1)=0.0d0
7283 cd      gcorr_loc(j-1)=0.0d0
7284 cd      gcorr_loc(k-1)=0.0d0
7285 cd      eel4=1.0d0
7286 cd      write (iout,*)'Contacts have occurred for peptide groups',
7287 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7288 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7289       if (j.lt.nres-1) then
7290         j1=j+1
7291         j2=j-1
7292       else
7293         j1=j-1
7294         j2=j-2
7295       endif
7296       if (l.lt.nres-1) then
7297         l1=l+1
7298         l2=l-1
7299       else
7300         l1=l-1
7301         l2=l-2
7302       endif
7303       do ll=1,3
7304 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7305 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7306         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7307         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7308 cgrad        ghalf=0.5d0*ggg1(ll)
7309         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7310         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7311         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7312         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7313         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7314         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7315 cgrad        ghalf=0.5d0*ggg2(ll)
7316         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7317         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7318         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7319         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7320         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7321         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7322       enddo
7323 cgrad      do m=i+1,j-1
7324 cgrad        do ll=1,3
7325 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7326 cgrad        enddo
7327 cgrad      enddo
7328 cgrad      do m=k+1,l-1
7329 cgrad        do ll=1,3
7330 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7331 cgrad        enddo
7332 cgrad      enddo
7333 cgrad      do m=i+2,j2
7334 cgrad        do ll=1,3
7335 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7336 cgrad        enddo
7337 cgrad      enddo
7338 cgrad      do m=k+2,l2
7339 cgrad        do ll=1,3
7340 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7341 cgrad        enddo
7342 cgrad      enddo
7343 cd      do iii=1,nres-3
7344 cd        write (2,*) iii,gcorr_loc(iii)
7345 cd      enddo
7346       eello4=ekont*eel4
7347 cd      write (2,*) 'ekont',ekont
7348 cd      write (iout,*) 'eello4',ekont*eel4
7349       return
7350       end
7351 C---------------------------------------------------------------------------
7352       double precision function eello5(i,j,k,l,jj,kk)
7353       implicit real*8 (a-h,o-z)
7354       include 'DIMENSIONS'
7355       include 'COMMON.IOUNITS'
7356       include 'COMMON.CHAIN'
7357       include 'COMMON.DERIV'
7358       include 'COMMON.INTERACT'
7359       include 'COMMON.CONTACTS'
7360       include 'COMMON.TORSION'
7361       include 'COMMON.VAR'
7362       include 'COMMON.GEO'
7363       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7364       double precision ggg1(3),ggg2(3)
7365 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7366 C                                                                              C
7367 C                            Parallel chains                                   C
7368 C                                                                              C
7369 C          o             o                   o             o                   C
7370 C         /l\           / \             \   / \           / \   /              C
7371 C        /   \         /   \             \ /   \         /   \ /               C
7372 C       j| o |l1       | o |              o| o |         | o |o                C
7373 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7374 C      \i/   \         /   \ /             /   \         /   \                 C
7375 C       o    k1             o                                                  C
7376 C         (I)          (II)                (III)          (IV)                 C
7377 C                                                                              C
7378 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7379 C                                                                              C
7380 C                            Antiparallel chains                               C
7381 C                                                                              C
7382 C          o             o                   o             o                   C
7383 C         /j\           / \             \   / \           / \   /              C
7384 C        /   \         /   \             \ /   \         /   \ /               C
7385 C      j1| o |l        | o |              o| o |         | o |o                C
7386 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7387 C      \i/   \         /   \ /             /   \         /   \                 C
7388 C       o     k1            o                                                  C
7389 C         (I)          (II)                (III)          (IV)                 C
7390 C                                                                              C
7391 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7392 C                                                                              C
7393 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7394 C                                                                              C
7395 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7396 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7397 cd        eello5=0.0d0
7398 cd        return
7399 cd      endif
7400 cd      write (iout,*)
7401 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7402 cd     &   ' and',k,l
7403       itk=itortyp(itype(k))
7404       itl=itortyp(itype(l))
7405       itj=itortyp(itype(j))
7406       eello5_1=0.0d0
7407       eello5_2=0.0d0
7408       eello5_3=0.0d0
7409       eello5_4=0.0d0
7410 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7411 cd     &   eel5_3_num,eel5_4_num)
7412       do iii=1,2
7413         do kkk=1,5
7414           do lll=1,3
7415             derx(lll,kkk,iii)=0.0d0
7416           enddo
7417         enddo
7418       enddo
7419 cd      eij=facont_hb(jj,i)
7420 cd      ekl=facont_hb(kk,k)
7421 cd      ekont=eij*ekl
7422 cd      write (iout,*)'Contacts have occurred for peptide groups',
7423 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7424 cd      goto 1111
7425 C Contribution from the graph I.
7426 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7427 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7428       call transpose2(EUg(1,1,k),auxmat(1,1))
7429       call matmat2(AEA(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       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7433      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7434 C Explicit gradient in virtual-dihedral angles.
7435       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7436      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7437      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7438       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7439       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7440       vv(1)=pizda(1,1)-pizda(2,2)
7441       vv(2)=pizda(1,2)+pizda(2,1)
7442       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7443      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7444      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7445       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7446       vv(1)=pizda(1,1)-pizda(2,2)
7447       vv(2)=pizda(1,2)+pizda(2,1)
7448       if (l.eq.j+1) then
7449         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7450      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7451      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7452       else
7453         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7454      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7455      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7456       endif
7457 C Cartesian gradient
7458       do iii=1,2
7459         do kkk=1,5
7460           do lll=1,3
7461             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7462      &        pizda(1,1))
7463             vv(1)=pizda(1,1)-pizda(2,2)
7464             vv(2)=pizda(1,2)+pizda(2,1)
7465             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7466      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7467      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7468           enddo
7469         enddo
7470       enddo
7471 c      goto 1112
7472 c1111  continue
7473 C Contribution from graph II
7474       call transpose2(EE(1,1,itk),auxmat(1,1))
7475       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7476       vv(1)=pizda(1,1)+pizda(2,2)
7477       vv(2)=pizda(2,1)-pizda(1,2)
7478       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7479      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7480 C Explicit gradient in virtual-dihedral angles.
7481       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7482      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7483       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7484       vv(1)=pizda(1,1)+pizda(2,2)
7485       vv(2)=pizda(2,1)-pizda(1,2)
7486       if (l.eq.j+1) then
7487         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7488      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7489      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7490       else
7491         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7492      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7493      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7494       endif
7495 C Cartesian gradient
7496       do iii=1,2
7497         do kkk=1,5
7498           do lll=1,3
7499             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7500      &        pizda(1,1))
7501             vv(1)=pizda(1,1)+pizda(2,2)
7502             vv(2)=pizda(2,1)-pizda(1,2)
7503             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7504      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7505      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7506           enddo
7507         enddo
7508       enddo
7509 cd      goto 1112
7510 cd1111  continue
7511       if (l.eq.j+1) then
7512 cd        goto 1110
7513 C Parallel orientation
7514 C Contribution from graph III
7515         call transpose2(EUg(1,1,l),auxmat(1,1))
7516         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7517         vv(1)=pizda(1,1)-pizda(2,2)
7518         vv(2)=pizda(1,2)+pizda(2,1)
7519         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7520      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7521 C Explicit gradient in virtual-dihedral angles.
7522         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7523      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7524      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7525         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7526         vv(1)=pizda(1,1)-pizda(2,2)
7527         vv(2)=pizda(1,2)+pizda(2,1)
7528         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7529      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7530      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7531         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7532         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7533         vv(1)=pizda(1,1)-pizda(2,2)
7534         vv(2)=pizda(1,2)+pizda(2,1)
7535         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7536      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7537      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7538 C Cartesian gradient
7539         do iii=1,2
7540           do kkk=1,5
7541             do lll=1,3
7542               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7543      &          pizda(1,1))
7544               vv(1)=pizda(1,1)-pizda(2,2)
7545               vv(2)=pizda(1,2)+pizda(2,1)
7546               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7547      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7548      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7549             enddo
7550           enddo
7551         enddo
7552 cd        goto 1112
7553 C Contribution from graph IV
7554 cd1110    continue
7555         call transpose2(EE(1,1,itl),auxmat(1,1))
7556         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7557         vv(1)=pizda(1,1)+pizda(2,2)
7558         vv(2)=pizda(2,1)-pizda(1,2)
7559         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7560      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7561 C Explicit gradient in virtual-dihedral angles.
7562         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7563      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7564         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7565         vv(1)=pizda(1,1)+pizda(2,2)
7566         vv(2)=pizda(2,1)-pizda(1,2)
7567         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7568      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7569      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7570 C Cartesian gradient
7571         do iii=1,2
7572           do kkk=1,5
7573             do lll=1,3
7574               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7575      &          pizda(1,1))
7576               vv(1)=pizda(1,1)+pizda(2,2)
7577               vv(2)=pizda(2,1)-pizda(1,2)
7578               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7579      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7580      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7581             enddo
7582           enddo
7583         enddo
7584       else
7585 C Antiparallel orientation
7586 C Contribution from graph III
7587 c        goto 1110
7588         call transpose2(EUg(1,1,j),auxmat(1,1))
7589         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7590         vv(1)=pizda(1,1)-pizda(2,2)
7591         vv(2)=pizda(1,2)+pizda(2,1)
7592         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7593      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7594 C Explicit gradient in virtual-dihedral angles.
7595         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7596      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7597      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7598         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7599         vv(1)=pizda(1,1)-pizda(2,2)
7600         vv(2)=pizda(1,2)+pizda(2,1)
7601         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7602      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7603      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7604         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7605         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7606         vv(1)=pizda(1,1)-pizda(2,2)
7607         vv(2)=pizda(1,2)+pizda(2,1)
7608         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7609      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7610      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7611 C Cartesian gradient
7612         do iii=1,2
7613           do kkk=1,5
7614             do lll=1,3
7615               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7616      &          pizda(1,1))
7617               vv(1)=pizda(1,1)-pizda(2,2)
7618               vv(2)=pizda(1,2)+pizda(2,1)
7619               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7620      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7621      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7622             enddo
7623           enddo
7624         enddo
7625 cd        goto 1112
7626 C Contribution from graph IV
7627 1110    continue
7628         call transpose2(EE(1,1,itj),auxmat(1,1))
7629         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7630         vv(1)=pizda(1,1)+pizda(2,2)
7631         vv(2)=pizda(2,1)-pizda(1,2)
7632         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7633      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7634 C Explicit gradient in virtual-dihedral angles.
7635         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7636      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7637         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7638         vv(1)=pizda(1,1)+pizda(2,2)
7639         vv(2)=pizda(2,1)-pizda(1,2)
7640         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7641      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7642      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7643 C Cartesian gradient
7644         do iii=1,2
7645           do kkk=1,5
7646             do lll=1,3
7647               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7648      &          pizda(1,1))
7649               vv(1)=pizda(1,1)+pizda(2,2)
7650               vv(2)=pizda(2,1)-pizda(1,2)
7651               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7652      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7653      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7654             enddo
7655           enddo
7656         enddo
7657       endif
7658 1112  continue
7659       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7660 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7661 cd        write (2,*) 'ijkl',i,j,k,l
7662 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7663 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7664 cd      endif
7665 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7666 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7667 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7668 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7669       if (j.lt.nres-1) then
7670         j1=j+1
7671         j2=j-1
7672       else
7673         j1=j-1
7674         j2=j-2
7675       endif
7676       if (l.lt.nres-1) then
7677         l1=l+1
7678         l2=l-1
7679       else
7680         l1=l-1
7681         l2=l-2
7682       endif
7683 cd      eij=1.0d0
7684 cd      ekl=1.0d0
7685 cd      ekont=1.0d0
7686 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7687 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7688 C        summed up outside the subrouine as for the other subroutines
7689 C        handling long-range interactions. The old code is commented out
7690 C        with "cgrad" to keep track of changes.
7691       do ll=1,3
7692 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7693 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7694         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7695         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7696 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7697 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7698 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7699 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7700 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7701 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7702 c     &   gradcorr5ij,
7703 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7704 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7705 cgrad        ghalf=0.5d0*ggg1(ll)
7706 cd        ghalf=0.0d0
7707         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7708         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7709         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7710         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7711         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7712         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7713 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7714 cgrad        ghalf=0.5d0*ggg2(ll)
7715 cd        ghalf=0.0d0
7716         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7717         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7718         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7719         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7720         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7721         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7722       enddo
7723 cd      goto 1112
7724 cgrad      do m=i+1,j-1
7725 cgrad        do ll=1,3
7726 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7727 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7728 cgrad        enddo
7729 cgrad      enddo
7730 cgrad      do m=k+1,l-1
7731 cgrad        do ll=1,3
7732 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7733 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7734 cgrad        enddo
7735 cgrad      enddo
7736 c1112  continue
7737 cgrad      do m=i+2,j2
7738 cgrad        do ll=1,3
7739 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7740 cgrad        enddo
7741 cgrad      enddo
7742 cgrad      do m=k+2,l2
7743 cgrad        do ll=1,3
7744 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7745 cgrad        enddo
7746 cgrad      enddo
7747 cd      do iii=1,nres-3
7748 cd        write (2,*) iii,g_corr5_loc(iii)
7749 cd      enddo
7750       eello5=ekont*eel5
7751 cd      write (2,*) 'ekont',ekont
7752 cd      write (iout,*) 'eello5',ekont*eel5
7753       return
7754       end
7755 c--------------------------------------------------------------------------
7756       double precision function eello6(i,j,k,l,jj,kk)
7757       implicit real*8 (a-h,o-z)
7758       include 'DIMENSIONS'
7759       include 'COMMON.IOUNITS'
7760       include 'COMMON.CHAIN'
7761       include 'COMMON.DERIV'
7762       include 'COMMON.INTERACT'
7763       include 'COMMON.CONTACTS'
7764       include 'COMMON.TORSION'
7765       include 'COMMON.VAR'
7766       include 'COMMON.GEO'
7767       include 'COMMON.FFIELD'
7768       double precision ggg1(3),ggg2(3)
7769 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7770 cd        eello6=0.0d0
7771 cd        return
7772 cd      endif
7773 cd      write (iout,*)
7774 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7775 cd     &   ' and',k,l
7776       eello6_1=0.0d0
7777       eello6_2=0.0d0
7778       eello6_3=0.0d0
7779       eello6_4=0.0d0
7780       eello6_5=0.0d0
7781       eello6_6=0.0d0
7782 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7783 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7784       do iii=1,2
7785         do kkk=1,5
7786           do lll=1,3
7787             derx(lll,kkk,iii)=0.0d0
7788           enddo
7789         enddo
7790       enddo
7791 cd      eij=facont_hb(jj,i)
7792 cd      ekl=facont_hb(kk,k)
7793 cd      ekont=eij*ekl
7794 cd      eij=1.0d0
7795 cd      ekl=1.0d0
7796 cd      ekont=1.0d0
7797       if (l.eq.j+1) then
7798         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7799         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7800         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7801         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7802         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7803         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7804       else
7805         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7806         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7807         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7808         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7809         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7810           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7811         else
7812           eello6_5=0.0d0
7813         endif
7814         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7815       endif
7816 C If turn contributions are considered, they will be handled separately.
7817       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7818 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7819 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7820 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7821 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7822 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7823 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7824 cd      goto 1112
7825       if (j.lt.nres-1) then
7826         j1=j+1
7827         j2=j-1
7828       else
7829         j1=j-1
7830         j2=j-2
7831       endif
7832       if (l.lt.nres-1) then
7833         l1=l+1
7834         l2=l-1
7835       else
7836         l1=l-1
7837         l2=l-2
7838       endif
7839       do ll=1,3
7840 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7841 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7842 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7843 cgrad        ghalf=0.5d0*ggg1(ll)
7844 cd        ghalf=0.0d0
7845         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7846         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7847         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7848         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7849         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7850         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7851         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7852         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7853 cgrad        ghalf=0.5d0*ggg2(ll)
7854 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7855 cd        ghalf=0.0d0
7856         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7857         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7858         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7859         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7860         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7861         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7862       enddo
7863 cd      goto 1112
7864 cgrad      do m=i+1,j-1
7865 cgrad        do ll=1,3
7866 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7867 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7868 cgrad        enddo
7869 cgrad      enddo
7870 cgrad      do m=k+1,l-1
7871 cgrad        do ll=1,3
7872 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7873 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7874 cgrad        enddo
7875 cgrad      enddo
7876 cgrad1112  continue
7877 cgrad      do m=i+2,j2
7878 cgrad        do ll=1,3
7879 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7880 cgrad        enddo
7881 cgrad      enddo
7882 cgrad      do m=k+2,l2
7883 cgrad        do ll=1,3
7884 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7885 cgrad        enddo
7886 cgrad      enddo
7887 cd      do iii=1,nres-3
7888 cd        write (2,*) iii,g_corr6_loc(iii)
7889 cd      enddo
7890       eello6=ekont*eel6
7891 cd      write (2,*) 'ekont',ekont
7892 cd      write (iout,*) 'eello6',ekont*eel6
7893       return
7894       end
7895 c--------------------------------------------------------------------------
7896       double precision function eello6_graph1(i,j,k,l,imat,swap)
7897       implicit real*8 (a-h,o-z)
7898       include 'DIMENSIONS'
7899       include 'COMMON.IOUNITS'
7900       include 'COMMON.CHAIN'
7901       include 'COMMON.DERIV'
7902       include 'COMMON.INTERACT'
7903       include 'COMMON.CONTACTS'
7904       include 'COMMON.TORSION'
7905       include 'COMMON.VAR'
7906       include 'COMMON.GEO'
7907       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7908       logical swap
7909       logical lprn
7910       common /kutas/ lprn
7911 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7912 C                                                                              C
7913 C      Parallel       Antiparallel                                             C
7914 C                                                                              C
7915 C          o             o                                                     C
7916 C         /l\           /j\                                                    C
7917 C        /   \         /   \                                                   C
7918 C       /| o |         | o |\                                                  C
7919 C     \ j|/k\|  /   \  |/k\|l /                                                C
7920 C      \ /   \ /     \ /   \ /                                                 C
7921 C       o     o       o     o                                                  C
7922 C       i             i                                                        C
7923 C                                                                              C
7924 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7925       itk=itortyp(itype(k))
7926       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7927       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7928       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7929       call transpose2(EUgC(1,1,k),auxmat(1,1))
7930       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7931       vv1(1)=pizda1(1,1)-pizda1(2,2)
7932       vv1(2)=pizda1(1,2)+pizda1(2,1)
7933       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7934       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7935       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7936       s5=scalar2(vv(1),Dtobr2(1,i))
7937 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7938       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7939       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7940      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7941      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7942      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7943      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7944      & +scalar2(vv(1),Dtobr2der(1,i)))
7945       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7946       vv1(1)=pizda1(1,1)-pizda1(2,2)
7947       vv1(2)=pizda1(1,2)+pizda1(2,1)
7948       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7949       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7950       if (l.eq.j+1) then
7951         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7952      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7953      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7954      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7955      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7956       else
7957         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7958      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7959      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7960      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7961      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7962       endif
7963       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7964       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7965       vv1(1)=pizda1(1,1)-pizda1(2,2)
7966       vv1(2)=pizda1(1,2)+pizda1(2,1)
7967       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7968      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7969      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7970      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7971       do iii=1,2
7972         if (swap) then
7973           ind=3-iii
7974         else
7975           ind=iii
7976         endif
7977         do kkk=1,5
7978           do lll=1,3
7979             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7980             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7981             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7982             call transpose2(EUgC(1,1,k),auxmat(1,1))
7983             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7984      &        pizda1(1,1))
7985             vv1(1)=pizda1(1,1)-pizda1(2,2)
7986             vv1(2)=pizda1(1,2)+pizda1(2,1)
7987             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7988             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7989      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7990             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7991      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7992             s5=scalar2(vv(1),Dtobr2(1,i))
7993             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7994           enddo
7995         enddo
7996       enddo
7997       return
7998       end
7999 c----------------------------------------------------------------------------
8000       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8001       implicit real*8 (a-h,o-z)
8002       include 'DIMENSIONS'
8003       include 'COMMON.IOUNITS'
8004       include 'COMMON.CHAIN'
8005       include 'COMMON.DERIV'
8006       include 'COMMON.INTERACT'
8007       include 'COMMON.CONTACTS'
8008       include 'COMMON.TORSION'
8009       include 'COMMON.VAR'
8010       include 'COMMON.GEO'
8011       logical swap
8012       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8013      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8014       logical lprn
8015       common /kutas/ lprn
8016 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8017 C                                                                              C
8018 C      Parallel       Antiparallel                                             C
8019 C                                                                              C
8020 C          o             o                                                     C
8021 C     \   /l\           /j\   /                                                C
8022 C      \ /   \         /   \ /                                                 C
8023 C       o| o |         | o |o                                                  C
8024 C     \ j|/k\|      \  |/k\|l                                                  C
8025 C      \ /   \       \ /   \                                                   C
8026 C       o             o                                                        C
8027 C       i             i                                                        C
8028 C                                                                              C
8029 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8030 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8031 C AL 7/4/01 s1 would occur in the sixth-order moment,
8032 C           but not in a cluster cumulant
8033 #ifdef MOMENT
8034       s1=dip(1,jj,i)*dip(1,kk,k)
8035 #endif
8036       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8037       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8038       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8039       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8040       call transpose2(EUg(1,1,k),auxmat(1,1))
8041       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8042       vv(1)=pizda(1,1)-pizda(2,2)
8043       vv(2)=pizda(1,2)+pizda(2,1)
8044       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8045 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8046 #ifdef MOMENT
8047       eello6_graph2=-(s1+s2+s3+s4)
8048 #else
8049       eello6_graph2=-(s2+s3+s4)
8050 #endif
8051 c      eello6_graph2=-s3
8052 C Derivatives in gamma(i-1)
8053       if (i.gt.1) then
8054 #ifdef MOMENT
8055         s1=dipderg(1,jj,i)*dip(1,kk,k)
8056 #endif
8057         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8058         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8059         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8060         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8061 #ifdef MOMENT
8062         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8063 #else
8064         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8065 #endif
8066 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8067       endif
8068 C Derivatives in gamma(k-1)
8069 #ifdef MOMENT
8070       s1=dip(1,jj,i)*dipderg(1,kk,k)
8071 #endif
8072       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8073       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8074       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8075       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8076       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8077       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8078       vv(1)=pizda(1,1)-pizda(2,2)
8079       vv(2)=pizda(1,2)+pizda(2,1)
8080       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8081 #ifdef MOMENT
8082       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8083 #else
8084       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8085 #endif
8086 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8087 C Derivatives in gamma(j-1) or gamma(l-1)
8088       if (j.gt.1) then
8089 #ifdef MOMENT
8090         s1=dipderg(3,jj,i)*dip(1,kk,k)
8091 #endif
8092         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8093         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8094         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8095         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8096         vv(1)=pizda(1,1)-pizda(2,2)
8097         vv(2)=pizda(1,2)+pizda(2,1)
8098         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8099 #ifdef MOMENT
8100         if (swap) then
8101           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8102         else
8103           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8104         endif
8105 #endif
8106         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8107 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8108       endif
8109 C Derivatives in gamma(l-1) or gamma(j-1)
8110       if (l.gt.1) then
8111 #ifdef MOMENT
8112         s1=dip(1,jj,i)*dipderg(3,kk,k)
8113 #endif
8114         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8115         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8116         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8117         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8118         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8119         vv(1)=pizda(1,1)-pizda(2,2)
8120         vv(2)=pizda(1,2)+pizda(2,1)
8121         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8122 #ifdef MOMENT
8123         if (swap) then
8124           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8125         else
8126           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8127         endif
8128 #endif
8129         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8130 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8131       endif
8132 C Cartesian derivatives.
8133       if (lprn) then
8134         write (2,*) 'In eello6_graph2'
8135         do iii=1,2
8136           write (2,*) 'iii=',iii
8137           do kkk=1,5
8138             write (2,*) 'kkk=',kkk
8139             do jjj=1,2
8140               write (2,'(3(2f10.5),5x)')
8141      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8142             enddo
8143           enddo
8144         enddo
8145       endif
8146       do iii=1,2
8147         do kkk=1,5
8148           do lll=1,3
8149 #ifdef MOMENT
8150             if (iii.eq.1) then
8151               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8152             else
8153               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8154             endif
8155 #endif
8156             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8157      &        auxvec(1))
8158             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8159             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8160      &        auxvec(1))
8161             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8162             call transpose2(EUg(1,1,k),auxmat(1,1))
8163             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8164      &        pizda(1,1))
8165             vv(1)=pizda(1,1)-pizda(2,2)
8166             vv(2)=pizda(1,2)+pizda(2,1)
8167             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8168 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8169 #ifdef MOMENT
8170             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8171 #else
8172             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8173 #endif
8174             if (swap) then
8175               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8176             else
8177               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8178             endif
8179           enddo
8180         enddo
8181       enddo
8182       return
8183       end
8184 c----------------------------------------------------------------------------
8185       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8186       implicit real*8 (a-h,o-z)
8187       include 'DIMENSIONS'
8188       include 'COMMON.IOUNITS'
8189       include 'COMMON.CHAIN'
8190       include 'COMMON.DERIV'
8191       include 'COMMON.INTERACT'
8192       include 'COMMON.CONTACTS'
8193       include 'COMMON.TORSION'
8194       include 'COMMON.VAR'
8195       include 'COMMON.GEO'
8196       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8197       logical swap
8198 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8199 C                                                                              C
8200 C      Parallel       Antiparallel                                             C
8201 C                                                                              C
8202 C          o             o                                                     C
8203 C         /l\   /   \   /j\                                                    C
8204 C        /   \ /     \ /   \                                                   C
8205 C       /| o |o       o| o |\                                                  C
8206 C       j|/k\|  /      |/k\|l /                                                C
8207 C        /   \ /       /   \ /                                                 C
8208 C       /     o       /     o                                                  C
8209 C       i             i                                                        C
8210 C                                                                              C
8211 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8212 C
8213 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8214 C           energy moment and not to the cluster cumulant.
8215       iti=itortyp(itype(i))
8216       if (j.lt.nres-1) then
8217         itj1=itortyp(itype(j+1))
8218       else
8219         itj1=ntortyp+1
8220       endif
8221       itk=itortyp(itype(k))
8222       itk1=itortyp(itype(k+1))
8223       if (l.lt.nres-1) then
8224         itl1=itortyp(itype(l+1))
8225       else
8226         itl1=ntortyp+1
8227       endif
8228 #ifdef MOMENT
8229       s1=dip(4,jj,i)*dip(4,kk,k)
8230 #endif
8231       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8232       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8233       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8234       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8235       call transpose2(EE(1,1,itk),auxmat(1,1))
8236       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8237       vv(1)=pizda(1,1)+pizda(2,2)
8238       vv(2)=pizda(2,1)-pizda(1,2)
8239       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8240 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8241 cd     & "sum",-(s2+s3+s4)
8242 #ifdef MOMENT
8243       eello6_graph3=-(s1+s2+s3+s4)
8244 #else
8245       eello6_graph3=-(s2+s3+s4)
8246 #endif
8247 c      eello6_graph3=-s4
8248 C Derivatives in gamma(k-1)
8249       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8250       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8251       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8252       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8253 C Derivatives in gamma(l-1)
8254       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8255       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8256       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8257       vv(1)=pizda(1,1)+pizda(2,2)
8258       vv(2)=pizda(2,1)-pizda(1,2)
8259       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8260       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8261 C Cartesian derivatives.
8262       do iii=1,2
8263         do kkk=1,5
8264           do lll=1,3
8265 #ifdef MOMENT
8266             if (iii.eq.1) then
8267               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8268             else
8269               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8270             endif
8271 #endif
8272             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8273      &        auxvec(1))
8274             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8275             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8276      &        auxvec(1))
8277             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8278             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8279      &        pizda(1,1))
8280             vv(1)=pizda(1,1)+pizda(2,2)
8281             vv(2)=pizda(2,1)-pizda(1,2)
8282             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8283 #ifdef MOMENT
8284             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8285 #else
8286             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8287 #endif
8288             if (swap) then
8289               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8290             else
8291               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8292             endif
8293 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8294           enddo
8295         enddo
8296       enddo
8297       return
8298       end
8299 c----------------------------------------------------------------------------
8300       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8301       implicit real*8 (a-h,o-z)
8302       include 'DIMENSIONS'
8303       include 'COMMON.IOUNITS'
8304       include 'COMMON.CHAIN'
8305       include 'COMMON.DERIV'
8306       include 'COMMON.INTERACT'
8307       include 'COMMON.CONTACTS'
8308       include 'COMMON.TORSION'
8309       include 'COMMON.VAR'
8310       include 'COMMON.GEO'
8311       include 'COMMON.FFIELD'
8312       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8313      & auxvec1(2),auxmat1(2,2)
8314       logical swap
8315 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8316 C                                                                              C
8317 C      Parallel       Antiparallel                                             C
8318 C                                                                              C
8319 C          o             o                                                     C
8320 C         /l\   /   \   /j\                                                    C
8321 C        /   \ /     \ /   \                                                   C
8322 C       /| o |o       o| o |\                                                  C
8323 C     \ j|/k\|      \  |/k\|l                                                  C
8324 C      \ /   \       \ /   \                                                   C
8325 C       o     \       o     \                                                  C
8326 C       i             i                                                        C
8327 C                                                                              C
8328 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8329 C
8330 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8331 C           energy moment and not to the cluster cumulant.
8332 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8333       iti=itortyp(itype(i))
8334       itj=itortyp(itype(j))
8335       if (j.lt.nres-1) then
8336         itj1=itortyp(itype(j+1))
8337       else
8338         itj1=ntortyp+1
8339       endif
8340       itk=itortyp(itype(k))
8341       if (k.lt.nres-1) then
8342         itk1=itortyp(itype(k+1))
8343       else
8344         itk1=ntortyp+1
8345       endif
8346       itl=itortyp(itype(l))
8347       if (l.lt.nres-1) then
8348         itl1=itortyp(itype(l+1))
8349       else
8350         itl1=ntortyp+1
8351       endif
8352 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8353 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8354 cd     & ' itl',itl,' itl1',itl1
8355 #ifdef MOMENT
8356       if (imat.eq.1) then
8357         s1=dip(3,jj,i)*dip(3,kk,k)
8358       else
8359         s1=dip(2,jj,j)*dip(2,kk,l)
8360       endif
8361 #endif
8362       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8363       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8364       if (j.eq.l+1) then
8365         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8366         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8367       else
8368         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8369         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8370       endif
8371       call transpose2(EUg(1,1,k),auxmat(1,1))
8372       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8373       vv(1)=pizda(1,1)-pizda(2,2)
8374       vv(2)=pizda(2,1)+pizda(1,2)
8375       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8376 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8377 #ifdef MOMENT
8378       eello6_graph4=-(s1+s2+s3+s4)
8379 #else
8380       eello6_graph4=-(s2+s3+s4)
8381 #endif
8382 C Derivatives in gamma(i-1)
8383       if (i.gt.1) then
8384 #ifdef MOMENT
8385         if (imat.eq.1) then
8386           s1=dipderg(2,jj,i)*dip(3,kk,k)
8387         else
8388           s1=dipderg(4,jj,j)*dip(2,kk,l)
8389         endif
8390 #endif
8391         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8392         if (j.eq.l+1) then
8393           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8394           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8395         else
8396           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8397           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8398         endif
8399         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8400         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8401 cd          write (2,*) 'turn6 derivatives'
8402 #ifdef MOMENT
8403           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8404 #else
8405           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8406 #endif
8407         else
8408 #ifdef MOMENT
8409           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8410 #else
8411           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8412 #endif
8413         endif
8414       endif
8415 C Derivatives in gamma(k-1)
8416 #ifdef MOMENT
8417       if (imat.eq.1) then
8418         s1=dip(3,jj,i)*dipderg(2,kk,k)
8419       else
8420         s1=dip(2,jj,j)*dipderg(4,kk,l)
8421       endif
8422 #endif
8423       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8424       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8425       if (j.eq.l+1) then
8426         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8427         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8428       else
8429         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8430         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8431       endif
8432       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8433       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8434       vv(1)=pizda(1,1)-pizda(2,2)
8435       vv(2)=pizda(2,1)+pizda(1,2)
8436       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8437       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8438 #ifdef MOMENT
8439         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8440 #else
8441         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8442 #endif
8443       else
8444 #ifdef MOMENT
8445         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8446 #else
8447         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8448 #endif
8449       endif
8450 C Derivatives in gamma(j-1) or gamma(l-1)
8451       if (l.eq.j+1 .and. l.gt.1) then
8452         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8453         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8454         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8455         vv(1)=pizda(1,1)-pizda(2,2)
8456         vv(2)=pizda(2,1)+pizda(1,2)
8457         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8458         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8459       else if (j.gt.1) then
8460         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8461         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8462         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8463         vv(1)=pizda(1,1)-pizda(2,2)
8464         vv(2)=pizda(2,1)+pizda(1,2)
8465         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8466         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8467           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8468         else
8469           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8470         endif
8471       endif
8472 C Cartesian derivatives.
8473       do iii=1,2
8474         do kkk=1,5
8475           do lll=1,3
8476 #ifdef MOMENT
8477             if (iii.eq.1) then
8478               if (imat.eq.1) then
8479                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8480               else
8481                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8482               endif
8483             else
8484               if (imat.eq.1) then
8485                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8486               else
8487                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8488               endif
8489             endif
8490 #endif
8491             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8492      &        auxvec(1))
8493             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8494             if (j.eq.l+1) then
8495               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8496      &          b1(1,itj1),auxvec(1))
8497               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8498             else
8499               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8500      &          b1(1,itl1),auxvec(1))
8501               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8502             endif
8503             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8504      &        pizda(1,1))
8505             vv(1)=pizda(1,1)-pizda(2,2)
8506             vv(2)=pizda(2,1)+pizda(1,2)
8507             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8508             if (swap) then
8509               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8510 #ifdef MOMENT
8511                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8512      &             -(s1+s2+s4)
8513 #else
8514                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8515      &             -(s2+s4)
8516 #endif
8517                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8518               else
8519 #ifdef MOMENT
8520                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8521 #else
8522                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8523 #endif
8524                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8525               endif
8526             else
8527 #ifdef MOMENT
8528               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8529 #else
8530               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8531 #endif
8532               if (l.eq.j+1) then
8533                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8534               else
8535                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8536               endif
8537             endif
8538           enddo
8539         enddo
8540       enddo
8541       return
8542       end
8543 c----------------------------------------------------------------------------
8544       double precision function eello_turn6(i,jj,kk)
8545       implicit real*8 (a-h,o-z)
8546       include 'DIMENSIONS'
8547       include 'COMMON.IOUNITS'
8548       include 'COMMON.CHAIN'
8549       include 'COMMON.DERIV'
8550       include 'COMMON.INTERACT'
8551       include 'COMMON.CONTACTS'
8552       include 'COMMON.TORSION'
8553       include 'COMMON.VAR'
8554       include 'COMMON.GEO'
8555       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8556      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8557      &  ggg1(3),ggg2(3)
8558       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8559      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8560 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8561 C           the respective energy moment and not to the cluster cumulant.
8562       s1=0.0d0
8563       s8=0.0d0
8564       s13=0.0d0
8565 c
8566       eello_turn6=0.0d0
8567       j=i+4
8568       k=i+1
8569       l=i+3
8570       iti=itortyp(itype(i))
8571       itk=itortyp(itype(k))
8572       itk1=itortyp(itype(k+1))
8573       itl=itortyp(itype(l))
8574       itj=itortyp(itype(j))
8575 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8576 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8577 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8578 cd        eello6=0.0d0
8579 cd        return
8580 cd      endif
8581 cd      write (iout,*)
8582 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8583 cd     &   ' and',k,l
8584 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8585       do iii=1,2
8586         do kkk=1,5
8587           do lll=1,3
8588             derx_turn(lll,kkk,iii)=0.0d0
8589           enddo
8590         enddo
8591       enddo
8592 cd      eij=1.0d0
8593 cd      ekl=1.0d0
8594 cd      ekont=1.0d0
8595       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8596 cd      eello6_5=0.0d0
8597 cd      write (2,*) 'eello6_5',eello6_5
8598 #ifdef MOMENT
8599       call transpose2(AEA(1,1,1),auxmat(1,1))
8600       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8601       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8602       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8603 #endif
8604       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8605       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8606       s2 = scalar2(b1(1,itk),vtemp1(1))
8607 #ifdef MOMENT
8608       call transpose2(AEA(1,1,2),atemp(1,1))
8609       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8610       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8611       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8612 #endif
8613       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8614       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8615       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8616 #ifdef MOMENT
8617       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8618       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8619       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8620       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8621       ss13 = scalar2(b1(1,itk),vtemp4(1))
8622       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8623 #endif
8624 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8625 c      s1=0.0d0
8626 c      s2=0.0d0
8627 c      s8=0.0d0
8628 c      s12=0.0d0
8629 c      s13=0.0d0
8630       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8631 C Derivatives in gamma(i+2)
8632       s1d =0.0d0
8633       s8d =0.0d0
8634 #ifdef MOMENT
8635       call transpose2(AEA(1,1,1),auxmatd(1,1))
8636       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8637       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8638       call transpose2(AEAderg(1,1,2),atempd(1,1))
8639       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8640       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8641 #endif
8642       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8643       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8644       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8645 c      s1d=0.0d0
8646 c      s2d=0.0d0
8647 c      s8d=0.0d0
8648 c      s12d=0.0d0
8649 c      s13d=0.0d0
8650       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8651 C Derivatives in gamma(i+3)
8652 #ifdef MOMENT
8653       call transpose2(AEA(1,1,1),auxmatd(1,1))
8654       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8655       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8656       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8657 #endif
8658       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8659       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8660       s2d = scalar2(b1(1,itk),vtemp1d(1))
8661 #ifdef MOMENT
8662       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8663       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8664 #endif
8665       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8666 #ifdef MOMENT
8667       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8668       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8669       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8670 #endif
8671 c      s1d=0.0d0
8672 c      s2d=0.0d0
8673 c      s8d=0.0d0
8674 c      s12d=0.0d0
8675 c      s13d=0.0d0
8676 #ifdef MOMENT
8677       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8678      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8679 #else
8680       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8681      &               -0.5d0*ekont*(s2d+s12d)
8682 #endif
8683 C Derivatives in gamma(i+4)
8684       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8685       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8686       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8687 #ifdef MOMENT
8688       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8689       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8690       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8691 #endif
8692 c      s1d=0.0d0
8693 c      s2d=0.0d0
8694 c      s8d=0.0d0
8695 C      s12d=0.0d0
8696 c      s13d=0.0d0
8697 #ifdef MOMENT
8698       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8699 #else
8700       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8701 #endif
8702 C Derivatives in gamma(i+5)
8703 #ifdef MOMENT
8704       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8705       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8706       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8707 #endif
8708       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8709       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8710       s2d = scalar2(b1(1,itk),vtemp1d(1))
8711 #ifdef MOMENT
8712       call transpose2(AEA(1,1,2),atempd(1,1))
8713       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8714       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8715 #endif
8716       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8717       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8718 #ifdef MOMENT
8719       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8720       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8721       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8722 #endif
8723 c      s1d=0.0d0
8724 c      s2d=0.0d0
8725 c      s8d=0.0d0
8726 c      s12d=0.0d0
8727 c      s13d=0.0d0
8728 #ifdef MOMENT
8729       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8730      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8731 #else
8732       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8733      &               -0.5d0*ekont*(s2d+s12d)
8734 #endif
8735 C Cartesian derivatives
8736       do iii=1,2
8737         do kkk=1,5
8738           do lll=1,3
8739 #ifdef MOMENT
8740             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8741             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8742             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8743 #endif
8744             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8745             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8746      &          vtemp1d(1))
8747             s2d = scalar2(b1(1,itk),vtemp1d(1))
8748 #ifdef MOMENT
8749             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8750             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8751             s8d = -(atempd(1,1)+atempd(2,2))*
8752      &           scalar2(cc(1,1,itl),vtemp2(1))
8753 #endif
8754             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8755      &           auxmatd(1,1))
8756             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8757             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8758 c      s1d=0.0d0
8759 c      s2d=0.0d0
8760 c      s8d=0.0d0
8761 c      s12d=0.0d0
8762 c      s13d=0.0d0
8763 #ifdef MOMENT
8764             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8765      &        - 0.5d0*(s1d+s2d)
8766 #else
8767             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8768      &        - 0.5d0*s2d
8769 #endif
8770 #ifdef MOMENT
8771             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8772      &        - 0.5d0*(s8d+s12d)
8773 #else
8774             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8775      &        - 0.5d0*s12d
8776 #endif
8777           enddo
8778         enddo
8779       enddo
8780 #ifdef MOMENT
8781       do kkk=1,5
8782         do lll=1,3
8783           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8784      &      achuj_tempd(1,1))
8785           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8786           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8787           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8788           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8789           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8790      &      vtemp4d(1))
8791           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8792           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8793           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8794         enddo
8795       enddo
8796 #endif
8797 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8798 cd     &  16*eel_turn6_num
8799 cd      goto 1112
8800       if (j.lt.nres-1) then
8801         j1=j+1
8802         j2=j-1
8803       else
8804         j1=j-1
8805         j2=j-2
8806       endif
8807       if (l.lt.nres-1) then
8808         l1=l+1
8809         l2=l-1
8810       else
8811         l1=l-1
8812         l2=l-2
8813       endif
8814       do ll=1,3
8815 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8816 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8817 cgrad        ghalf=0.5d0*ggg1(ll)
8818 cd        ghalf=0.0d0
8819         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8820         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8821         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8822      &    +ekont*derx_turn(ll,2,1)
8823         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8824         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8825      &    +ekont*derx_turn(ll,4,1)
8826         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8827         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8828         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8829 cgrad        ghalf=0.5d0*ggg2(ll)
8830 cd        ghalf=0.0d0
8831         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8832      &    +ekont*derx_turn(ll,2,2)
8833         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8834         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8835      &    +ekont*derx_turn(ll,4,2)
8836         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8837         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8838         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8839       enddo
8840 cd      goto 1112
8841 cgrad      do m=i+1,j-1
8842 cgrad        do ll=1,3
8843 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8844 cgrad        enddo
8845 cgrad      enddo
8846 cgrad      do m=k+1,l-1
8847 cgrad        do ll=1,3
8848 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8849 cgrad        enddo
8850 cgrad      enddo
8851 cgrad1112  continue
8852 cgrad      do m=i+2,j2
8853 cgrad        do ll=1,3
8854 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8855 cgrad        enddo
8856 cgrad      enddo
8857 cgrad      do m=k+2,l2
8858 cgrad        do ll=1,3
8859 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8860 cgrad        enddo
8861 cgrad      enddo
8862 cd      do iii=1,nres-3
8863 cd        write (2,*) iii,g_corr6_loc(iii)
8864 cd      enddo
8865       eello_turn6=ekont*eel_turn6
8866 cd      write (2,*) 'ekont',ekont
8867 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8868       return
8869       end
8870
8871 C-----------------------------------------------------------------------------
8872       double precision function scalar(u,v)
8873 !DIR$ INLINEALWAYS scalar
8874 #ifndef OSF
8875 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8876 #endif
8877       implicit none
8878       double precision u(3),v(3)
8879 cd      double precision sc
8880 cd      integer i
8881 cd      sc=0.0d0
8882 cd      do i=1,3
8883 cd        sc=sc+u(i)*v(i)
8884 cd      enddo
8885 cd      scalar=sc
8886
8887       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8888       return
8889       end
8890 crc-------------------------------------------------
8891       SUBROUTINE MATVEC2(A1,V1,V2)
8892 !DIR$ INLINEALWAYS MATVEC2
8893 #ifndef OSF
8894 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8895 #endif
8896       implicit real*8 (a-h,o-z)
8897       include 'DIMENSIONS'
8898       DIMENSION A1(2,2),V1(2),V2(2)
8899 c      DO 1 I=1,2
8900 c        VI=0.0
8901 c        DO 3 K=1,2
8902 c    3     VI=VI+A1(I,K)*V1(K)
8903 c        Vaux(I)=VI
8904 c    1 CONTINUE
8905
8906       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8907       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8908
8909       v2(1)=vaux1
8910       v2(2)=vaux2
8911       END
8912 C---------------------------------------
8913       SUBROUTINE MATMAT2(A1,A2,A3)
8914 #ifndef OSF
8915 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8916 #endif
8917       implicit real*8 (a-h,o-z)
8918       include 'DIMENSIONS'
8919       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8920 c      DIMENSION AI3(2,2)
8921 c        DO  J=1,2
8922 c          A3IJ=0.0
8923 c          DO K=1,2
8924 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8925 c          enddo
8926 c          A3(I,J)=A3IJ
8927 c       enddo
8928 c      enddo
8929
8930       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8931       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8932       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8933       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8934
8935       A3(1,1)=AI3_11
8936       A3(2,1)=AI3_21
8937       A3(1,2)=AI3_12
8938       A3(2,2)=AI3_22
8939       END
8940
8941 c-------------------------------------------------------------------------
8942       double precision function scalar2(u,v)
8943 !DIR$ INLINEALWAYS scalar2
8944       implicit none
8945       double precision u(2),v(2)
8946       double precision sc
8947       integer i
8948       scalar2=u(1)*v(1)+u(2)*v(2)
8949       return
8950       end
8951
8952 C-----------------------------------------------------------------------------
8953
8954       subroutine transpose2(a,at)
8955 !DIR$ INLINEALWAYS transpose2
8956 #ifndef OSF
8957 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8958 #endif
8959       implicit none
8960       double precision a(2,2),at(2,2)
8961       at(1,1)=a(1,1)
8962       at(1,2)=a(2,1)
8963       at(2,1)=a(1,2)
8964       at(2,2)=a(2,2)
8965       return
8966       end
8967 c--------------------------------------------------------------------------
8968       subroutine transpose(n,a,at)
8969       implicit none
8970       integer n,i,j
8971       double precision a(n,n),at(n,n)
8972       do i=1,n
8973         do j=1,n
8974           at(j,i)=a(i,j)
8975         enddo
8976       enddo
8977       return
8978       end
8979 C---------------------------------------------------------------------------
8980       subroutine prodmat3(a1,a2,kk,transp,prod)
8981 !DIR$ INLINEALWAYS prodmat3
8982 #ifndef OSF
8983 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8984 #endif
8985       implicit none
8986       integer i,j
8987       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8988       logical transp
8989 crc      double precision auxmat(2,2),prod_(2,2)
8990
8991       if (transp) then
8992 crc        call transpose2(kk(1,1),auxmat(1,1))
8993 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8994 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8995
8996            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8997      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8998            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8999      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9000            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9001      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9002            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9003      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9004
9005       else
9006 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9007 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9008
9009            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9010      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9011            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9012      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9013            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9014      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9015            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9016      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9017
9018       endif
9019 c      call transpose2(a2(1,1),a2t(1,1))
9020
9021 crc      print *,transp
9022 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9023 crc      print *,((prod(i,j),i=1,2),j=1,2)
9024
9025       return
9026       end
9027