source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c      print *," Processor",myrank," calls SUM_ENERGY"
 300       call sum_energy(energia,.true.)
 301 c      print *," Processor",myrank," left SUM_ENERGY"
 302 #ifdef TIMING
 303       time_sumene=time_sumene+MPI_Wtime()-time00
 304 #endif
 305       return
 306       end
 307 c-------------------------------------------------------------------------------
 308       subroutine sum_energy(energia,reduce)
 309       implicit real*8 (a-h,o-z)
 310       include 'DIMENSIONS'
 311 #ifndef ISNAN
 312       external proc_proc
 313 #ifdef WINPGI
 314 cMS$ATTRIBUTES C ::  proc_proc
 315 #endif
 316 #endif
 317 #ifdef MPI
 318       include "mpif.h"
 319 #endif
 320       include 'COMMON.SETUP'
 321       include 'COMMON.IOUNITS'
 322       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 323       include 'COMMON.FFIELD'
 324       include 'COMMON.DERIV'
 325       include 'COMMON.INTERACT'
 326       include 'COMMON.SBRIDGE'
 327       include 'COMMON.CHAIN'
 328       include 'COMMON.VAR'
 329       include 'COMMON.CONTROL'
 330       include 'COMMON.TIME1'
 331       logical reduce
 332 #ifdef MPI
 333       if (nfgtasks.gt.1 .and. reduce) then
 334 #ifdef DEBUG
 335         write (iout,*) "energies before REDUCE"
 336         call enerprint(energia)
 337         call flush(iout)
 338 #endif
 339         do i=0,n_ene
 340           enebuff(i)=energia(i)
 341         enddo
 342         time00=MPI_Wtime()
 343         call MPI_Barrier(FG_COMM,IERR)
 344         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 345         time00=MPI_Wtime()
 346         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 347      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 348 #ifdef DEBUG
 349         write (iout,*) "energies after REDUCE"
 350         call enerprint(energia)
 351         call flush(iout)
 352 #endif
 353         time_Reduce=time_Reduce+MPI_Wtime()-time00
 354       endif
 355       if (fg_rank.eq.0) then
 356 #endif
 357       evdw=energia(1)
 358 #ifdef SCP14
 359       evdw2=energia(2)+energia(18)
 360       evdw2_14=energia(18)
 361 #else
 362       evdw2=energia(2)
 363 #endif
 364 #ifdef SPLITELE
 365       ees=energia(3)
 366       evdw1=energia(16)
 367 #else
 368       ees=energia(3)
 369       evdw1=0.0d0
 370 #endif
 371       ecorr=energia(4)
 372       ecorr5=energia(5)
 373       ecorr6=energia(6)
 374       eel_loc=energia(7)
 375       eello_turn3=energia(8)
 376       eello_turn4=energia(9)
 377       eturn6=energia(10)
 378       ebe=energia(11)
 379       escloc=energia(12)
 380       etors=energia(13)
 381       etors_d=energia(14)
 382       ehpb=energia(15)
 383       edihcnstr=energia(19)
 384       estr=energia(17)
 385       Uconst=energia(20)
 386       esccor=energia(21)
 387 #ifdef SPLITELE
 388       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 389      & +wang*ebe+wtor*etors+wscloc*escloc
 390      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 391      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 392      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 393      & +wbond*estr+Uconst+wsccor*esccor
 394 #else
 395       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 396      & +wang*ebe+wtor*etors+wscloc*escloc
 397      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 398      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 399      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 400      & +wbond*estr+Uconst+wsccor*esccor
 401 #endif
 402       energia(0)=etot
 403 c detecting NaNQ
 404 #ifdef ISNAN
 405 #ifdef AIX
 406       if (isnan(etot).ne.0) energia(0)=1.0d+99
 407 #else
 408       if (isnan(etot)) energia(0)=1.0d+99
 409 #endif
 410 #else
 411       i=0
 412 #ifdef WINPGI
 413       idumm=proc_proc(etot,i)
 414 #else
 415       call proc_proc(etot,i)
 416 #endif
 417       if(i.eq.1)energia(0)=1.0d+99
 418 #endif
 419 #ifdef MPI
 420       endif
 421 #endif
 422       return
 423       end
 424 c-------------------------------------------------------------------------------
 425       subroutine sum_gradient
 426       implicit real*8 (a-h,o-z)
 427       include 'DIMENSIONS'
 428 #ifndef ISNAN
 429       external proc_proc
 430 #ifdef WINPGI
 431 cMS$ATTRIBUTES C ::  proc_proc
 432 #endif
 433 #endif
 434 #ifdef MPI
 435       include 'mpif.h'
 436       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 437      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 438 #endif
 439       include 'COMMON.SETUP'
 440       include 'COMMON.IOUNITS'
 441       include 'COMMON.FFIELD'
 442       include 'COMMON.DERIV'
 443       include 'COMMON.INTERACT'
 444       include 'COMMON.SBRIDGE'
 445       include 'COMMON.CHAIN'
 446       include 'COMMON.VAR'
 447       include 'COMMON.CONTROL'
 448       include 'COMMON.TIME1'
 449       include 'COMMON.MAXGRAD'
 450       include 'COMMON.SCCOR'
 451 #ifdef TIMING
 452       time01=MPI_Wtime()
 453 #endif
 454 #ifdef DEBUG
 455       write (iout,*) "sum_gradient gvdwc, gvdwx"
 456       do i=1,nres
 457         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 458      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 459       enddo
 460       call flush(iout)
 461 #endif
 462 #ifdef MPI
 463 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 464         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 465      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 466 #endif
 467 C
 468 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 469 C            in virtual-bond-vector coordinates
 470 C
 471 #ifdef DEBUG
 472 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 473 c      do i=1,nres-1
 474 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 475 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 476 c      enddo
 477 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 478 c      do i=1,nres-1
 479 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 480 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 481 c      enddo
 482       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 483       do i=1,nres
 484         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 485      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 486      &   g_corr5_loc(i)
 487       enddo
 488       call flush(iout)
 489 #endif
 490 #ifdef SPLITELE
 491       do i=1,nct
 492         do j=1,3
 493           gradbufc(j,i)=wsc*gvdwc(j,i)+
 494      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 495      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 496      &                wel_loc*gel_loc_long(j,i)+
 497      &                wcorr*gradcorr_long(j,i)+
 498      &                wcorr5*gradcorr5_long(j,i)+
 499      &                wcorr6*gradcorr6_long(j,i)+
 500      &                wturn6*gcorr6_turn_long(j,i)+
 501      &                wstrain*ghpbc(j,i)
 502         enddo
 503       enddo
 504 #else
 505       do i=1,nct
 506         do j=1,3
 507           gradbufc(j,i)=wsc*gvdwc(j,i)+
 508      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 509      &                welec*gelc_long(j,i)+
 510      &                wbond*gradb(j,i)+
 511      &                wel_loc*gel_loc_long(j,i)+
 512      &                wcorr*gradcorr_long(j,i)+
 513      &                wcorr5*gradcorr5_long(j,i)+
 514      &                wcorr6*gradcorr6_long(j,i)+
 515      &                wturn6*gcorr6_turn_long(j,i)+
 516      &                wstrain*ghpbc(j,i)
 517         enddo
 518       enddo
 519 #endif
 520 #ifdef MPI
 521       if (nfgtasks.gt.1) then
 522       time00=MPI_Wtime()
 523 #ifdef DEBUG
 524       write (iout,*) "gradbufc before allreduce"
 525       do i=1,nres
 526         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 527       enddo
 528       call flush(iout)
 529 #endif
 530       do i=1,nres
 531         do j=1,3
 532           gradbufc_sum(j,i)=gradbufc(j,i)
 533         enddo
 534       enddo
 535 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 536 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 537 c      time_reduce=time_reduce+MPI_Wtime()-time00
 538 #ifdef DEBUG
 539 c      write (iout,*) "gradbufc_sum after allreduce"
 540 c      do i=1,nres
 541 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 542 c      enddo
 543 c      call flush(iout)
 544 #endif
 545 #ifdef TIMING
 546 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 547 #endif
 548       do i=nnt,nres
 549         do k=1,3
 550           gradbufc(k,i)=0.0d0
 551         enddo
 552       enddo
 553 #ifdef DEBUG
 554       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 555       write (iout,*) (i," jgrad_start",jgrad_start(i),
 556      &                  " jgrad_end  ",jgrad_end(i),
 557      &                  i=igrad_start,igrad_end)
 558 #endif
 559 c
 560 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 561 c do not parallelize this part.
 562 c
 563 c      do i=igrad_start,igrad_end
 564 c        do j=jgrad_start(i),jgrad_end(i)
 565 c          do k=1,3
 566 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 567 c          enddo
 568 c        enddo
 569 c      enddo
 570       do j=1,3
 571         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 572       enddo
 573       do i=nres-2,nnt,-1
 574         do j=1,3
 575           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 576         enddo
 577       enddo
 578 #ifdef DEBUG
 579       write (iout,*) "gradbufc after summing"
 580       do i=1,nres
 581         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 582       enddo
 583       call flush(iout)
 584 #endif
 585       else
 586 #endif
 587 #ifdef DEBUG
 588       write (iout,*) "gradbufc"
 589       do i=1,nres
 590         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 591       enddo
 592       call flush(iout)
 593 #endif
 594       do i=1,nres
 595         do j=1,3
 596           gradbufc_sum(j,i)=gradbufc(j,i)
 597           gradbufc(j,i)=0.0d0
 598         enddo
 599       enddo
 600       do j=1,3
 601         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 602       enddo
 603       do i=nres-2,nnt,-1
 604         do j=1,3
 605           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 606         enddo
 607       enddo
 608 c      do i=nnt,nres-1
 609 c        do k=1,3
 610 c          gradbufc(k,i)=0.0d0
 611 c        enddo
 612 c        do j=i+1,nres
 613 c          do k=1,3
 614 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 615 c          enddo
 616 c        enddo
 617 c      enddo
 618 #ifdef DEBUG
 619       write (iout,*) "gradbufc after summing"
 620       do i=1,nres
 621         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 622       enddo
 623       call flush(iout)
 624 #endif
 625 #ifdef MPI
 626       endif
 627 #endif
 628       do k=1,3
 629         gradbufc(k,nres)=0.0d0
 630       enddo
 631       do i=1,nct
 632         do j=1,3
 633 #ifdef SPLITELE
 634           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 635      &                wel_loc*gel_loc(j,i)+
 636      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 637      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 638      &                wel_loc*gel_loc_long(j,i)+
 639      &                wcorr*gradcorr_long(j,i)+
 640      &                wcorr5*gradcorr5_long(j,i)+
 641      &                wcorr6*gradcorr6_long(j,i)+
 642      &                wturn6*gcorr6_turn_long(j,i))+
 643      &                wbond*gradb(j,i)+
 644      &                wcorr*gradcorr(j,i)+
 645      &                wturn3*gcorr3_turn(j,i)+
 646      &                wturn4*gcorr4_turn(j,i)+
 647      &                wcorr5*gradcorr5(j,i)+
 648      &                wcorr6*gradcorr6(j,i)+
 649      &                wturn6*gcorr6_turn(j,i)+
 650      &                wsccor*gsccorc(j,i)
 651      &               +wscloc*gscloc(j,i)
 652 #else
 653           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 654      &                wel_loc*gel_loc(j,i)+
 655      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 656      &                welec*gelc_long(j,i)
 657      &                wel_loc*gel_loc_long(j,i)+
 658      &                wcorr*gcorr_long(j,i)+
 659      &                wcorr5*gradcorr5_long(j,i)+
 660      &                wcorr6*gradcorr6_long(j,i)+
 661      &                wturn6*gcorr6_turn_long(j,i))+
 662      &                wbond*gradb(j,i)+
 663      &                wcorr*gradcorr(j,i)+
 664      &                wturn3*gcorr3_turn(j,i)+
 665      &                wturn4*gcorr4_turn(j,i)+
 666      &                wcorr5*gradcorr5(j,i)+
 667      &                wcorr6*gradcorr6(j,i)+
 668      &                wturn6*gcorr6_turn(j,i)+
 669      &                wsccor*gsccorc(j,i)
 670      &               +wscloc*gscloc(j,i)
 671 #endif
 672           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 673      &                  wbond*gradbx(j,i)+
 674      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 675      &                  wsccor*gsccorx(j,i)
 676      &                 +wscloc*gsclocx(j,i)
 677         enddo
 678       enddo
 679 #ifdef DEBUG
 680       write (iout,*) "gloc before adding corr"
 681       do i=1,4*nres
 682         write (iout,*) i,gloc(i,icg)
 683       enddo
 684 #endif
 685       do i=1,nres-3
 686         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 687      &   +wcorr5*g_corr5_loc(i)
 688      &   +wcorr6*g_corr6_loc(i)
 689      &   +wturn4*gel_loc_turn4(i)
 690      &   +wturn3*gel_loc_turn3(i)
 691      &   +wturn6*gel_loc_turn6(i)
 692      &   +wel_loc*gel_loc_loc(i)
 693       enddo
 694 #ifdef DEBUG
 695       write (iout,*) "gloc after adding corr"
 696       do i=1,4*nres
 697         write (iout,*) i,gloc(i,icg)
 698       enddo
 699 #endif
 700 #ifdef MPI
 701       if (nfgtasks.gt.1) then
 702         do j=1,3
 703           do i=1,nres
 704             gradbufc(j,i)=gradc(j,i,icg)
 705             gradbufx(j,i)=gradx(j,i,icg)
 706           enddo
 707         enddo
 708         do i=1,4*nres
 709           glocbuf(i)=gloc(i,icg)
 710         enddo
 711 #define DEBUG
 712 #ifdef DEBUG
 713       write (iout,*) "gloc_sc before reduce"
 714       do i=1,nres
 715        do j=1,1
 716         write (iout,*) i,j,gloc_sc(j,i,icg)
 717        enddo
 718       enddo
 719 #endif
 720 #undef DEBUG
 721         do i=1,nres
 722          do j=1,3
 723           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 724          enddo
 725         enddo
 726         time00=MPI_Wtime()
 727         call MPI_Barrier(FG_COMM,IERR)
 728         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 729         time00=MPI_Wtime()
 730         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 731      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 732         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         time_reduce=time_reduce+MPI_Wtime()-time00
 737         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 738      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 739         time_reduce=time_reduce+MPI_Wtime()-time00
 740 #define DEBUG
 741 #ifdef DEBUG
 742       write (iout,*) "gloc_sc after reduce"
 743       do i=1,nres
 744        do j=1,1
 745         write (iout,*) i,j,gloc_sc(j,i,icg)
 746        enddo
 747       enddo
 748 #endif
 749 #undef DEBUG
 750 #ifdef DEBUG
 751       write (iout,*) "gloc after reduce"
 752       do i=1,4*nres
 753         write (iout,*) i,gloc(i,icg)
 754       enddo
 755 #endif
 756       endif
 757 #endif
 758       if (gnorm_check) then
 759 c
 760 c Compute the maximum elements of the gradient
 761 c
 762       gvdwc_max=0.0d0
 763       gvdwc_scp_max=0.0d0
 764       gelc_max=0.0d0
 765       gvdwpp_max=0.0d0
 766       gradb_max=0.0d0
 767       ghpbc_max=0.0d0
 768       gradcorr_max=0.0d0
 769       gel_loc_max=0.0d0
 770       gcorr3_turn_max=0.0d0
 771       gcorr4_turn_max=0.0d0
 772       gradcorr5_max=0.0d0
 773       gradcorr6_max=0.0d0
 774       gcorr6_turn_max=0.0d0
 775       gsccorc_max=0.0d0
 776       gscloc_max=0.0d0
 777       gvdwx_max=0.0d0
 778       gradx_scp_max=0.0d0
 779       ghpbx_max=0.0d0
 780       gradxorr_max=0.0d0
 781       gsccorx_max=0.0d0
 782       gsclocx_max=0.0d0
 783       do i=1,nct
 784         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 785         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 786         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 787         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 788      &   gvdwc_scp_max=gvdwc_scp_norm
 789         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 790         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 791         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 792         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 793         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 794         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 795         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 796         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 797         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 798         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 799         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 800         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 801         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 802      &    gcorr3_turn(1,i)))
 803         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 804      &    gcorr3_turn_max=gcorr3_turn_norm
 805         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 806      &    gcorr4_turn(1,i)))
 807         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 808      &    gcorr4_turn_max=gcorr4_turn_norm
 809         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 810         if (gradcorr5_norm.gt.gradcorr5_max)
 811      &    gradcorr5_max=gradcorr5_norm
 812         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 813         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 814         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 815      &    gcorr6_turn(1,i)))
 816         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 817      &    gcorr6_turn_max=gcorr6_turn_norm
 818         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 819         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 820         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 821         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 822         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 823         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 824         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 825         if (gradx_scp_norm.gt.gradx_scp_max)
 826      &    gradx_scp_max=gradx_scp_norm
 827         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 828         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 829         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 830         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 831         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 832         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 833         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 834         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 835       enddo
 836       if (gradout) then
 837 #ifdef AIX
 838         open(istat,file=statname,position="append")
 839 #else
 840         open(istat,file=statname,access="append")
 841 #endif
 842         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 843      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 844      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 845      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 846      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 847      &     gsccorx_max,gsclocx_max
 848         close(istat)
 849         if (gvdwc_max.gt.1.0d4) then
 850           write (iout,*) "gvdwc gvdwx gradb gradbx"
 851           do i=nnt,nct
 852             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 853      &        gradb(j,i),gradbx(j,i),j=1,3)
 854           enddo
 855           call pdbout(0.0d0,'cipiszcze',iout)
 856           call flush(iout)
 857         endif
 858       endif
 859       endif
 860 #ifdef DEBUG
 861       write (iout,*) "gradc gradx gloc"
 862       do i=1,nres
 863         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 864      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 865       enddo
 866 #endif
 867 #ifdef TIMING
 868       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 869 #endif
 870       return
 871       end
 872 c-------------------------------------------------------------------------------
 873       subroutine rescale_weights(t_bath)
 874       implicit real*8 (a-h,o-z)
 875       include 'DIMENSIONS'
 876       include 'COMMON.IOUNITS'
 877       include 'COMMON.FFIELD'
 878       include 'COMMON.SBRIDGE'
 879       double precision kfac /2.4d0/
 880       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 881 c      facT=temp0/t_bath
 882 c      facT=2*temp0/(t_bath+temp0)
 883       if (rescale_mode.eq.0) then
 884         facT=1.0d0
 885         facT2=1.0d0
 886         facT3=1.0d0
 887         facT4=1.0d0
 888         facT5=1.0d0
 889       else if (rescale_mode.eq.1) then
 890         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 891         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 892         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 893         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 894         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 895       else if (rescale_mode.eq.2) then
 896         x=t_bath/temp0
 897         x2=x*x
 898         x3=x2*x
 899         x4=x3*x
 900         x5=x4*x
 901         facT=licznik/dlog(dexp(x)+dexp(-x))
 902         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 903         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 904         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 905         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 906       else
 907         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 908         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 909 #ifdef MPI
 910        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 911 #endif
 912        stop 555
 913       endif
 914       welec=weights(3)*fact
 915       wcorr=weights(4)*fact3
 916       wcorr5=weights(5)*fact4
 917       wcorr6=weights(6)*fact5
 918       wel_loc=weights(7)*fact2
 919       wturn3=weights(8)*fact2
 920       wturn4=weights(9)*fact3
 921       wturn6=weights(10)*fact5
 922       wtor=weights(13)*fact
 923       wtor_d=weights(14)*fact2
 924       wsccor=weights(21)*fact
 925
 926       return
 927       end
 928 C------------------------------------------------------------------------
 929       subroutine enerprint(energia)
 930       implicit real*8 (a-h,o-z)
 931       include 'DIMENSIONS'
 932       include 'COMMON.IOUNITS'
 933       include 'COMMON.FFIELD'
 934       include 'COMMON.SBRIDGE'
 935       include 'COMMON.MD'
 936       double precision energia(0:n_ene)
 937       etot=energia(0)
 938       evdw=energia(1)
 939       evdw2=energia(2)
 940 #ifdef SCP14
 941       evdw2=energia(2)+energia(18)
 942 #else
 943       evdw2=energia(2)
 944 #endif
 945       ees=energia(3)
 946 #ifdef SPLITELE
 947       evdw1=energia(16)
 948 #endif
 949       ecorr=energia(4)
 950       ecorr5=energia(5)
 951       ecorr6=energia(6)
 952       eel_loc=energia(7)
 953       eello_turn3=energia(8)
 954       eello_turn4=energia(9)
 955       eello_turn6=energia(10)
 956       ebe=energia(11)
 957       escloc=energia(12)
 958       etors=energia(13)
 959       etors_d=energia(14)
 960       ehpb=energia(15)
 961       edihcnstr=energia(19)
 962       estr=energia(17)
 963       Uconst=energia(20)
 964       esccor=energia(21)
 965 #ifdef SPLITELE
 966       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 967      &  estr,wbond,ebe,wang,
 968      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 969      &  ecorr,wcorr,
 970      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 971      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 972      &  edihcnstr,ebr*nss,
 973      &  Uconst,etot
 974    10 format (/'Virtual-chain energies:'//
 975      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 976      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 977      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 978      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 979      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 980      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 981      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 982      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 983      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 984      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 985      & ' (SS bridges & dist. cnstr.)'/
 986      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 987      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 988      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 990      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 991      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 992      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 993      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 994      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 995      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 996      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 997      & 'ETOT=  ',1pE16.6,' (total)')
 998 #else
 999       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1000      &  estr,wbond,ebe,wang,
1001      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1002      &  ecorr,wcorr,
1003      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1004      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1005      &  ebr*nss,Uconst,etot
1006    10 format (/'Virtual-chain energies:'//
1007      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1008      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1009      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1010      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1011      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1012      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1013      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1014      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1015      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1016      & ' (SS bridges & dist. cnstr.)'/
1017      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1018      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1019      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1021      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1022      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1023      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1024      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1025      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1026      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1027      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1028      & 'ETOT=  ',1pE16.6,' (total)')
1029 #endif
1030       return
1031       end
1032 C-----------------------------------------------------------------------
1033       subroutine elj(evdw)
1034 C
1035 C This subroutine calculates the interaction energy of nonbonded side chains
1036 C assuming the LJ potential of interaction.
1037 C
1038       implicit real*8 (a-h,o-z)
1039       include 'DIMENSIONS'
1040       parameter (accur=1.0d-10)
1041       include 'COMMON.GEO'
1042       include 'COMMON.VAR'
1043       include 'COMMON.LOCAL'
1044       include 'COMMON.CHAIN'
1045       include 'COMMON.DERIV'
1046       include 'COMMON.INTERACT'
1047       include 'COMMON.TORSION'
1048       include 'COMMON.SBRIDGE'
1049       include 'COMMON.NAMES'
1050       include 'COMMON.IOUNITS'
1051       include 'COMMON.CONTACTS'
1052       dimension gg(3)
1053 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1054       evdw=0.0D0
1055       do i=iatsc_s,iatsc_e
1056         itypi=iabs(itype(i))
1057         if (itypi.eq.ntyp1) cycle
1058         itypi1=iabs(itype(i+1))
1059         xi=c(1,nres+i)
1060         yi=c(2,nres+i)
1061         zi=c(3,nres+i)
1062 C Change 12/1/95
1063         num_conti=0
1064 C
1065 C Calculate SC interaction energy.
1066 C
1067         do iint=1,nint_gr(i)
1068 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1069 cd   &                  'iend=',iend(i,iint)
1070           do j=istart(i,iint),iend(i,iint)
1071             itypj=iabs(itype(j))
1072             if (itypj.eq.ntyp1) cycle
1073             xj=c(1,nres+j)-xi
1074             yj=c(2,nres+j)-yi
1075             zj=c(3,nres+j)-zi
1076 C Change 12/1/95 to calculate four-body interactions
1077             rij=xj*xj+yj*yj+zj*zj
1078             rrij=1.0D0/rij
1079 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1080             eps0ij=eps(itypi,itypj)
1081             fac=rrij**expon2
1082             e1=fac*fac*aa(itypi,itypj)
1083             e2=fac*bb(itypi,itypj)
1084             evdwij=e1+e2
1085 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1086 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1087 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1088 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1089 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1090 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1091             evdw=evdw+evdwij
1092 C
1093 C Calculate the components of the gradient in DC and X
1094 C
1095             fac=-rrij*(e1+evdwij)
1096             gg(1)=xj*fac
1097             gg(2)=yj*fac
1098             gg(3)=zj*fac
1099             do k=1,3
1100               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1101               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1102               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1103               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1104             enddo
1105 cgrad            do k=i,j-1
1106 cgrad              do l=1,3
1107 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1108 cgrad              enddo
1109 cgrad            enddo
1110 C
1111 C 12/1/95, revised on 5/20/97
1112 C
1113 C Calculate the contact function. The ith column of the array JCONT will
1114 C contain the numbers of atoms that make contacts with the atom I (of numbers
1115 C greater than I). The arrays FACONT and GACONT will contain the values of
1116 C the contact function and its derivative.
1117 C
1118 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1119 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1120 C Uncomment next line, if the correlation interactions are contact function only
1121             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1122               rij=dsqrt(rij)
1123               sigij=sigma(itypi,itypj)
1124               r0ij=rs0(itypi,itypj)
1125 C
1126 C Check whether the SC's are not too far to make a contact.
1127 C
1128               rcut=1.5d0*r0ij
1129               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1130 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1131 C
1132               if (fcont.gt.0.0D0) then
1133 C If the SC-SC distance if close to sigma, apply spline.
1134 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1135 cAdam &             fcont1,fprimcont1)
1136 cAdam           fcont1=1.0d0-fcont1
1137 cAdam           if (fcont1.gt.0.0d0) then
1138 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1139 cAdam             fcont=fcont*fcont1
1140 cAdam           endif
1141 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1142 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1143 cga             do k=1,3
1144 cga               gg(k)=gg(k)*eps0ij
1145 cga             enddo
1146 cga             eps0ij=-evdwij*eps0ij
1147 C Uncomment for AL's type of SC correlation interactions.
1148 cadam           eps0ij=-evdwij
1149                 num_conti=num_conti+1
1150                 jcont(num_conti,i)=j
1151                 facont(num_conti,i)=fcont*eps0ij
1152                 fprimcont=eps0ij*fprimcont/rij
1153                 fcont=expon*fcont
1154 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1155 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1156 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1157 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1158                 gacont(1,num_conti,i)=-fprimcont*xj
1159                 gacont(2,num_conti,i)=-fprimcont*yj
1160                 gacont(3,num_conti,i)=-fprimcont*zj
1161 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1162 cd              write (iout,'(2i3,3f10.5)')
1163 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1164               endif
1165             endif
1166           enddo      ! j
1167         enddo        ! iint
1168 C Change 12/1/95
1169         num_cont(i)=num_conti
1170       enddo          ! i
1171       do i=1,nct
1172         do j=1,3
1173           gvdwc(j,i)=expon*gvdwc(j,i)
1174           gvdwx(j,i)=expon*gvdwx(j,i)
1175         enddo
1176       enddo
1177 C******************************************************************************
1178 C
1179 C                              N O T E !!!
1180 C
1181 C To save time, the factor of EXPON has been extracted from ALL components
1182 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1183 C use!
1184 C
1185 C******************************************************************************
1186       return
1187       end
1188 C-----------------------------------------------------------------------------
1189       subroutine eljk(evdw)
1190 C
1191 C This subroutine calculates the interaction energy of nonbonded side chains
1192 C assuming the LJK potential of interaction.
1193 C
1194       implicit real*8 (a-h,o-z)
1195       include 'DIMENSIONS'
1196       include 'COMMON.GEO'
1197       include 'COMMON.VAR'
1198       include 'COMMON.LOCAL'
1199       include 'COMMON.CHAIN'
1200       include 'COMMON.DERIV'
1201       include 'COMMON.INTERACT'
1202       include 'COMMON.IOUNITS'
1203       include 'COMMON.NAMES'
1204       dimension gg(3)
1205       logical scheck
1206 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1207       evdw=0.0D0
1208       do i=iatsc_s,iatsc_e
1209         itypi=iabs(itype(i))
1210         if (itypi.eq.ntyp1) cycle
1211         itypi1=iabs(itype(i+1))
1212         xi=c(1,nres+i)
1213         yi=c(2,nres+i)
1214         zi=c(3,nres+i)
1215 C
1216 C Calculate SC interaction energy.
1217 C
1218         do iint=1,nint_gr(i)
1219           do j=istart(i,iint),iend(i,iint)
1220             itypj=iabs(itype(j))
1221             if (itypj.eq.ntyp1) cycle
1222             xj=c(1,nres+j)-xi
1223             yj=c(2,nres+j)-yi
1224             zj=c(3,nres+j)-zi
1225             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1226             fac_augm=rrij**expon
1227             e_augm=augm(itypi,itypj)*fac_augm
1228             r_inv_ij=dsqrt(rrij)
1229             rij=1.0D0/r_inv_ij
1230             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1231             fac=r_shift_inv**expon
1232             e1=fac*fac*aa(itypi,itypj)
1233             e2=fac*bb(itypi,itypj)
1234             evdwij=e_augm+e1+e2
1235 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1236 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1237 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1238 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1239 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1240 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1241 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1242             evdw=evdw+evdwij
1243 C
1244 C Calculate the components of the gradient in DC and X
1245 C
1246             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1247             gg(1)=xj*fac
1248             gg(2)=yj*fac
1249             gg(3)=zj*fac
1250             do k=1,3
1251               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1252               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1253               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1254               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1255             enddo
1256 cgrad            do k=i,j-1
1257 cgrad              do l=1,3
1258 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1259 cgrad              enddo
1260 cgrad            enddo
1261           enddo      ! j
1262         enddo        ! iint
1263       enddo          ! i
1264       do i=1,nct
1265         do j=1,3
1266           gvdwc(j,i)=expon*gvdwc(j,i)
1267           gvdwx(j,i)=expon*gvdwx(j,i)
1268         enddo
1269       enddo
1270       return
1271       end
1272 C-----------------------------------------------------------------------------
1273       subroutine ebp(evdw)
1274 C
1275 C This subroutine calculates the interaction energy of nonbonded side chains
1276 C assuming the Berne-Pechukas potential of interaction.
1277 C
1278       implicit real*8 (a-h,o-z)
1279       include 'DIMENSIONS'
1280       include 'COMMON.GEO'
1281       include 'COMMON.VAR'
1282       include 'COMMON.LOCAL'
1283       include 'COMMON.CHAIN'
1284       include 'COMMON.DERIV'
1285       include 'COMMON.NAMES'
1286       include 'COMMON.INTERACT'
1287       include 'COMMON.IOUNITS'
1288       include 'COMMON.CALC'
1289       common /srutu/ icall
1290 c     double precision rrsave(maxdim)
1291       logical lprn
1292       evdw=0.0D0
1293 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1294       evdw=0.0D0
1295 c     if (icall.eq.0) then
1296 c       lprn=.true.
1297 c     else
1298         lprn=.false.
1299 c     endif
1300       ind=0
1301       do i=iatsc_s,iatsc_e
1302         itypi=iabs(itype(i))
1303         if (itypi.eq.ntyp1) cycle
1304         itypi1=iabs(itype(i+1))
1305         xi=c(1,nres+i)
1306         yi=c(2,nres+i)
1307         zi=c(3,nres+i)
1308         dxi=dc_norm(1,nres+i)
1309         dyi=dc_norm(2,nres+i)
1310         dzi=dc_norm(3,nres+i)
1311 c        dsci_inv=dsc_inv(itypi)
1312         dsci_inv=vbld_inv(i+nres)
1313 C
1314 C Calculate SC interaction energy.
1315 C
1316         do iint=1,nint_gr(i)
1317           do j=istart(i,iint),iend(i,iint)
1318             ind=ind+1
1319             itypj=iabs(itype(j))
1320             if (itypj.eq.ntyp1) cycle
1321 c            dscj_inv=dsc_inv(itypj)
1322             dscj_inv=vbld_inv(j+nres)
1323             chi1=chi(itypi,itypj)
1324             chi2=chi(itypj,itypi)
1325             chi12=chi1*chi2
1326             chip1=chip(itypi)
1327             chip2=chip(itypj)
1328             chip12=chip1*chip2
1329             alf1=alp(itypi)
1330             alf2=alp(itypj)
1331             alf12=0.5D0*(alf1+alf2)
1332 C For diagnostics only!!!
1333 c           chi1=0.0D0
1334 c           chi2=0.0D0
1335 c           chi12=0.0D0
1336 c           chip1=0.0D0
1337 c           chip2=0.0D0
1338 c           chip12=0.0D0
1339 c           alf1=0.0D0
1340 c           alf2=0.0D0
1341 c           alf12=0.0D0
1342             xj=c(1,nres+j)-xi
1343             yj=c(2,nres+j)-yi
1344             zj=c(3,nres+j)-zi
1345             dxj=dc_norm(1,nres+j)
1346             dyj=dc_norm(2,nres+j)
1347             dzj=dc_norm(3,nres+j)
1348             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1349 cd          if (icall.eq.0) then
1350 cd            rrsave(ind)=rrij
1351 cd          else
1352 cd            rrij=rrsave(ind)
1353 cd          endif
1354             rij=dsqrt(rrij)
1355 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1356             call sc_angular
1357 C Calculate whole angle-dependent part of epsilon and contributions
1358 C to its derivatives
1359             fac=(rrij*sigsq)**expon2
1360             e1=fac*fac*aa(itypi,itypj)
1361             e2=fac*bb(itypi,itypj)
1362             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1363             eps2der=evdwij*eps3rt
1364             eps3der=evdwij*eps2rt
1365             evdwij=evdwij*eps2rt*eps3rt
1366             evdw=evdw+evdwij
1367             if (lprn) then
1368             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1369             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1370 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1371 cd     &        restyp(itypi),i,restyp(itypj),j,
1372 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1373 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1374 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1375 cd     &        evdwij
1376             endif
1377 C Calculate gradient components.
1378             e1=e1*eps1*eps2rt**2*eps3rt**2
1379             fac=-expon*(e1+evdwij)
1380             sigder=fac/sigsq
1381             fac=rrij*fac
1382 C Calculate radial part of the gradient
1383             gg(1)=xj*fac
1384             gg(2)=yj*fac
1385             gg(3)=zj*fac
1386 C Calculate the angular part of the gradient and sum add the contributions
1387 C to the appropriate components of the Cartesian gradient.
1388             call sc_grad
1389           enddo      ! j
1390         enddo        ! iint
1391       enddo          ! i
1392 c     stop
1393       return
1394       end
1395 C-----------------------------------------------------------------------------
1396       subroutine egb(evdw)
1397 C
1398 C This subroutine calculates the interaction energy of nonbonded side chains
1399 C assuming the Gay-Berne potential of interaction.
1400 C
1401       implicit real*8 (a-h,o-z)
1402       include 'DIMENSIONS'
1403       include 'COMMON.GEO'
1404       include 'COMMON.VAR'
1405       include 'COMMON.LOCAL'
1406       include 'COMMON.CHAIN'
1407       include 'COMMON.DERIV'
1408       include 'COMMON.NAMES'
1409       include 'COMMON.INTERACT'
1410       include 'COMMON.IOUNITS'
1411       include 'COMMON.CALC'
1412       include 'COMMON.CONTROL'
1413       logical lprn
1414       evdw=0.0D0
1415 ccccc      energy_dec=.false.
1416 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1417       evdw=0.0D0
1418       lprn=.false.
1419 c     if (icall.eq.0) lprn=.false.
1420       ind=0
1421       do i=iatsc_s,iatsc_e
1422         itypi=iabs(itype(i))
1423         if (itypi.eq.ntyp1) cycle
1424         itypi1=iabs(itype(i+1))
1425         xi=c(1,nres+i)
1426         yi=c(2,nres+i)
1427         zi=c(3,nres+i)
1428         dxi=dc_norm(1,nres+i)
1429         dyi=dc_norm(2,nres+i)
1430         dzi=dc_norm(3,nres+i)
1431 c        dsci_inv=dsc_inv(itypi)
1432         dsci_inv=vbld_inv(i+nres)
1433 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1434 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1435 C
1436 C Calculate SC interaction energy.
1437 C
1438         do iint=1,nint_gr(i)
1439           do j=istart(i,iint),iend(i,iint)
1440             ind=ind+1
1441             itypj=iabs(itype(j))
1442             if (itypj.eq.ntyp1) cycle
1443 c            dscj_inv=dsc_inv(itypj)
1444             dscj_inv=vbld_inv(j+nres)
1445 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1446 c     &       1.0d0/vbld(j+nres)
1447 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1448             sig0ij=sigma(itypi,itypj)
1449             chi1=chi(itypi,itypj)
1450             chi2=chi(itypj,itypi)
1451             chi12=chi1*chi2
1452             chip1=chip(itypi)
1453             chip2=chip(itypj)
1454             chip12=chip1*chip2
1455             alf1=alp(itypi)
1456             alf2=alp(itypj)
1457             alf12=0.5D0*(alf1+alf2)
1458 C For diagnostics only!!!
1459 c           chi1=0.0D0
1460 c           chi2=0.0D0
1461 c           chi12=0.0D0
1462 c           chip1=0.0D0
1463 c           chip2=0.0D0
1464 c           chip12=0.0D0
1465 c           alf1=0.0D0
1466 c           alf2=0.0D0
1467 c           alf12=0.0D0
1468             xj=c(1,nres+j)-xi
1469             yj=c(2,nres+j)-yi
1470             zj=c(3,nres+j)-zi
1471             dxj=dc_norm(1,nres+j)
1472             dyj=dc_norm(2,nres+j)
1473             dzj=dc_norm(3,nres+j)
1474 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1475 c            write (iout,*) "j",j," dc_norm",
1476 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1477             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1478             rij=dsqrt(rrij)
1479 C Calculate angle-dependent terms of energy and contributions to their
1480 C derivatives.
1481             call sc_angular
1482             sigsq=1.0D0/sigsq
1483             sig=sig0ij*dsqrt(sigsq)
1484             rij_shift=1.0D0/rij-sig+sig0ij
1485 c for diagnostics; uncomment
1486 c            rij_shift=1.2*sig0ij
1487 C I hate to put IF's in the loops, but here don't have another choice!!!!
1488             if (rij_shift.le.0.0D0) then
1489               evdw=1.0D20
1490 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1491 cd     &        restyp(itypi),i,restyp(itypj),j,
1492 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1493               return
1494             endif
1495             sigder=-sig*sigsq
1496 c---------------------------------------------------------------
1497             rij_shift=1.0D0/rij_shift
1498             fac=rij_shift**expon
1499             e1=fac*fac*aa(itypi,itypj)
1500             e2=fac*bb(itypi,itypj)
1501             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1502             eps2der=evdwij*eps3rt
1503             eps3der=evdwij*eps2rt
1504 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1505 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1506             evdwij=evdwij*eps2rt*eps3rt
1507             evdw=evdw+evdwij
1508             if (lprn) then
1509             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1510             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1511             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1512      &        restyp(itypi),i,restyp(itypj),j,
1513      &        epsi,sigm,chi1,chi2,chip1,chip2,
1514      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1515      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1516      &        evdwij
1517             endif
1518
1519             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1520      &                        'evdw',i,j,evdwij
1521
1522 C Calculate gradient components.
1523             e1=e1*eps1*eps2rt**2*eps3rt**2
1524             fac=-expon*(e1+evdwij)*rij_shift
1525             sigder=fac*sigder
1526             fac=rij*fac
1527 c            fac=0.0d0
1528 C Calculate the radial part of the gradient
1529             gg(1)=xj*fac
1530             gg(2)=yj*fac
1531             gg(3)=zj*fac
1532 C Calculate angular part of the gradient.
1533             call sc_grad
1534           enddo      ! j
1535         enddo        ! iint
1536       enddo          ! i
1537 c      write (iout,*) "Number of loop steps in EGB:",ind
1538 cccc      energy_dec=.false.
1539       return
1540       end
1541 C-----------------------------------------------------------------------------
1542       subroutine egbv(evdw)
1543 C
1544 C This subroutine calculates the interaction energy of nonbonded side chains
1545 C assuming the Gay-Berne-Vorobjev potential of interaction.
1546 C
1547       implicit real*8 (a-h,o-z)
1548       include 'DIMENSIONS'
1549       include 'COMMON.GEO'
1550       include 'COMMON.VAR'
1551       include 'COMMON.LOCAL'
1552       include 'COMMON.CHAIN'
1553       include 'COMMON.DERIV'
1554       include 'COMMON.NAMES'
1555       include 'COMMON.INTERACT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.CALC'
1558       common /srutu/ icall
1559       logical lprn
1560       evdw=0.0D0
1561 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1562       evdw=0.0D0
1563       lprn=.false.
1564 c     if (icall.eq.0) lprn=.true.
1565       ind=0
1566       do i=iatsc_s,iatsc_e
1567         itypi=iabs(itype(i))
1568         if (itypi.eq.ntyp1) cycle
1569         itypi1=iabs(itype(i+1))
1570         xi=c(1,nres+i)
1571         yi=c(2,nres+i)
1572         zi=c(3,nres+i)
1573         dxi=dc_norm(1,nres+i)
1574         dyi=dc_norm(2,nres+i)
1575         dzi=dc_norm(3,nres+i)
1576 c        dsci_inv=dsc_inv(itypi)
1577         dsci_inv=vbld_inv(i+nres)
1578 C
1579 C Calculate SC interaction energy.
1580 C
1581         do iint=1,nint_gr(i)
1582           do j=istart(i,iint),iend(i,iint)
1583             ind=ind+1
1584             itypj=iabs(itype(j))
1585             if (itypj.eq.ntyp1) cycle
1586 c            dscj_inv=dsc_inv(itypj)
1587             dscj_inv=vbld_inv(j+nres)
1588             sig0ij=sigma(itypi,itypj)
1589             r0ij=r0(itypi,itypj)
1590             chi1=chi(itypi,itypj)
1591             chi2=chi(itypj,itypi)
1592             chi12=chi1*chi2
1593             chip1=chip(itypi)
1594             chip2=chip(itypj)
1595             chip12=chip1*chip2
1596             alf1=alp(itypi)
1597             alf2=alp(itypj)
1598             alf12=0.5D0*(alf1+alf2)
1599 C For diagnostics only!!!
1600 c           chi1=0.0D0
1601 c           chi2=0.0D0
1602 c           chi12=0.0D0
1603 c           chip1=0.0D0
1604 c           chip2=0.0D0
1605 c           chip12=0.0D0
1606 c           alf1=0.0D0
1607 c           alf2=0.0D0
1608 c           alf12=0.0D0
1609             xj=c(1,nres+j)-xi
1610             yj=c(2,nres+j)-yi
1611             zj=c(3,nres+j)-zi
1612             dxj=dc_norm(1,nres+j)
1613             dyj=dc_norm(2,nres+j)
1614             dzj=dc_norm(3,nres+j)
1615             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1616             rij=dsqrt(rrij)
1617 C Calculate angle-dependent terms of energy and contributions to their
1618 C derivatives.
1619             call sc_angular
1620             sigsq=1.0D0/sigsq
1621             sig=sig0ij*dsqrt(sigsq)
1622             rij_shift=1.0D0/rij-sig+r0ij
1623 C I hate to put IF's in the loops, but here don't have another choice!!!!
1624             if (rij_shift.le.0.0D0) then
1625               evdw=1.0D20
1626               return
1627             endif
1628             sigder=-sig*sigsq
1629 c---------------------------------------------------------------
1630             rij_shift=1.0D0/rij_shift
1631             fac=rij_shift**expon
1632             e1=fac*fac*aa(itypi,itypj)
1633             e2=fac*bb(itypi,itypj)
1634             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1635             eps2der=evdwij*eps3rt
1636             eps3der=evdwij*eps2rt
1637             fac_augm=rrij**expon
1638             e_augm=augm(itypi,itypj)*fac_augm
1639             evdwij=evdwij*eps2rt*eps3rt
1640             evdw=evdw+evdwij+e_augm
1641             if (lprn) then
1642             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1643             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1644             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1645      &        restyp(itypi),i,restyp(itypj),j,
1646      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1647      &        chi1,chi2,chip1,chip2,
1648      &        eps1,eps2rt**2,eps3rt**2,
1649      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1650      &        evdwij+e_augm
1651             endif
1652 C Calculate gradient components.
1653             e1=e1*eps1*eps2rt**2*eps3rt**2
1654             fac=-expon*(e1+evdwij)*rij_shift
1655             sigder=fac*sigder
1656             fac=rij*fac-2*expon*rrij*e_augm
1657 C Calculate the radial part of the gradient
1658             gg(1)=xj*fac
1659             gg(2)=yj*fac
1660             gg(3)=zj*fac
1661 C Calculate angular part of the gradient.
1662             call sc_grad
1663           enddo      ! j
1664         enddo        ! iint
1665       enddo          ! i
1666       end
1667 C-----------------------------------------------------------------------------
1668       subroutine sc_angular
1669 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1670 C om12. Called by ebp, egb, and egbv.
1671       implicit none
1672       include 'COMMON.CALC'
1673       include 'COMMON.IOUNITS'
1674       erij(1)=xj*rij
1675       erij(2)=yj*rij
1676       erij(3)=zj*rij
1677       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1678       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1679       om12=dxi*dxj+dyi*dyj+dzi*dzj
1680       chiom12=chi12*om12
1681 C Calculate eps1(om12) and its derivative in om12
1682       faceps1=1.0D0-om12*chiom12
1683       faceps1_inv=1.0D0/faceps1
1684       eps1=dsqrt(faceps1_inv)
1685 C Following variable is eps1*deps1/dom12
1686       eps1_om12=faceps1_inv*chiom12
1687 c diagnostics only
1688 c      faceps1_inv=om12
1689 c      eps1=om12
1690 c      eps1_om12=1.0d0
1691 c      write (iout,*) "om12",om12," eps1",eps1
1692 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1693 C and om12.
1694       om1om2=om1*om2
1695       chiom1=chi1*om1
1696       chiom2=chi2*om2
1697       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1698       sigsq=1.0D0-facsig*faceps1_inv
1699       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1700       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1701       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1702 c diagnostics only
1703 c      sigsq=1.0d0
1704 c      sigsq_om1=0.0d0
1705 c      sigsq_om2=0.0d0
1706 c      sigsq_om12=0.0d0
1707 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1708 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1709 c     &    " eps1",eps1
1710 C Calculate eps2 and its derivatives in om1, om2, and om12.
1711       chipom1=chip1*om1
1712       chipom2=chip2*om2
1713       chipom12=chip12*om12
1714       facp=1.0D0-om12*chipom12
1715       facp_inv=1.0D0/facp
1716       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1717 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1718 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1719 C Following variable is the square root of eps2
1720       eps2rt=1.0D0-facp1*facp_inv
1721 C Following three variables are the derivatives of the square root of eps
1722 C in om1, om2, and om12.
1723       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1724       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1725       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1726 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1727       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1728 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1729 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1730 c     &  " eps2rt_om12",eps2rt_om12
1731 C Calculate whole angle-dependent part of epsilon and contributions
1732 C to its derivatives
1733       return
1734       end
1735 C----------------------------------------------------------------------------
1736       subroutine sc_grad
1737       implicit real*8 (a-h,o-z)
1738       include 'DIMENSIONS'
1739       include 'COMMON.CHAIN'
1740       include 'COMMON.DERIV'
1741       include 'COMMON.CALC'
1742       include 'COMMON.IOUNITS'
1743       double precision dcosom1(3),dcosom2(3)
1744       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1745       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1746       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1747      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1748 c diagnostics only
1749 c      eom1=0.0d0
1750 c      eom2=0.0d0
1751 c      eom12=evdwij*eps1_om12
1752 c end diagnostics
1753 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1754 c     &  " sigder",sigder
1755 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1756 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1757       do k=1,3
1758         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1759         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1760       enddo
1761       do k=1,3
1762         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1763       enddo
1764 c      write (iout,*) "gg",(gg(k),k=1,3)
1765       do k=1,3
1766         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1767      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1768      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1769         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1770      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1771      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1772 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1773 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1774 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1775 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1776       enddo
1777 C
1778 C Calculate the components of the gradient in DC and X
1779 C
1780 cgrad      do k=i,j-1
1781 cgrad        do l=1,3
1782 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1783 cgrad        enddo
1784 cgrad      enddo
1785       do l=1,3
1786         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1787         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1788       enddo
1789       return
1790       end
1791 C-----------------------------------------------------------------------
1792       subroutine e_softsphere(evdw)
1793 C
1794 C This subroutine calculates the interaction energy of nonbonded side chains
1795 C assuming the LJ potential of interaction.
1796 C
1797       implicit real*8 (a-h,o-z)
1798       include 'DIMENSIONS'
1799       parameter (accur=1.0d-10)
1800       include 'COMMON.GEO'
1801       include 'COMMON.VAR'
1802       include 'COMMON.LOCAL'
1803       include 'COMMON.CHAIN'
1804       include 'COMMON.DERIV'
1805       include 'COMMON.INTERACT'
1806       include 'COMMON.TORSION'
1807       include 'COMMON.SBRIDGE'
1808       include 'COMMON.NAMES'
1809       include 'COMMON.IOUNITS'
1810       include 'COMMON.CONTACTS'
1811       dimension gg(3)
1812 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1813       evdw=0.0D0
1814       do i=iatsc_s,iatsc_e
1815         itypi=iabs(itype(i))
1816         if (itypi.eq.ntyp1) cycle
1817         itypi1=iabs(itype(i+1))
1818         xi=c(1,nres+i)
1819         yi=c(2,nres+i)
1820         zi=c(3,nres+i)
1821 C
1822 C Calculate SC interaction energy.
1823 C
1824         do iint=1,nint_gr(i)
1825 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1826 cd   &                  'iend=',iend(i,iint)
1827           do j=istart(i,iint),iend(i,iint)
1828             itypj=iabs(itype(j))
1829             if (itypj.eq.ntyp1) cycle
1830             xj=c(1,nres+j)-xi
1831             yj=c(2,nres+j)-yi
1832             zj=c(3,nres+j)-zi
1833             rij=xj*xj+yj*yj+zj*zj
1834 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1835             r0ij=r0(itypi,itypj)
1836             r0ijsq=r0ij*r0ij
1837 c            print *,i,j,r0ij,dsqrt(rij)
1838             if (rij.lt.r0ijsq) then
1839               evdwij=0.25d0*(rij-r0ijsq)**2
1840               fac=rij-r0ijsq
1841             else
1842               evdwij=0.0d0
1843               fac=0.0d0
1844             endif
1845             evdw=evdw+evdwij
1846 C
1847 C Calculate the components of the gradient in DC and X
1848 C
1849             gg(1)=xj*fac
1850             gg(2)=yj*fac
1851             gg(3)=zj*fac
1852             do k=1,3
1853               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1854               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1855               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1856               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1857             enddo
1858 cgrad            do k=i,j-1
1859 cgrad              do l=1,3
1860 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1861 cgrad              enddo
1862 cgrad            enddo
1863           enddo ! j
1864         enddo ! iint
1865       enddo ! i
1866       return
1867       end
1868 C--------------------------------------------------------------------------
1869       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1870      &              eello_turn4)
1871 C
1872 C Soft-sphere potential of p-p interaction
1873 C
1874       implicit real*8 (a-h,o-z)
1875       include 'DIMENSIONS'
1876       include 'COMMON.CONTROL'
1877       include 'COMMON.IOUNITS'
1878       include 'COMMON.GEO'
1879       include 'COMMON.VAR'
1880       include 'COMMON.LOCAL'
1881       include 'COMMON.CHAIN'
1882       include 'COMMON.DERIV'
1883       include 'COMMON.INTERACT'
1884       include 'COMMON.CONTACTS'
1885       include 'COMMON.TORSION'
1886       include 'COMMON.VECTORS'
1887       include 'COMMON.FFIELD'
1888       dimension ggg(3)
1889 cd      write(iout,*) 'In EELEC_soft_sphere'
1890       ees=0.0D0
1891       evdw1=0.0D0
1892       eel_loc=0.0d0
1893       eello_turn3=0.0d0
1894       eello_turn4=0.0d0
1895       ind=0
1896       do i=iatel_s,iatel_e
1897         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1898         dxi=dc(1,i)
1899         dyi=dc(2,i)
1900         dzi=dc(3,i)
1901         xmedi=c(1,i)+0.5d0*dxi
1902         ymedi=c(2,i)+0.5d0*dyi
1903         zmedi=c(3,i)+0.5d0*dzi
1904         num_conti=0
1905 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1906         do j=ielstart(i),ielend(i)
1907           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1908           ind=ind+1
1909           iteli=itel(i)
1910           itelj=itel(j)
1911           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1912           r0ij=rpp(iteli,itelj)
1913           r0ijsq=r0ij*r0ij
1914           dxj=dc(1,j)
1915           dyj=dc(2,j)
1916           dzj=dc(3,j)
1917           xj=c(1,j)+0.5D0*dxj-xmedi
1918           yj=c(2,j)+0.5D0*dyj-ymedi
1919           zj=c(3,j)+0.5D0*dzj-zmedi
1920           rij=xj*xj+yj*yj+zj*zj
1921           if (rij.lt.r0ijsq) then
1922             evdw1ij=0.25d0*(rij-r0ijsq)**2
1923             fac=rij-r0ijsq
1924           else
1925             evdw1ij=0.0d0
1926             fac=0.0d0
1927           endif
1928           evdw1=evdw1+evdw1ij
1929 C
1930 C Calculate contributions to the Cartesian gradient.
1931 C
1932           ggg(1)=fac*xj
1933           ggg(2)=fac*yj
1934           ggg(3)=fac*zj
1935           do k=1,3
1936             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1937             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1938           enddo
1939 *
1940 * Loop over residues i+1 thru j-1.
1941 *
1942 cgrad          do k=i+1,j-1
1943 cgrad            do l=1,3
1944 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1945 cgrad            enddo
1946 cgrad          enddo
1947         enddo ! j
1948       enddo   ! i
1949 cgrad      do i=nnt,nct-1
1950 cgrad        do k=1,3
1951 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1952 cgrad        enddo
1953 cgrad        do j=i+1,nct-1
1954 cgrad          do k=1,3
1955 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1956 cgrad          enddo
1957 cgrad        enddo
1958 cgrad      enddo
1959       return
1960       end
1961 c------------------------------------------------------------------------------
1962       subroutine vec_and_deriv
1963       implicit real*8 (a-h,o-z)
1964       include 'DIMENSIONS'
1965 #ifdef MPI
1966       include 'mpif.h'
1967 #endif
1968       include 'COMMON.IOUNITS'
1969       include 'COMMON.GEO'
1970       include 'COMMON.VAR'
1971       include 'COMMON.LOCAL'
1972       include 'COMMON.CHAIN'
1973       include 'COMMON.VECTORS'
1974       include 'COMMON.SETUP'
1975       include 'COMMON.TIME1'
1976       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1977 C Compute the local reference systems. For reference system (i), the
1978 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1979 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1980 #ifdef PARVEC
1981       do i=ivec_start,ivec_end
1982 #else
1983       do i=1,nres-1
1984 #endif
1985           if (i.eq.nres-1) then
1986 C Case of the last full residue
1987 C Compute the Z-axis
1988             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1989             costh=dcos(pi-theta(nres))
1990             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1991             do k=1,3
1992               uz(k,i)=fac*uz(k,i)
1993             enddo
1994 C Compute the derivatives of uz
1995             uzder(1,1,1)= 0.0d0
1996             uzder(2,1,1)=-dc_norm(3,i-1)
1997             uzder(3,1,1)= dc_norm(2,i-1)
1998             uzder(1,2,1)= dc_norm(3,i-1)
1999             uzder(2,2,1)= 0.0d0
2000             uzder(3,2,1)=-dc_norm(1,i-1)
2001             uzder(1,3,1)=-dc_norm(2,i-1)
2002             uzder(2,3,1)= dc_norm(1,i-1)
2003             uzder(3,3,1)= 0.0d0
2004             uzder(1,1,2)= 0.0d0
2005             uzder(2,1,2)= dc_norm(3,i)
2006             uzder(3,1,2)=-dc_norm(2,i)
2007             uzder(1,2,2)=-dc_norm(3,i)
2008             uzder(2,2,2)= 0.0d0
2009             uzder(3,2,2)= dc_norm(1,i)
2010             uzder(1,3,2)= dc_norm(2,i)
2011             uzder(2,3,2)=-dc_norm(1,i)
2012             uzder(3,3,2)= 0.0d0
2013 C Compute the Y-axis
2014             facy=fac
2015             do k=1,3
2016               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2017             enddo
2018 C Compute the derivatives of uy
2019             do j=1,3
2020               do k=1,3
2021                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2022      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2023                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2024               enddo
2025               uyder(j,j,1)=uyder(j,j,1)-costh
2026               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2027             enddo
2028             do j=1,2
2029               do k=1,3
2030                 do l=1,3
2031                   uygrad(l,k,j,i)=uyder(l,k,j)
2032                   uzgrad(l,k,j,i)=uzder(l,k,j)
2033                 enddo
2034               enddo
2035             enddo
2036             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2037             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2038             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2039             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2040           else
2041 C Other residues
2042 C Compute the Z-axis
2043             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2044             costh=dcos(pi-theta(i+2))
2045             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2046             do k=1,3
2047               uz(k,i)=fac*uz(k,i)
2048             enddo
2049 C Compute the derivatives of uz
2050             uzder(1,1,1)= 0.0d0
2051             uzder(2,1,1)=-dc_norm(3,i+1)
2052             uzder(3,1,1)= dc_norm(2,i+1)
2053             uzder(1,2,1)= dc_norm(3,i+1)
2054             uzder(2,2,1)= 0.0d0
2055             uzder(3,2,1)=-dc_norm(1,i+1)
2056             uzder(1,3,1)=-dc_norm(2,i+1)
2057             uzder(2,3,1)= dc_norm(1,i+1)
2058             uzder(3,3,1)= 0.0d0
2059             uzder(1,1,2)= 0.0d0
2060             uzder(2,1,2)= dc_norm(3,i)
2061             uzder(3,1,2)=-dc_norm(2,i)
2062             uzder(1,2,2)=-dc_norm(3,i)
2063             uzder(2,2,2)= 0.0d0
2064             uzder(3,2,2)= dc_norm(1,i)
2065             uzder(1,3,2)= dc_norm(2,i)
2066             uzder(2,3,2)=-dc_norm(1,i)
2067             uzder(3,3,2)= 0.0d0
2068 C Compute the Y-axis
2069             facy=fac
2070             do k=1,3
2071               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2072             enddo
2073 C Compute the derivatives of uy
2074             do j=1,3
2075               do k=1,3
2076                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2077      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2078                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2079               enddo
2080               uyder(j,j,1)=uyder(j,j,1)-costh
2081               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2082             enddo
2083             do j=1,2
2084               do k=1,3
2085                 do l=1,3
2086                   uygrad(l,k,j,i)=uyder(l,k,j)
2087                   uzgrad(l,k,j,i)=uzder(l,k,j)
2088                 enddo
2089               enddo
2090             enddo
2091             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2092             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2093             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2094             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2095           endif
2096       enddo
2097       do i=1,nres-1
2098         vbld_inv_temp(1)=vbld_inv(i+1)
2099         if (i.lt.nres-1) then
2100           vbld_inv_temp(2)=vbld_inv(i+2)
2101           else
2102           vbld_inv_temp(2)=vbld_inv(i)
2103           endif
2104         do j=1,2
2105           do k=1,3
2106             do l=1,3
2107               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2108               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2109             enddo
2110           enddo
2111         enddo
2112       enddo
2113 #if defined(PARVEC) && defined(MPI)
2114       if (nfgtasks1.gt.1) then
2115         time00=MPI_Wtime()
2116 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2117 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2118 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2119         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2120      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2121      &   FG_COMM1,IERR)
2122         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2123      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2124      &   FG_COMM1,IERR)
2125         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2126      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2127      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2128         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2129      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2130      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2131         time_gather=time_gather+MPI_Wtime()-time00
2132       endif
2133 c      if (fg_rank.eq.0) then
2134 c        write (iout,*) "Arrays UY and UZ"
2135 c        do i=1,nres-1
2136 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2137 c     &     (uz(k,i),k=1,3)
2138 c        enddo
2139 c      endif
2140 #endif
2141       return
2142       end
2143 C-----------------------------------------------------------------------------
2144       subroutine check_vecgrad
2145       implicit real*8 (a-h,o-z)
2146       include 'DIMENSIONS'
2147       include 'COMMON.IOUNITS'
2148       include 'COMMON.GEO'
2149       include 'COMMON.VAR'
2150       include 'COMMON.LOCAL'
2151       include 'COMMON.CHAIN'
2152       include 'COMMON.VECTORS'
2153       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2154       dimension uyt(3,maxres),uzt(3,maxres)
2155       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2156       double precision delta /1.0d-7/
2157       call vec_and_deriv
2158 cd      do i=1,nres
2159 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2160 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2161 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2162 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2163 cd     &     (dc_norm(if90,i),if90=1,3)
2164 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2165 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2166 cd          write(iout,'(a)')
2167 cd      enddo
2168       do i=1,nres
2169         do j=1,2
2170           do k=1,3
2171             do l=1,3
2172               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2173               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2174             enddo
2175           enddo
2176         enddo
2177       enddo
2178       call vec_and_deriv
2179       do i=1,nres
2180         do j=1,3
2181           uyt(j,i)=uy(j,i)
2182           uzt(j,i)=uz(j,i)
2183         enddo
2184       enddo
2185       do i=1,nres
2186 cd        write (iout,*) 'i=',i
2187         do k=1,3
2188           erij(k)=dc_norm(k,i)
2189         enddo
2190         do j=1,3
2191           do k=1,3
2192             dc_norm(k,i)=erij(k)
2193           enddo
2194           dc_norm(j,i)=dc_norm(j,i)+delta
2195 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2196 c          do k=1,3
2197 c            dc_norm(k,i)=dc_norm(k,i)/fac
2198 c          enddo
2199 c          write (iout,*) (dc_norm(k,i),k=1,3)
2200 c          write (iout,*) (erij(k),k=1,3)
2201           call vec_and_deriv
2202           do k=1,3
2203             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2204             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2205             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2206             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2207           enddo
2208 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2209 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2210 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2211         enddo
2212         do k=1,3
2213           dc_norm(k,i)=erij(k)
2214         enddo
2215 cd        do k=1,3
2216 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2217 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2218 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2219 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2220 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2221 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2222 cd          write (iout,'(a)')
2223 cd        enddo
2224       enddo
2225       return
2226       end
2227 C--------------------------------------------------------------------------
2228       subroutine set_matrices
2229       implicit real*8 (a-h,o-z)
2230       include 'DIMENSIONS'
2231 #ifdef MPI
2232       include "mpif.h"
2233       include "COMMON.SETUP"
2234       integer IERR
2235       integer status(MPI_STATUS_SIZE)
2236 #endif
2237       include 'COMMON.IOUNITS'
2238       include 'COMMON.GEO'
2239       include 'COMMON.VAR'
2240       include 'COMMON.LOCAL'
2241       include 'COMMON.CHAIN'
2242       include 'COMMON.DERIV'
2243       include 'COMMON.INTERACT'
2244       include 'COMMON.CONTACTS'
2245       include 'COMMON.TORSION'
2246       include 'COMMON.VECTORS'
2247       include 'COMMON.FFIELD'
2248       double precision auxvec(2),auxmat(2,2)
2249 C
2250 C Compute the virtual-bond-torsional-angle dependent quantities needed
2251 C to calculate the el-loc multibody terms of various order.
2252 C
2253 #ifdef PARMAT
2254       do i=ivec_start+2,ivec_end+2
2255 #else
2256       do i=3,nres+1
2257 #endif
2258         if (i .lt. nres+1) then
2259           sin1=dsin(phi(i))
2260           cos1=dcos(phi(i))
2261           sintab(i-2)=sin1
2262           costab(i-2)=cos1
2263           obrot(1,i-2)=cos1
2264           obrot(2,i-2)=sin1
2265           sin2=dsin(2*phi(i))
2266           cos2=dcos(2*phi(i))
2267           sintab2(i-2)=sin2
2268           costab2(i-2)=cos2
2269           obrot2(1,i-2)=cos2
2270           obrot2(2,i-2)=sin2
2271           Ug(1,1,i-2)=-cos1
2272           Ug(1,2,i-2)=-sin1
2273           Ug(2,1,i-2)=-sin1
2274           Ug(2,2,i-2)= cos1
2275           Ug2(1,1,i-2)=-cos2
2276           Ug2(1,2,i-2)=-sin2
2277           Ug2(2,1,i-2)=-sin2
2278           Ug2(2,2,i-2)= cos2
2279         else
2280           costab(i-2)=1.0d0
2281           sintab(i-2)=0.0d0
2282           obrot(1,i-2)=1.0d0
2283           obrot(2,i-2)=0.0d0
2284           obrot2(1,i-2)=0.0d0
2285           obrot2(2,i-2)=0.0d0
2286           Ug(1,1,i-2)=1.0d0
2287           Ug(1,2,i-2)=0.0d0
2288           Ug(2,1,i-2)=0.0d0
2289           Ug(2,2,i-2)=1.0d0
2290           Ug2(1,1,i-2)=0.0d0
2291           Ug2(1,2,i-2)=0.0d0
2292           Ug2(2,1,i-2)=0.0d0
2293           Ug2(2,2,i-2)=0.0d0
2294         endif
2295         if (i .gt. 3 .and. i .lt. nres+1) then
2296           obrot_der(1,i-2)=-sin1
2297           obrot_der(2,i-2)= cos1
2298           Ugder(1,1,i-2)= sin1
2299           Ugder(1,2,i-2)=-cos1
2300           Ugder(2,1,i-2)=-cos1
2301           Ugder(2,2,i-2)=-sin1
2302           dwacos2=cos2+cos2
2303           dwasin2=sin2+sin2
2304           obrot2_der(1,i-2)=-dwasin2
2305           obrot2_der(2,i-2)= dwacos2
2306           Ug2der(1,1,i-2)= dwasin2
2307           Ug2der(1,2,i-2)=-dwacos2
2308           Ug2der(2,1,i-2)=-dwacos2
2309           Ug2der(2,2,i-2)=-dwasin2
2310         else
2311           obrot_der(1,i-2)=0.0d0
2312           obrot_der(2,i-2)=0.0d0
2313           Ugder(1,1,i-2)=0.0d0
2314           Ugder(1,2,i-2)=0.0d0
2315           Ugder(2,1,i-2)=0.0d0
2316           Ugder(2,2,i-2)=0.0d0
2317           obrot2_der(1,i-2)=0.0d0
2318           obrot2_der(2,i-2)=0.0d0
2319           Ug2der(1,1,i-2)=0.0d0
2320           Ug2der(1,2,i-2)=0.0d0
2321           Ug2der(2,1,i-2)=0.0d0
2322           Ug2der(2,2,i-2)=0.0d0
2323         endif
2324 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2325         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2326           iti = itortyp(itype(i-2))
2327         else
2328           iti=ntortyp+1
2329         endif
2330 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2331         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2332           iti1 = itortyp(itype(i-1))
2333         else
2334           iti1=ntortyp+1
2335         endif
2336 cd        write (iout,*) '*******i',i,' iti1',iti
2337 cd        write (iout,*) 'b1',b1(:,iti)
2338 cd        write (iout,*) 'b2',b2(:,iti)
2339 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2340 c        if (i .gt. iatel_s+2) then
2341         if (i .gt. nnt+2) then
2342           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2343           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2344           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2345      &    then
2346           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2347           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2348           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2349           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2350           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2351           endif
2352         else
2353           do k=1,2
2354             Ub2(k,i-2)=0.0d0
2355             Ctobr(k,i-2)=0.0d0
2356             Dtobr2(k,i-2)=0.0d0
2357             do l=1,2
2358               EUg(l,k,i-2)=0.0d0
2359               CUg(l,k,i-2)=0.0d0
2360               DUg(l,k,i-2)=0.0d0
2361               DtUg2(l,k,i-2)=0.0d0
2362             enddo
2363           enddo
2364         endif
2365         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2366         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2367         do k=1,2
2368           muder(k,i-2)=Ub2der(k,i-2)
2369         enddo
2370 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2371         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2372           if (itype(i-1).le.ntyp) then
2373             iti1 = itortyp(itype(i-1))
2374           else
2375             iti1=ntortyp+1
2376           endif
2377         else
2378           iti1=ntortyp+1
2379         endif
2380         do k=1,2
2381           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2382         enddo
2383 cd        write (iout,*) 'mu ',mu(:,i-2)
2384 cd        write (iout,*) 'mu1',mu1(:,i-2)
2385 cd        write (iout,*) 'mu2',mu2(:,i-2)
2386         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2387      &  then
2388         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2389         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2390         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2391         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2392         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2393 C Vectors and matrices dependent on a single virtual-bond dihedral.
2394         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2395         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2396         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2397         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2398         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2399         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2400         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2401         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2402         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2403         endif
2404       enddo
2405 C Matrices dependent on two consecutive virtual-bond dihedrals.
2406 C The order of matrices is from left to right.
2407       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2408      &then
2409 c      do i=max0(ivec_start,2),ivec_end
2410       do i=2,nres-1
2411         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2412         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2413         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2414         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2415         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2416         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2417         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2418         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2419       enddo
2420       endif
2421 #if defined(MPI) && defined(PARMAT)
2422 #ifdef DEBUG
2423 c      if (fg_rank.eq.0) then
2424         write (iout,*) "Arrays UG and UGDER before GATHER"
2425         do i=1,nres-1
2426           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2427      &     ((ug(l,k,i),l=1,2),k=1,2),
2428      &     ((ugder(l,k,i),l=1,2),k=1,2)
2429         enddo
2430         write (iout,*) "Arrays UG2 and UG2DER"
2431         do i=1,nres-1
2432           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2433      &     ((ug2(l,k,i),l=1,2),k=1,2),
2434      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2435         enddo
2436         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2437         do i=1,nres-1
2438           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2439      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2440      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2441         enddo
2442         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2443         do i=1,nres-1
2444           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2445      &     costab(i),sintab(i),costab2(i),sintab2(i)
2446         enddo
2447         write (iout,*) "Array MUDER"
2448         do i=1,nres-1
2449           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2450         enddo
2451 c      endif
2452 #endif
2453       if (nfgtasks.gt.1) then
2454         time00=MPI_Wtime()
2455 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2456 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2457 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2458 #ifdef MATGATHER
2459         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2460      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2461      &   FG_COMM1,IERR)
2462         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2463      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2464      &   FG_COMM1,IERR)
2465         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2466      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2467      &   FG_COMM1,IERR)
2468         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2469      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2470      &   FG_COMM1,IERR)
2471         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2472      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2473      &   FG_COMM1,IERR)
2474         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2475      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2476      &   FG_COMM1,IERR)
2477         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2478      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2479      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2480         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2481      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2482      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2483         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2484      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2485      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2486         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2487      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2488      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2489         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2490      &  then
2491         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2492      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2493      &   FG_COMM1,IERR)
2494         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2495      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2496      &   FG_COMM1,IERR)
2497         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2498      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2499      &   FG_COMM1,IERR)
2500        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2501      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2502      &   FG_COMM1,IERR)
2503         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2504      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2505      &   FG_COMM1,IERR)
2506         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2507      &   ivec_count(fg_rank1),
2508      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2509      &   FG_COMM1,IERR)
2510         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2514      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2515      &   FG_COMM1,IERR)
2516         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2517      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2523      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2524      &   FG_COMM1,IERR)
2525         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2526      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2527      &   FG_COMM1,IERR)
2528         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2529      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2530      &   FG_COMM1,IERR)
2531         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2532      &   ivec_count(fg_rank1),
2533      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2534      &   FG_COMM1,IERR)
2535         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2536      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2537      &   FG_COMM1,IERR)
2538        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2539      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2540      &   FG_COMM1,IERR)
2541         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2542      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2543      &   FG_COMM1,IERR)
2544        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2545      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2548      &   ivec_count(fg_rank1),
2549      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2550      &   FG_COMM1,IERR)
2551         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2552      &   ivec_count(fg_rank1),
2553      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2556      &   ivec_count(fg_rank1),
2557      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2558      &   MPI_MAT2,FG_COMM1,IERR)
2559         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2560      &   ivec_count(fg_rank1),
2561      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2562      &   MPI_MAT2,FG_COMM1,IERR)
2563         endif
2564 #else
2565 c Passes matrix info through the ring
2566       isend=fg_rank1
2567       irecv=fg_rank1-1
2568       if (irecv.lt.0) irecv=nfgtasks1-1
2569       iprev=irecv
2570       inext=fg_rank1+1
2571       if (inext.ge.nfgtasks1) inext=0
2572       do i=1,nfgtasks1-1
2573 c        write (iout,*) "isend",isend," irecv",irecv
2574 c        call flush(iout)
2575         lensend=lentyp(isend)
2576         lenrecv=lentyp(irecv)
2577 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2578 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2579 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2580 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2581 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2582 c        write (iout,*) "Gather ROTAT1"
2583 c        call flush(iout)
2584 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2585 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2586 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2587 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2588 c        write (iout,*) "Gather ROTAT2"
2589 c        call flush(iout)
2590         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2591      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2592      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2593      &   iprev,4400+irecv,FG_COMM,status,IERR)
2594 c        write (iout,*) "Gather ROTAT_OLD"
2595 c        call flush(iout)
2596         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2597      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2598      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2599      &   iprev,5500+irecv,FG_COMM,status,IERR)
2600 c        write (iout,*) "Gather PRECOMP11"
2601 c        call flush(iout)
2602         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2603      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2604      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2605      &   iprev,6600+irecv,FG_COMM,status,IERR)
2606 c        write (iout,*) "Gather PRECOMP12"
2607 c        call flush(iout)
2608         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2609      &  then
2610         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2611      &   MPI_ROTAT2(lensend),inext,7700+isend,
2612      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2613      &   iprev,7700+irecv,FG_COMM,status,IERR)
2614 c        write (iout,*) "Gather PRECOMP21"
2615 c        call flush(iout)
2616         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2617      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2618      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2619      &   iprev,8800+irecv,FG_COMM,status,IERR)
2620 c        write (iout,*) "Gather PRECOMP22"
2621 c        call flush(iout)
2622         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2623      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2624      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2625      &   MPI_PRECOMP23(lenrecv),
2626      &   iprev,9900+irecv,FG_COMM,status,IERR)
2627 c        write (iout,*) "Gather PRECOMP23"
2628 c        call flush(iout)
2629         endif
2630         isend=irecv
2631         irecv=irecv-1
2632         if (irecv.lt.0) irecv=nfgtasks1-1
2633       enddo
2634 #endif
2635         time_gather=time_gather+MPI_Wtime()-time00
2636       endif
2637 #ifdef DEBUG
2638 c      if (fg_rank.eq.0) then
2639         write (iout,*) "Arrays UG and UGDER"
2640         do i=1,nres-1
2641           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2642      &     ((ug(l,k,i),l=1,2),k=1,2),
2643      &     ((ugder(l,k,i),l=1,2),k=1,2)
2644         enddo
2645         write (iout,*) "Arrays UG2 and UG2DER"
2646         do i=1,nres-1
2647           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2648      &     ((ug2(l,k,i),l=1,2),k=1,2),
2649      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2650         enddo
2651         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2652         do i=1,nres-1
2653           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2654      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2655      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2656         enddo
2657         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2658         do i=1,nres-1
2659           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2660      &     costab(i),sintab(i),costab2(i),sintab2(i)
2661         enddo
2662         write (iout,*) "Array MUDER"
2663         do i=1,nres-1
2664           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2665         enddo
2666 c      endif
2667 #endif
2668 #endif
2669 cd      do i=1,nres
2670 cd        iti = itortyp(itype(i))
2671 cd        write (iout,*) i
2672 cd        do j=1,2
2673 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2674 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2675 cd        enddo
2676 cd      enddo
2677       return
2678       end
2679 C--------------------------------------------------------------------------
2680       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2681 C
2682 C This subroutine calculates the average interaction energy and its gradient
2683 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2684 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2685 C The potential depends both on the distance of peptide-group centers and on
2686 C the orientation of the CA-CA virtual bonds.
2687 C
2688       implicit real*8 (a-h,o-z)
2689 #ifdef MPI
2690       include 'mpif.h'
2691 #endif
2692       include 'DIMENSIONS'
2693       include 'COMMON.CONTROL'
2694       include 'COMMON.SETUP'
2695       include 'COMMON.IOUNITS'
2696       include 'COMMON.GEO'
2697       include 'COMMON.VAR'
2698       include 'COMMON.LOCAL'
2699       include 'COMMON.CHAIN'
2700       include 'COMMON.DERIV'
2701       include 'COMMON.INTERACT'
2702       include 'COMMON.CONTACTS'
2703       include 'COMMON.TORSION'
2704       include 'COMMON.VECTORS'
2705       include 'COMMON.FFIELD'
2706       include 'COMMON.TIME1'
2707       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2708      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2709       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2710      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2711       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2712      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2713      &    num_conti,j1,j2
2714 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2715 #ifdef MOMENT
2716       double precision scal_el /1.0d0/
2717 #else
2718       double precision scal_el /0.5d0/
2719 #endif
2720 C 12/13/98
2721 C 13-go grudnia roku pamietnego...
2722       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2723      &                   0.0d0,1.0d0,0.0d0,
2724      &                   0.0d0,0.0d0,1.0d0/
2725 cd      write(iout,*) 'In EELEC'
2726 cd      do i=1,nloctyp
2727 cd        write(iout,*) 'Type',i
2728 cd        write(iout,*) 'B1',B1(:,i)
2729 cd        write(iout,*) 'B2',B2(:,i)
2730 cd        write(iout,*) 'CC',CC(:,:,i)
2731 cd        write(iout,*) 'DD',DD(:,:,i)
2732 cd        write(iout,*) 'EE',EE(:,:,i)
2733 cd      enddo
2734 cd      call check_vecgrad
2735 cd      stop
2736       if (icheckgrad.eq.1) then
2737         do i=1,nres-1
2738           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2739           do k=1,3
2740             dc_norm(k,i)=dc(k,i)*fac
2741           enddo
2742 c          write (iout,*) 'i',i,' fac',fac
2743         enddo
2744       endif
2745       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2746      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2747      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2748 c        call vec_and_deriv
2749 #ifdef TIMING
2750         time01=MPI_Wtime()
2751 #endif
2752         call set_matrices
2753 #ifdef TIMING
2754         time_mat=time_mat+MPI_Wtime()-time01
2755 #endif
2756       endif
2757 cd      do i=1,nres-1
2758 cd        write (iout,*) 'i=',i
2759 cd        do k=1,3
2760 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2761 cd        enddo
2762 cd        do k=1,3
2763 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2764 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2765 cd        enddo
2766 cd      enddo
2767       t_eelecij=0.0d0
2768       ees=0.0D0
2769       evdw1=0.0D0
2770       eel_loc=0.0d0
2771       eello_turn3=0.0d0
2772       eello_turn4=0.0d0
2773       ind=0
2774       do i=1,nres
2775         num_cont_hb(i)=0
2776       enddo
2777 cd      print '(a)','Enter EELEC'
2778 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2779       do i=1,nres
2780         gel_loc_loc(i)=0.0d0
2781         gcorr_loc(i)=0.0d0
2782       enddo
2783 c
2784 c
2785 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2786 C
2787 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2788 C
2789       do i=iturn3_start,iturn3_end
2790         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2791      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2792         dxi=dc(1,i)
2793         dyi=dc(2,i)
2794         dzi=dc(3,i)
2795         dx_normi=dc_norm(1,i)
2796         dy_normi=dc_norm(2,i)
2797         dz_normi=dc_norm(3,i)
2798         xmedi=c(1,i)+0.5d0*dxi
2799         ymedi=c(2,i)+0.5d0*dyi
2800         zmedi=c(3,i)+0.5d0*dzi
2801         num_conti=0
2802         call eelecij(i,i+2,ees,evdw1,eel_loc)
2803         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2804         num_cont_hb(i)=num_conti
2805       enddo
2806       do i=iturn4_start,iturn4_end
2807         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2808      &    .or. itype(i+3).eq.ntyp1
2809      &    .or. itype(i+4).eq.ntyp1) cycle
2810         dxi=dc(1,i)
2811         dyi=dc(2,i)
2812         dzi=dc(3,i)
2813         dx_normi=dc_norm(1,i)
2814         dy_normi=dc_norm(2,i)
2815         dz_normi=dc_norm(3,i)
2816         xmedi=c(1,i)+0.5d0*dxi
2817         ymedi=c(2,i)+0.5d0*dyi
2818         zmedi=c(3,i)+0.5d0*dzi
2819         num_conti=num_cont_hb(i)
2820         call eelecij(i,i+3,ees,evdw1,eel_loc)
2821         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2822      &   call eturn4(i,eello_turn4)
2823         num_cont_hb(i)=num_conti
2824       enddo   ! i
2825 c
2826 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2827 c
2828       do i=iatel_s,iatel_e
2829         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2830         dxi=dc(1,i)
2831         dyi=dc(2,i)
2832         dzi=dc(3,i)
2833         dx_normi=dc_norm(1,i)
2834         dy_normi=dc_norm(2,i)
2835         dz_normi=dc_norm(3,i)
2836         xmedi=c(1,i)+0.5d0*dxi
2837         ymedi=c(2,i)+0.5d0*dyi
2838         zmedi=c(3,i)+0.5d0*dzi
2839 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2840         num_conti=num_cont_hb(i)
2841         do j=ielstart(i),ielend(i)
2842 c          write (iout,*) i,j,itype(i),itype(j)
2843           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2844           call eelecij(i,j,ees,evdw1,eel_loc)
2845         enddo ! j
2846         num_cont_hb(i)=num_conti
2847       enddo   ! i
2848 c      write (iout,*) "Number of loop steps in EELEC:",ind
2849 cd      do i=1,nres
2850 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2851 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2852 cd      enddo
2853 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2854 ccc      eel_loc=eel_loc+eello_turn3
2855 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2856       return
2857       end
2858 C-------------------------------------------------------------------------------
2859       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2860       implicit real*8 (a-h,o-z)
2861       include 'DIMENSIONS'
2862 #ifdef MPI
2863       include "mpif.h"
2864 #endif
2865       include 'COMMON.CONTROL'
2866       include 'COMMON.IOUNITS'
2867       include 'COMMON.GEO'
2868       include 'COMMON.VAR'
2869       include 'COMMON.LOCAL'
2870       include 'COMMON.CHAIN'
2871       include 'COMMON.DERIV'
2872       include 'COMMON.INTERACT'
2873       include 'COMMON.CONTACTS'
2874       include 'COMMON.TORSION'
2875       include 'COMMON.VECTORS'
2876       include 'COMMON.FFIELD'
2877       include 'COMMON.TIME1'
2878       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2879      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2880       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2881      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2882       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2883      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2884      &    num_conti,j1,j2
2885 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2886 #ifdef MOMENT
2887       double precision scal_el /1.0d0/
2888 #else
2889       double precision scal_el /0.5d0/
2890 #endif
2891 C 12/13/98
2892 C 13-go grudnia roku pamietnego...
2893       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2894      &                   0.0d0,1.0d0,0.0d0,
2895      &                   0.0d0,0.0d0,1.0d0/
2896 c          time00=MPI_Wtime()
2897 cd      write (iout,*) "eelecij",i,j
2898 c          ind=ind+1
2899           iteli=itel(i)
2900           itelj=itel(j)
2901           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2902           aaa=app(iteli,itelj)
2903           bbb=bpp(iteli,itelj)
2904           ael6i=ael6(iteli,itelj)
2905           ael3i=ael3(iteli,itelj)
2906           dxj=dc(1,j)
2907           dyj=dc(2,j)
2908           dzj=dc(3,j)
2909           dx_normj=dc_norm(1,j)
2910           dy_normj=dc_norm(2,j)
2911           dz_normj=dc_norm(3,j)
2912           xj=c(1,j)+0.5D0*dxj-xmedi
2913           yj=c(2,j)+0.5D0*dyj-ymedi
2914           zj=c(3,j)+0.5D0*dzj-zmedi
2915           rij=xj*xj+yj*yj+zj*zj
2916           rrmij=1.0D0/rij
2917           rij=dsqrt(rij)
2918           rmij=1.0D0/rij
2919           r3ij=rrmij*rmij
2920           r6ij=r3ij*r3ij
2921           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2922           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2923           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2924           fac=cosa-3.0D0*cosb*cosg
2925           ev1=aaa*r6ij*r6ij
2926 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2927           if (j.eq.i+2) ev1=scal_el*ev1
2928           ev2=bbb*r6ij
2929           fac3=ael6i*r6ij
2930           fac4=ael3i*r3ij
2931           evdwij=ev1+ev2
2932           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2933           el2=fac4*fac
2934           eesij=el1+el2
2935 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2936           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2937           ees=ees+eesij
2938           evdw1=evdw1+evdwij
2939 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2940 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2941 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2942 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2943
2944           if (energy_dec) then
2945               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2946      &'evdw1',i,j,evdwij
2947      &,iteli,itelj,aaa,evdw1
2948               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2949           endif
2950
2951 C
2952 C Calculate contributions to the Cartesian gradient.
2953 C
2954 #ifdef SPLITELE
2955           facvdw=-6*rrmij*(ev1+evdwij)
2956           facel=-3*rrmij*(el1+eesij)
2957           fac1=fac
2958           erij(1)=xj*rmij
2959           erij(2)=yj*rmij
2960           erij(3)=zj*rmij
2961 *
2962 * Radial derivatives. First process both termini of the fragment (i,j)
2963 *
2964           ggg(1)=facel*xj
2965           ggg(2)=facel*yj
2966           ggg(3)=facel*zj
2967 c          do k=1,3
2968 c            ghalf=0.5D0*ggg(k)
2969 c            gelc(k,i)=gelc(k,i)+ghalf
2970 c            gelc(k,j)=gelc(k,j)+ghalf
2971 c          enddo
2972 c 9/28/08 AL Gradient compotents will be summed only at the end
2973           do k=1,3
2974             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2975             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2976           enddo
2977 *
2978 * Loop over residues i+1 thru j-1.
2979 *
2980 cgrad          do k=i+1,j-1
2981 cgrad            do l=1,3
2982 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2983 cgrad            enddo
2984 cgrad          enddo
2985           ggg(1)=facvdw*xj
2986           ggg(2)=facvdw*yj
2987           ggg(3)=facvdw*zj
2988 c          do k=1,3
2989 c            ghalf=0.5D0*ggg(k)
2990 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2991 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2992 c          enddo
2993 c 9/28/08 AL Gradient compotents will be summed only at the end
2994           do k=1,3
2995             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2996             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2997           enddo
2998 *
2999 * Loop over residues i+1 thru j-1.
3000 *
3001 cgrad          do k=i+1,j-1
3002 cgrad            do l=1,3
3003 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3004 cgrad            enddo
3005 cgrad          enddo
3006 #else
3007           facvdw=ev1+evdwij
3008           facel=el1+eesij
3009           fac1=fac
3010           fac=-3*rrmij*(facvdw+facvdw+facel)
3011           erij(1)=xj*rmij
3012           erij(2)=yj*rmij
3013           erij(3)=zj*rmij
3014 *
3015 * Radial derivatives. First process both termini of the fragment (i,j)
3016 *
3017           ggg(1)=fac*xj
3018           ggg(2)=fac*yj
3019           ggg(3)=fac*zj
3020 c          do k=1,3
3021 c            ghalf=0.5D0*ggg(k)
3022 c            gelc(k,i)=gelc(k,i)+ghalf
3023 c            gelc(k,j)=gelc(k,j)+ghalf
3024 c          enddo
3025 c 9/28/08 AL Gradient compotents will be summed only at the end
3026           do k=1,3
3027             gelc_long(k,j)=gelc(k,j)+ggg(k)
3028             gelc_long(k,i)=gelc(k,i)-ggg(k)
3029           enddo
3030 *
3031 * Loop over residues i+1 thru j-1.
3032 *
3033 cgrad          do k=i+1,j-1
3034 cgrad            do l=1,3
3035 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3036 cgrad            enddo
3037 cgrad          enddo
3038 c 9/28/08 AL Gradient compotents will be summed only at the end
3039           ggg(1)=facvdw*xj
3040           ggg(2)=facvdw*yj
3041           ggg(3)=facvdw*zj
3042           do k=1,3
3043             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3044             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3045           enddo
3046 #endif
3047 *
3048 * Angular part
3049 *
3050           ecosa=2.0D0*fac3*fac1+fac4
3051           fac4=-3.0D0*fac4
3052           fac3=-6.0D0*fac3
3053           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3054           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3055           do k=1,3
3056             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3057             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3058           enddo
3059 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3060 cd   &          (dcosg(k),k=1,3)
3061           do k=1,3
3062             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3063           enddo
3064 c          do k=1,3
3065 c            ghalf=0.5D0*ggg(k)
3066 c            gelc(k,i)=gelc(k,i)+ghalf
3067 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3068 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3069 c            gelc(k,j)=gelc(k,j)+ghalf
3070 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3071 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3072 c          enddo
3073 cgrad          do k=i+1,j-1
3074 cgrad            do l=1,3
3075 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3076 cgrad            enddo
3077 cgrad          enddo
3078           do k=1,3
3079             gelc(k,i)=gelc(k,i)
3080      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3081      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3082             gelc(k,j)=gelc(k,j)
3083      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3084      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3085             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3086             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3087           enddo
3088           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3089      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3090      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3091 C
3092 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3093 C   energy of a peptide unit is assumed in the form of a second-order
3094 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3095 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3096 C   are computed for EVERY pair of non-contiguous peptide groups.
3097 C
3098           if (j.lt.nres-1) then
3099             j1=j+1
3100             j2=j-1
3101           else
3102             j1=j-1
3103             j2=j-2
3104           endif
3105           kkk=0
3106           do k=1,2
3107             do l=1,2
3108               kkk=kkk+1
3109               muij(kkk)=mu(k,i)*mu(l,j)
3110             enddo
3111           enddo
3112 cd         write (iout,*) 'EELEC: i',i,' j',j
3113 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3114 cd          write(iout,*) 'muij',muij
3115           ury=scalar(uy(1,i),erij)
3116           urz=scalar(uz(1,i),erij)
3117           vry=scalar(uy(1,j),erij)
3118           vrz=scalar(uz(1,j),erij)
3119           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3120           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3121           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3122           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3123           fac=dsqrt(-ael6i)*r3ij
3124           a22=a22*fac
3125           a23=a23*fac
3126           a32=a32*fac
3127           a33=a33*fac
3128 cd          write (iout,'(4i5,4f10.5)')
3129 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3130 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3131 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3132 cd     &      uy(:,j),uz(:,j)
3133 cd          write (iout,'(4f10.5)')
3134 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3135 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3136 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3137 cd           write (iout,'(9f10.5/)')
3138 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3139 C Derivatives of the elements of A in virtual-bond vectors
3140           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3141           do k=1,3
3142             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3143             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3144             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3145             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3146             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3147             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3148             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3149             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3150             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3151             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3152             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3153             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3154           enddo
3155 C Compute radial contributions to the gradient
3156           facr=-3.0d0*rrmij
3157           a22der=a22*facr
3158           a23der=a23*facr
3159           a32der=a32*facr
3160           a33der=a33*facr
3161           agg(1,1)=a22der*xj
3162           agg(2,1)=a22der*yj
3163           agg(3,1)=a22der*zj
3164           agg(1,2)=a23der*xj
3165           agg(2,2)=a23der*yj
3166           agg(3,2)=a23der*zj
3167           agg(1,3)=a32der*xj
3168           agg(2,3)=a32der*yj
3169           agg(3,3)=a32der*zj
3170           agg(1,4)=a33der*xj
3171           agg(2,4)=a33der*yj
3172           agg(3,4)=a33der*zj
3173 C Add the contributions coming from er
3174           fac3=-3.0d0*fac
3175           do k=1,3
3176             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3177             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3178             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3179             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3180           enddo
3181           do k=1,3
3182 C Derivatives in DC(i)
3183 cgrad            ghalf1=0.5d0*agg(k,1)
3184 cgrad            ghalf2=0.5d0*agg(k,2)
3185 cgrad            ghalf3=0.5d0*agg(k,3)
3186 cgrad            ghalf4=0.5d0*agg(k,4)
3187             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3188      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3189             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3190      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3191             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3192      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3193             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3194      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3195 C Derivatives in DC(i+1)
3196             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3197      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3198             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3199      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3200             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3201      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3202             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3203      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3204 C Derivatives in DC(j)
3205             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3206      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3207             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3208      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3209             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3210      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3211             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3212      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3213 C Derivatives in DC(j+1) or DC(nres-1)
3214             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3215      &      -3.0d0*vryg(k,3)*ury)
3216             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3217      &      -3.0d0*vrzg(k,3)*ury)
3218             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3219      &      -3.0d0*vryg(k,3)*urz)
3220             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3221      &      -3.0d0*vrzg(k,3)*urz)
3222 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3223 cgrad              do l=1,4
3224 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3225 cgrad              enddo
3226 cgrad            endif
3227           enddo
3228           acipa(1,1)=a22
3229           acipa(1,2)=a23
3230           acipa(2,1)=a32
3231           acipa(2,2)=a33
3232           a22=-a22
3233           a23=-a23
3234           do l=1,2
3235             do k=1,3
3236               agg(k,l)=-agg(k,l)
3237               aggi(k,l)=-aggi(k,l)
3238               aggi1(k,l)=-aggi1(k,l)
3239               aggj(k,l)=-aggj(k,l)
3240               aggj1(k,l)=-aggj1(k,l)
3241             enddo
3242           enddo
3243           if (j.lt.nres-1) then
3244             a22=-a22
3245             a32=-a32
3246             do l=1,3,2
3247               do k=1,3
3248                 agg(k,l)=-agg(k,l)
3249                 aggi(k,l)=-aggi(k,l)
3250                 aggi1(k,l)=-aggi1(k,l)
3251                 aggj(k,l)=-aggj(k,l)
3252                 aggj1(k,l)=-aggj1(k,l)
3253               enddo
3254             enddo
3255           else
3256             a22=-a22
3257             a23=-a23
3258             a32=-a32
3259             a33=-a33
3260             do l=1,4
3261               do k=1,3
3262                 agg(k,l)=-agg(k,l)
3263                 aggi(k,l)=-aggi(k,l)
3264                 aggi1(k,l)=-aggi1(k,l)
3265                 aggj(k,l)=-aggj(k,l)
3266                 aggj1(k,l)=-aggj1(k,l)
3267               enddo
3268             enddo
3269           endif
3270           ENDIF ! WCORR
3271           IF (wel_loc.gt.0.0d0) THEN
3272 C Contribution to the local-electrostatic energy coming from the i-j pair
3273           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3274      &     +a33*muij(4)
3275 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3276
3277           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3278      &            'eelloc',i,j,eel_loc_ij
3279 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3280
3281           eel_loc=eel_loc+eel_loc_ij
3282 C Partial derivatives in virtual-bond dihedral angles gamma
3283           if (i.gt.1)
3284      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3285      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3286      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3287           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3288      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3289      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3290 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3291           do l=1,3
3292             ggg(l)=agg(l,1)*muij(1)+
3293      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3294             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3295             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3296 cgrad            ghalf=0.5d0*ggg(l)
3297 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3298 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3299           enddo
3300 cgrad          do k=i+1,j2
3301 cgrad            do l=1,3
3302 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3303 cgrad            enddo
3304 cgrad          enddo
3305 C Remaining derivatives of eello
3306           do l=1,3
3307             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3308      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3309             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3310      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3311             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3312      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3313             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3314      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3315           enddo
3316           ENDIF
3317 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3318 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3319           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3320      &       .and. num_conti.le.maxconts) then
3321 c            write (iout,*) i,j," entered corr"
3322 C
3323 C Calculate the contact function. The ith column of the array JCONT will
3324 C contain the numbers of atoms that make contacts with the atom I (of numbers
3325 C greater than I). The arrays FACONT and GACONT will contain the values of
3326 C the contact function and its derivative.
3327 c           r0ij=1.02D0*rpp(iteli,itelj)
3328 c           r0ij=1.11D0*rpp(iteli,itelj)
3329             r0ij=2.20D0*rpp(iteli,itelj)
3330 c           r0ij=1.55D0*rpp(iteli,itelj)
3331             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3332             if (fcont.gt.0.0D0) then
3333               num_conti=num_conti+1
3334               if (num_conti.gt.maxconts) then
3335                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3336      &                         ' will skip next contacts for this conf.'
3337               else
3338                 jcont_hb(num_conti,i)=j
3339 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3340 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3341                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3342      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3343 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3344 C  terms.
3345                 d_cont(num_conti,i)=rij
3346 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3347 C     --- Electrostatic-interaction matrix ---
3348                 a_chuj(1,1,num_conti,i)=a22
3349                 a_chuj(1,2,num_conti,i)=a23
3350                 a_chuj(2,1,num_conti,i)=a32
3351                 a_chuj(2,2,num_conti,i)=a33
3352 C     --- Gradient of rij
3353                 do kkk=1,3
3354                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3355                 enddo
3356                 kkll=0
3357                 do k=1,2
3358                   do l=1,2
3359                     kkll=kkll+1
3360                     do m=1,3
3361                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3362                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3363                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3364                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3365                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3366                     enddo
3367                   enddo
3368                 enddo
3369                 ENDIF
3370                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3371 C Calculate contact energies
3372                 cosa4=4.0D0*cosa
3373                 wij=cosa-3.0D0*cosb*cosg
3374                 cosbg1=cosb+cosg
3375                 cosbg2=cosb-cosg
3376 c               fac3=dsqrt(-ael6i)/r0ij**3
3377                 fac3=dsqrt(-ael6i)*r3ij
3378 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3379                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3380                 if (ees0tmp.gt.0) then
3381                   ees0pij=dsqrt(ees0tmp)
3382                 else
3383                   ees0pij=0
3384                 endif
3385 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3386                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3387                 if (ees0tmp.gt.0) then
3388                   ees0mij=dsqrt(ees0tmp)
3389                 else
3390                   ees0mij=0
3391                 endif
3392 c               ees0mij=0.0D0
3393                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3394                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3395 C Diagnostics. Comment out or remove after debugging!
3396 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3397 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3398 c               ees0m(num_conti,i)=0.0D0
3399 C End diagnostics.
3400 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3401 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3402 C Angular derivatives of the contact function
3403                 ees0pij1=fac3/ees0pij
3404                 ees0mij1=fac3/ees0mij
3405                 fac3p=-3.0D0*fac3*rrmij
3406                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3407                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3408 c               ees0mij1=0.0D0
3409                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3410                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3411                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3412                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3413                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3414                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3415                 ecosap=ecosa1+ecosa2
3416                 ecosbp=ecosb1+ecosb2
3417                 ecosgp=ecosg1+ecosg2
3418                 ecosam=ecosa1-ecosa2
3419                 ecosbm=ecosb1-ecosb2
3420                 ecosgm=ecosg1-ecosg2
3421 C Diagnostics
3422 c               ecosap=ecosa1
3423 c               ecosbp=ecosb1
3424 c               ecosgp=ecosg1
3425 c               ecosam=0.0D0
3426 c               ecosbm=0.0D0
3427 c               ecosgm=0.0D0
3428 C End diagnostics
3429                 facont_hb(num_conti,i)=fcont
3430                 fprimcont=fprimcont/rij
3431 cd              facont_hb(num_conti,i)=1.0D0
3432 C Following line is for diagnostics.
3433 cd              fprimcont=0.0D0
3434                 do k=1,3
3435                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3436                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3437                 enddo
3438                 do k=1,3
3439                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3440                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3441                 enddo
3442                 gggp(1)=gggp(1)+ees0pijp*xj
3443                 gggp(2)=gggp(2)+ees0pijp*yj
3444                 gggp(3)=gggp(3)+ees0pijp*zj
3445                 gggm(1)=gggm(1)+ees0mijp*xj
3446                 gggm(2)=gggm(2)+ees0mijp*yj
3447                 gggm(3)=gggm(3)+ees0mijp*zj
3448 C Derivatives due to the contact function
3449                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3450                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3451                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3452                 do k=1,3
3453 c
3454 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3455 c          following the change of gradient-summation algorithm.
3456 c
3457 cgrad                  ghalfp=0.5D0*gggp(k)
3458 cgrad                  ghalfm=0.5D0*gggm(k)
3459                   gacontp_hb1(k,num_conti,i)=!ghalfp
3460      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3461      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3462                   gacontp_hb2(k,num_conti,i)=!ghalfp
3463      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3464      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3465                   gacontp_hb3(k,num_conti,i)=gggp(k)
3466                   gacontm_hb1(k,num_conti,i)=!ghalfm
3467      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3468      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3469                   gacontm_hb2(k,num_conti,i)=!ghalfm
3470      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3471      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3472                   gacontm_hb3(k,num_conti,i)=gggm(k)
3473                 enddo
3474 C Diagnostics. Comment out or remove after debugging!
3475 cdiag           do k=1,3
3476 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3477 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3478 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3479 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3480 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3481 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3482 cdiag           enddo
3483               ENDIF ! wcorr
3484               endif  ! num_conti.le.maxconts
3485             endif  ! fcont.gt.0
3486           endif    ! j.gt.i+1
3487           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3488             do k=1,4
3489               do l=1,3
3490                 ghalf=0.5d0*agg(l,k)
3491                 aggi(l,k)=aggi(l,k)+ghalf
3492                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3493                 aggj(l,k)=aggj(l,k)+ghalf
3494               enddo
3495             enddo
3496             if (j.eq.nres-1 .and. i.lt.j-2) then
3497               do k=1,4
3498                 do l=1,3
3499                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3500                 enddo
3501               enddo
3502             endif
3503           endif
3504 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3505       return
3506       end
3507 C-----------------------------------------------------------------------------
3508       subroutine eturn3(i,eello_turn3)
3509 C Third- and fourth-order contributions from turns
3510       implicit real*8 (a-h,o-z)
3511       include 'DIMENSIONS'
3512       include 'COMMON.IOUNITS'
3513       include 'COMMON.GEO'
3514       include 'COMMON.VAR'
3515       include 'COMMON.LOCAL'
3516       include 'COMMON.CHAIN'
3517       include 'COMMON.DERIV'
3518       include 'COMMON.INTERACT'
3519       include 'COMMON.CONTACTS'
3520       include 'COMMON.TORSION'
3521       include 'COMMON.VECTORS'
3522       include 'COMMON.FFIELD'
3523       include 'COMMON.CONTROL'
3524       dimension ggg(3)
3525       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3526      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3527      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3528       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3529      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3530       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3531      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3532      &    num_conti,j1,j2
3533       j=i+2
3534 c      write (iout,*) "eturn3",i,j,j1,j2
3535       a_temp(1,1)=a22
3536       a_temp(1,2)=a23
3537       a_temp(2,1)=a32
3538       a_temp(2,2)=a33
3539 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3540 C
3541 C               Third-order contributions
3542 C
3543 C                 (i+2)o----(i+3)
3544 C                      | |
3545 C                      | |
3546 C                 (i+1)o----i
3547 C
3548 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3549 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3550         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3551         call transpose2(auxmat(1,1),auxmat1(1,1))
3552         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3553         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3554         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3555      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3556 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3557 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3558 cd     &    ' eello_turn3_num',4*eello_turn3_num
3559 C Derivatives in gamma(i)
3560         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3561         call transpose2(auxmat2(1,1),auxmat3(1,1))
3562         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3563         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3564 C Derivatives in gamma(i+1)
3565         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3566         call transpose2(auxmat2(1,1),auxmat3(1,1))
3567         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3568         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3569      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3570 C Cartesian derivatives
3571         do l=1,3
3572 c            ghalf1=0.5d0*agg(l,1)
3573 c            ghalf2=0.5d0*agg(l,2)
3574 c            ghalf3=0.5d0*agg(l,3)
3575 c            ghalf4=0.5d0*agg(l,4)
3576           a_temp(1,1)=aggi(l,1)!+ghalf1
3577           a_temp(1,2)=aggi(l,2)!+ghalf2
3578           a_temp(2,1)=aggi(l,3)!+ghalf3
3579           a_temp(2,2)=aggi(l,4)!+ghalf4
3580           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3581           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3582      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3583           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3584           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3585           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3586           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3587           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3588           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3589      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3590           a_temp(1,1)=aggj(l,1)!+ghalf1
3591           a_temp(1,2)=aggj(l,2)!+ghalf2
3592           a_temp(2,1)=aggj(l,3)!+ghalf3
3593           a_temp(2,2)=aggj(l,4)!+ghalf4
3594           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3595           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3596      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3597           a_temp(1,1)=aggj1(l,1)
3598           a_temp(1,2)=aggj1(l,2)
3599           a_temp(2,1)=aggj1(l,3)
3600           a_temp(2,2)=aggj1(l,4)
3601           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3602           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3603      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3604         enddo
3605       return
3606       end
3607 C-------------------------------------------------------------------------------
3608       subroutine eturn4(i,eello_turn4)
3609 C Third- and fourth-order contributions from turns
3610       implicit real*8 (a-h,o-z)
3611       include 'DIMENSIONS'
3612       include 'COMMON.IOUNITS'
3613       include 'COMMON.GEO'
3614       include 'COMMON.VAR'
3615       include 'COMMON.LOCAL'
3616       include 'COMMON.CHAIN'
3617       include 'COMMON.DERIV'
3618       include 'COMMON.INTERACT'
3619       include 'COMMON.CONTACTS'
3620       include 'COMMON.TORSION'
3621       include 'COMMON.VECTORS'
3622       include 'COMMON.FFIELD'
3623       include 'COMMON.CONTROL'
3624       dimension ggg(3)
3625       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3626      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3627      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3628       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3629      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3630       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3631      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3632      &    num_conti,j1,j2
3633       j=i+3
3634 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3635 C
3636 C               Fourth-order contributions
3637 C
3638 C                 (i+3)o----(i+4)
3639 C                     /  |
3640 C               (i+2)o   |
3641 C                     \  |
3642 C                 (i+1)o----i
3643 C
3644 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3645 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3646 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3647         a_temp(1,1)=a22
3648         a_temp(1,2)=a23
3649         a_temp(2,1)=a32
3650         a_temp(2,2)=a33
3651         iti1=itortyp(itype(i+1))
3652         iti2=itortyp(itype(i+2))
3653         iti3=itortyp(itype(i+3))
3654 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3655         call transpose2(EUg(1,1,i+1),e1t(1,1))
3656         call transpose2(Eug(1,1,i+2),e2t(1,1))
3657         call transpose2(Eug(1,1,i+3),e3t(1,1))
3658         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3659         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3660         s1=scalar2(b1(1,iti2),auxvec(1))
3661         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3662         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3663         s2=scalar2(b1(1,iti1),auxvec(1))
3664         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3665         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3666         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3667         eello_turn4=eello_turn4-(s1+s2+s3)
3668         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3669      &      'eturn4',i,j,-(s1+s2+s3)
3670 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3671 cd     &    ' eello_turn4_num',8*eello_turn4_num
3672 C Derivatives in gamma(i)
3673         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3674         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3675         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3676         s1=scalar2(b1(1,iti2),auxvec(1))
3677         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3678         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3679         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3680 C Derivatives in gamma(i+1)
3681         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3682         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3683         s2=scalar2(b1(1,iti1),auxvec(1))
3684         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3685         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3686         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3687         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3688 C Derivatives in gamma(i+2)
3689         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3690         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3691         s1=scalar2(b1(1,iti2),auxvec(1))
3692         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3693         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3694         s2=scalar2(b1(1,iti1),auxvec(1))
3695         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3696         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3697         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3698         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3699 C Cartesian derivatives
3700 C Derivatives of this turn contributions in DC(i+2)
3701         if (j.lt.nres-1) then
3702           do l=1,3
3703             a_temp(1,1)=agg(l,1)
3704             a_temp(1,2)=agg(l,2)
3705             a_temp(2,1)=agg(l,3)
3706             a_temp(2,2)=agg(l,4)
3707             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3708             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3709             s1=scalar2(b1(1,iti2),auxvec(1))
3710             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3711             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3712             s2=scalar2(b1(1,iti1),auxvec(1))
3713             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3714             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3715             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3716             ggg(l)=-(s1+s2+s3)
3717             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3718           enddo
3719         endif
3720 C Remaining derivatives of this turn contribution
3721         do l=1,3
3722           a_temp(1,1)=aggi(l,1)
3723           a_temp(1,2)=aggi(l,2)
3724           a_temp(2,1)=aggi(l,3)
3725           a_temp(2,2)=aggi(l,4)
3726           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3727           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3728           s1=scalar2(b1(1,iti2),auxvec(1))
3729           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3730           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3731           s2=scalar2(b1(1,iti1),auxvec(1))
3732           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3733           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3734           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3735           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3736           a_temp(1,1)=aggi1(l,1)
3737           a_temp(1,2)=aggi1(l,2)
3738           a_temp(2,1)=aggi1(l,3)
3739           a_temp(2,2)=aggi1(l,4)
3740           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3741           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3742           s1=scalar2(b1(1,iti2),auxvec(1))
3743           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3744           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3745           s2=scalar2(b1(1,iti1),auxvec(1))
3746           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3747           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3748           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3749           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3750           a_temp(1,1)=aggj(l,1)
3751           a_temp(1,2)=aggj(l,2)
3752           a_temp(2,1)=aggj(l,3)
3753           a_temp(2,2)=aggj(l,4)
3754           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3755           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3756           s1=scalar2(b1(1,iti2),auxvec(1))
3757           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3758           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3759           s2=scalar2(b1(1,iti1),auxvec(1))
3760           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3761           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3762           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3763           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3764           a_temp(1,1)=aggj1(l,1)
3765           a_temp(1,2)=aggj1(l,2)
3766           a_temp(2,1)=aggj1(l,3)
3767           a_temp(2,2)=aggj1(l,4)
3768           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3769           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3770           s1=scalar2(b1(1,iti2),auxvec(1))
3771           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3772           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3773           s2=scalar2(b1(1,iti1),auxvec(1))
3774           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3775           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3776           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3777 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3778           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3779         enddo
3780       return
3781       end
3782 C-----------------------------------------------------------------------------
3783       subroutine vecpr(u,v,w)
3784       implicit real*8(a-h,o-z)
3785       dimension u(3),v(3),w(3)
3786       w(1)=u(2)*v(3)-u(3)*v(2)
3787       w(2)=-u(1)*v(3)+u(3)*v(1)
3788       w(3)=u(1)*v(2)-u(2)*v(1)
3789       return
3790       end
3791 C-----------------------------------------------------------------------------
3792       subroutine unormderiv(u,ugrad,unorm,ungrad)
3793 C This subroutine computes the derivatives of a normalized vector u, given
3794 C the derivatives computed without normalization conditions, ugrad. Returns
3795 C ungrad.
3796       implicit none
3797       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3798       double precision vec(3)
3799       double precision scalar
3800       integer i,j
3801 c      write (2,*) 'ugrad',ugrad
3802 c      write (2,*) 'u',u
3803       do i=1,3
3804         vec(i)=scalar(ugrad(1,i),u(1))
3805       enddo
3806 c      write (2,*) 'vec',vec
3807       do i=1,3
3808         do j=1,3
3809           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3810         enddo
3811       enddo
3812 c      write (2,*) 'ungrad',ungrad
3813       return
3814       end
3815 C-----------------------------------------------------------------------------
3816       subroutine escp_soft_sphere(evdw2,evdw2_14)
3817 C
3818 C This subroutine calculates the excluded-volume interaction energy between
3819 C peptide-group centers and side chains and its gradient in virtual-bond and
3820 C side-chain vectors.
3821 C
3822       implicit real*8 (a-h,o-z)
3823       include 'DIMENSIONS'
3824       include 'COMMON.GEO'
3825       include 'COMMON.VAR'
3826       include 'COMMON.LOCAL'
3827       include 'COMMON.CHAIN'
3828       include 'COMMON.DERIV'
3829       include 'COMMON.INTERACT'
3830       include 'COMMON.FFIELD'
3831       include 'COMMON.IOUNITS'
3832       include 'COMMON.CONTROL'
3833       dimension ggg(3)
3834       evdw2=0.0D0
3835       evdw2_14=0.0d0
3836       r0_scp=4.5d0
3837 cd    print '(a)','Enter ESCP'
3838 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3839       do i=iatscp_s,iatscp_e
3840         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3841         iteli=itel(i)
3842         xi=0.5D0*(c(1,i)+c(1,i+1))
3843         yi=0.5D0*(c(2,i)+c(2,i+1))
3844         zi=0.5D0*(c(3,i)+c(3,i+1))
3845
3846         do iint=1,nscp_gr(i)
3847
3848         do j=iscpstart(i,iint),iscpend(i,iint)
3849           if (itype(j).eq.ntyp1) cycle
3850           itypj=iabs(itype(j))
3851 C Uncomment following three lines for SC-p interactions
3852 c         xj=c(1,nres+j)-xi
3853 c         yj=c(2,nres+j)-yi
3854 c         zj=c(3,nres+j)-zi
3855 C Uncomment following three lines for Ca-p interactions
3856           xj=c(1,j)-xi
3857           yj=c(2,j)-yi
3858           zj=c(3,j)-zi
3859           rij=xj*xj+yj*yj+zj*zj
3860           r0ij=r0_scp
3861           r0ijsq=r0ij*r0ij
3862           if (rij.lt.r0ijsq) then
3863             evdwij=0.25d0*(rij-r0ijsq)**2
3864             fac=rij-r0ijsq
3865           else
3866             evdwij=0.0d0
3867             fac=0.0d0
3868           endif
3869           evdw2=evdw2+evdwij
3870 C
3871 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3872 C
3873           ggg(1)=xj*fac
3874           ggg(2)=yj*fac
3875           ggg(3)=zj*fac
3876 cgrad          if (j.lt.i) then
3877 cd          write (iout,*) 'j<i'
3878 C Uncomment following three lines for SC-p interactions
3879 c           do k=1,3
3880 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3881 c           enddo
3882 cgrad          else
3883 cd          write (iout,*) 'j>i'
3884 cgrad            do k=1,3
3885 cgrad              ggg(k)=-ggg(k)
3886 C Uncomment following line for SC-p interactions
3887 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3888 cgrad            enddo
3889 cgrad          endif
3890 cgrad          do k=1,3
3891 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3892 cgrad          enddo
3893 cgrad          kstart=min0(i+1,j)
3894 cgrad          kend=max0(i-1,j-1)
3895 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3896 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3897 cgrad          do k=kstart,kend
3898 cgrad            do l=1,3
3899 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3900 cgrad            enddo
3901 cgrad          enddo
3902           do k=1,3
3903             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3904             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3905           enddo
3906         enddo
3907
3908         enddo ! iint
3909       enddo ! i
3910       return
3911       end
3912 C-----------------------------------------------------------------------------
3913       subroutine escp(evdw2,evdw2_14)
3914 C
3915 C This subroutine calculates the excluded-volume interaction energy between
3916 C peptide-group centers and side chains and its gradient in virtual-bond and
3917 C side-chain vectors.
3918 C
3919       implicit real*8 (a-h,o-z)
3920       include 'DIMENSIONS'
3921       include 'COMMON.GEO'
3922       include 'COMMON.VAR'
3923       include 'COMMON.LOCAL'
3924       include 'COMMON.CHAIN'
3925       include 'COMMON.DERIV'
3926       include 'COMMON.INTERACT'
3927       include 'COMMON.FFIELD'
3928       include 'COMMON.IOUNITS'
3929       include 'COMMON.CONTROL'
3930       dimension ggg(3)
3931       evdw2=0.0D0
3932       evdw2_14=0.0d0
3933 cd    print '(a)','Enter ESCP'
3934 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3935       do i=iatscp_s,iatscp_e
3936         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3937         iteli=itel(i)
3938         xi=0.5D0*(c(1,i)+c(1,i+1))
3939         yi=0.5D0*(c(2,i)+c(2,i+1))
3940         zi=0.5D0*(c(3,i)+c(3,i+1))
3941
3942         do iint=1,nscp_gr(i)
3943
3944         do j=iscpstart(i,iint),iscpend(i,iint)
3945           itypj=iabs(itype(j))
3946           if (itypj.eq.ntyp1) cycle
3947 C Uncomment following three lines for SC-p interactions
3948 c         xj=c(1,nres+j)-xi
3949 c         yj=c(2,nres+j)-yi
3950 c         zj=c(3,nres+j)-zi
3951 C Uncomment following three lines for Ca-p interactions
3952           xj=c(1,j)-xi
3953           yj=c(2,j)-yi
3954           zj=c(3,j)-zi
3955           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3956           fac=rrij**expon2
3957           e1=fac*fac*aad(itypj,iteli)
3958           e2=fac*bad(itypj,iteli)
3959           if (iabs(j-i) .le. 2) then
3960             e1=scal14*e1
3961             e2=scal14*e2
3962             evdw2_14=evdw2_14+e1+e2
3963           endif
3964           evdwij=e1+e2
3965           evdw2=evdw2+evdwij
3966           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3967      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3968      &       bad(itypj,iteli)
3969 C
3970 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3971 C
3972           fac=-(evdwij+e1)*rrij
3973           ggg(1)=xj*fac
3974           ggg(2)=yj*fac
3975           ggg(3)=zj*fac
3976 cgrad          if (j.lt.i) then
3977 cd          write (iout,*) 'j<i'
3978 C Uncomment following three lines for SC-p interactions
3979 c           do k=1,3
3980 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3981 c           enddo
3982 cgrad          else
3983 cd          write (iout,*) 'j>i'
3984 cgrad            do k=1,3
3985 cgrad              ggg(k)=-ggg(k)
3986 C Uncomment following line for SC-p interactions
3987 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3988 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3989 cgrad            enddo
3990 cgrad          endif
3991 cgrad          do k=1,3
3992 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3993 cgrad          enddo
3994 cgrad          kstart=min0(i+1,j)
3995 cgrad          kend=max0(i-1,j-1)
3996 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3997 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3998 cgrad          do k=kstart,kend
3999 cgrad            do l=1,3
4000 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4001 cgrad            enddo
4002 cgrad          enddo
4003           do k=1,3
4004             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4005             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4006           enddo
4007         enddo
4008
4009         enddo ! iint
4010       enddo ! i
4011       do i=1,nct
4012         do j=1,3
4013           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4014           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4015           gradx_scp(j,i)=expon*gradx_scp(j,i)
4016         enddo
4017       enddo
4018 C******************************************************************************
4019 C
4020 C                              N O T E !!!
4021 C
4022 C To save time the factor EXPON has been extracted from ALL components
4023 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4024 C use!
4025 C
4026 C******************************************************************************
4027       return
4028       end
4029 C--------------------------------------------------------------------------
4030       subroutine edis(ehpb)
4031 C
4032 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4033 C
4034       implicit real*8 (a-h,o-z)
4035       include 'DIMENSIONS'
4036       include 'COMMON.SBRIDGE'
4037       include 'COMMON.CHAIN'
4038       include 'COMMON.DERIV'
4039       include 'COMMON.VAR'
4040       include 'COMMON.INTERACT'
4041       include 'COMMON.IOUNITS'
4042       dimension ggg(3)
4043       ehpb=0.0D0
4044 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4045 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4046       if (link_end.eq.0) return
4047       do i=link_start,link_end
4048 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4049 C CA-CA distance used in regularization of structure.
4050         ii=ihpb(i)
4051         jj=jhpb(i)
4052 C iii and jjj point to the residues for which the distance is assigned.
4053         if (ii.gt.nres) then
4054           iii=ii-nres
4055           jjj=jj-nres
4056         else
4057           iii=ii
4058           jjj=jj
4059         endif
4060 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4061 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4062 C    distance and angle dependent SS bond potential.
4063         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4064      & iabs(itype(jjj)).eq.1) then
4065           call ssbond_ene(iii,jjj,eij)
4066           ehpb=ehpb+2*eij
4067 cd          write (iout,*) "eij",eij
4068         else
4069 C Calculate the distance between the two points and its difference from the
4070 C target distance.
4071         dd=dist(ii,jj)
4072         rdis=dd-dhpb(i)
4073 C Get the force constant corresponding to this distance.
4074         waga=forcon(i)
4075 C Calculate the contribution to energy.
4076         ehpb=ehpb+waga*rdis*rdis
4077 C
4078 C Evaluate gradient.
4079 C
4080         fac=waga*rdis/dd
4081 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4082 cd   &   ' waga=',waga,' fac=',fac
4083         do j=1,3
4084           ggg(j)=fac*(c(j,jj)-c(j,ii))
4085         enddo
4086 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4087 C If this is a SC-SC distance, we need to calculate the contributions to the
4088 C Cartesian gradient in the SC vectors (ghpbx).
4089         if (iii.lt.ii) then
4090           do j=1,3
4091             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4092             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4093           enddo
4094         endif
4095 cgrad        do j=iii,jjj-1
4096 cgrad          do k=1,3
4097 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4098 cgrad          enddo
4099 cgrad        enddo
4100         do k=1,3
4101           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4102           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4103         enddo
4104         endif
4105       enddo
4106       ehpb=0.5D0*ehpb
4107       return
4108       end
4109 C--------------------------------------------------------------------------
4110       subroutine ssbond_ene(i,j,eij)
4111 C
4112 C Calculate the distance and angle dependent SS-bond potential energy
4113 C using a free-energy function derived based on RHF/6-31G** ab initio
4114 C calculations of diethyl disulfide.
4115 C
4116 C A. Liwo and U. Kozlowska, 11/24/03
4117 C
4118       implicit real*8 (a-h,o-z)
4119       include 'DIMENSIONS'
4120       include 'COMMON.SBRIDGE'
4121       include 'COMMON.CHAIN'
4122       include 'COMMON.DERIV'
4123       include 'COMMON.LOCAL'
4124       include 'COMMON.INTERACT'
4125       include 'COMMON.VAR'
4126       include 'COMMON.IOUNITS'
4127       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4128       itypi=iabs(itype(i))
4129       xi=c(1,nres+i)
4130       yi=c(2,nres+i)
4131       zi=c(3,nres+i)
4132       dxi=dc_norm(1,nres+i)
4133       dyi=dc_norm(2,nres+i)
4134       dzi=dc_norm(3,nres+i)
4135 c      dsci_inv=dsc_inv(itypi)
4136       dsci_inv=vbld_inv(nres+i)
4137       itypj=iabs(itype(j))
4138 c      dscj_inv=dsc_inv(itypj)
4139       dscj_inv=vbld_inv(nres+j)
4140       xj=c(1,nres+j)-xi
4141       yj=c(2,nres+j)-yi
4142       zj=c(3,nres+j)-zi
4143       dxj=dc_norm(1,nres+j)
4144       dyj=dc_norm(2,nres+j)
4145       dzj=dc_norm(3,nres+j)
4146       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4147       rij=dsqrt(rrij)
4148       erij(1)=xj*rij
4149       erij(2)=yj*rij
4150       erij(3)=zj*rij
4151       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4152       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4153       om12=dxi*dxj+dyi*dyj+dzi*dzj
4154       do k=1,3
4155         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4156         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4157       enddo
4158       rij=1.0d0/rij
4159       deltad=rij-d0cm
4160       deltat1=1.0d0-om1
4161       deltat2=1.0d0+om2
4162       deltat12=om2-om1+2.0d0
4163       cosphi=om12-om1*om2
4164       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4165      &  +akct*deltad*deltat12
4166      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4167 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4168 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4169 c     &  " deltat12",deltat12," eij",eij
4170       ed=2*akcm*deltad+akct*deltat12
4171       pom1=akct*deltad
4172       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4173       eom1=-2*akth*deltat1-pom1-om2*pom2
4174       eom2= 2*akth*deltat2+pom1-om1*pom2
4175       eom12=pom2
4176       do k=1,3
4177         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4178         ghpbx(k,i)=ghpbx(k,i)-ggk
4179      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4180      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4181         ghpbx(k,j)=ghpbx(k,j)+ggk
4182      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4183      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4184         ghpbc(k,i)=ghpbc(k,i)-ggk
4185         ghpbc(k,j)=ghpbc(k,j)+ggk
4186       enddo
4187 C
4188 C Calculate the components of the gradient in DC and X
4189 C
4190 cgrad      do k=i,j-1
4191 cgrad        do l=1,3
4192 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4193 cgrad        enddo
4194 cgrad      enddo
4195       return
4196       end
4197 C--------------------------------------------------------------------------
4198       subroutine ebond(estr)
4199 c
4200 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4201 c
4202       implicit real*8 (a-h,o-z)
4203       include 'DIMENSIONS'
4204       include 'COMMON.LOCAL'
4205       include 'COMMON.GEO'
4206       include 'COMMON.INTERACT'
4207       include 'COMMON.DERIV'
4208       include 'COMMON.VAR'
4209       include 'COMMON.CHAIN'
4210       include 'COMMON.IOUNITS'
4211       include 'COMMON.NAMES'
4212       include 'COMMON.FFIELD'
4213       include 'COMMON.CONTROL'
4214       include 'COMMON.SETUP'
4215       double precision u(3),ud(3)
4216       estr=0.0d0
4217       estr1=0.0d0
4218       do i=ibondp_start,ibondp_end
4219         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4220           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4221           do j=1,3
4222           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4223      &      *dc(j,i-1)/vbld(i)
4224           enddo
4225           if (energy_dec) write(iout,*)
4226      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4227         else
4228         diff = vbld(i)-vbldp0
4229         if (energy_dec) write (iout,*)
4230      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4231         estr=estr+diff*diff
4232         do j=1,3
4233           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4234         enddo
4235 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4236         endif
4237       enddo
4238       estr=0.5d0*AKP*estr+estr1
4239 c
4240 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4241 c
4242       do i=ibond_start,ibond_end
4243         iti=iabs(itype(i))
4244         if (iti.ne.10 .and. iti.ne.ntyp1) then
4245           nbi=nbondterm(iti)
4246           if (nbi.eq.1) then
4247             diff=vbld(i+nres)-vbldsc0(1,iti)
4248             if (energy_dec) write (iout,*)
4249      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4250      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4251             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4252             do j=1,3
4253               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4254             enddo
4255           else
4256             do j=1,nbi
4257               diff=vbld(i+nres)-vbldsc0(j,iti)
4258               ud(j)=aksc(j,iti)*diff
4259               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4260             enddo
4261             uprod=u(1)
4262             do j=2,nbi
4263               uprod=uprod*u(j)
4264             enddo
4265             usum=0.0d0
4266             usumsqder=0.0d0
4267             do j=1,nbi
4268               uprod1=1.0d0
4269               uprod2=1.0d0
4270               do k=1,nbi
4271                 if (k.ne.j) then
4272                   uprod1=uprod1*u(k)
4273                   uprod2=uprod2*u(k)*u(k)
4274                 endif
4275               enddo
4276               usum=usum+uprod1
4277               usumsqder=usumsqder+ud(j)*uprod2
4278             enddo
4279             estr=estr+uprod/usum
4280             do j=1,3
4281              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4282             enddo
4283           endif
4284         endif
4285       enddo
4286       return
4287       end
4288 #ifdef CRYST_THETA
4289 C--------------------------------------------------------------------------
4290       subroutine ebend(etheta)
4291 C
4292 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4293 C angles gamma and its derivatives in consecutive thetas and gammas.
4294 C
4295       implicit real*8 (a-h,o-z)
4296       include 'DIMENSIONS'
4297       include 'COMMON.LOCAL'
4298       include 'COMMON.GEO'
4299       include 'COMMON.INTERACT'
4300       include 'COMMON.DERIV'
4301       include 'COMMON.VAR'
4302       include 'COMMON.CHAIN'
4303       include 'COMMON.IOUNITS'
4304       include 'COMMON.NAMES'
4305       include 'COMMON.FFIELD'
4306       include 'COMMON.CONTROL'
4307       common /calcthet/ term1,term2,termm,diffak,ratak,
4308      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4309      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4310       double precision y(2),z(2)
4311       delta=0.02d0*pi
4312 c      time11=dexp(-2*time)
4313 c      time12=1.0d0
4314       etheta=0.0D0
4315 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4316       do i=ithet_start,ithet_end
4317         if (itype(i-1).eq.ntyp1) cycle
4318 C Zero the energy function and its derivative at 0 or pi.
4319         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4320         it=itype(i-1)
4321         ichir1=isign(1,itype(i-2))
4322         ichir2=isign(1,itype(i))
4323          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4324          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4325          if (itype(i-1).eq.10) then
4326           itype1=isign(10,itype(i-2))
4327           ichir11=isign(1,itype(i-2))
4328           ichir12=isign(1,itype(i-2))
4329           itype2=isign(10,itype(i))
4330           ichir21=isign(1,itype(i))
4331           ichir22=isign(1,itype(i))
4332          endif
4333
4334         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4335 #ifdef OSF
4336           phii=phi(i)
4337           if (phii.ne.phii) phii=150.0
4338 #else
4339           phii=phi(i)
4340 #endif
4341           y(1)=dcos(phii)
4342           y(2)=dsin(phii)
4343         else
4344           y(1)=0.0D0
4345           y(2)=0.0D0
4346         endif
4347         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4348 #ifdef OSF
4349           phii1=phi(i+1)
4350           if (phii1.ne.phii1) phii1=150.0
4351           phii1=pinorm(phii1)
4352           z(1)=cos(phii1)
4353 #else
4354           phii1=phi(i+1)
4355           z(1)=dcos(phii1)
4356 #endif
4357           z(2)=dsin(phii1)
4358         else
4359           z(1)=0.0D0
4360           z(2)=0.0D0
4361         endif
4362 C Calculate the "mean" value of theta from the part of the distribution
4363 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4364 C In following comments this theta will be referred to as t_c.
4365         thet_pred_mean=0.0d0
4366         do k=1,2
4367             athetk=athet(k,it,ichir1,ichir2)
4368             bthetk=bthet(k,it,ichir1,ichir2)
4369           if (it.eq.10) then
4370              athetk=athet(k,itype1,ichir11,ichir12)
4371              bthetk=bthet(k,itype2,ichir21,ichir22)
4372           endif
4373          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4374         enddo
4375         dthett=thet_pred_mean*ssd
4376         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4377 C Derivatives of the "mean" values in gamma1 and gamma2.
4378         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4379      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4380          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4381      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4382          if (it.eq.10) then
4383       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4384      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4385         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4386      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4387          endif
4388         if (theta(i).gt.pi-delta) then
4389           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4390      &         E_tc0)
4391           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4392           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4393           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4394      &        E_theta)
4395           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4396      &        E_tc)
4397         else if (theta(i).lt.delta) then
4398           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4399           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4400           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4401      &        E_theta)
4402           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4403           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4404      &        E_tc)
4405         else
4406           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4407      &        E_theta,E_tc)
4408         endif
4409         etheta=etheta+ethetai
4410         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4411      &      'ebend',i,ethetai
4412         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4413         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4414         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4415       enddo
4416 C Ufff.... We've done all this!!!
4417       return
4418       end
4419 C---------------------------------------------------------------------------
4420       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4421      &     E_tc)
4422       implicit real*8 (a-h,o-z)
4423       include 'DIMENSIONS'
4424       include 'COMMON.LOCAL'
4425       include 'COMMON.IOUNITS'
4426       common /calcthet/ term1,term2,termm,diffak,ratak,
4427      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4428      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4429 C Calculate the contributions to both Gaussian lobes.
4430 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4431 C The "polynomial part" of the "standard deviation" of this part of
4432 C the distribution.
4433         sig=polthet(3,it)
4434         do j=2,0,-1
4435           sig=sig*thet_pred_mean+polthet(j,it)
4436         enddo
4437 C Derivative of the "interior part" of the "standard deviation of the"
4438 C gamma-dependent Gaussian lobe in t_c.
4439         sigtc=3*polthet(3,it)
4440         do j=2,1,-1
4441           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4442         enddo
4443         sigtc=sig*sigtc
4444 C Set the parameters of both Gaussian lobes of the distribution.
4445 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4446         fac=sig*sig+sigc0(it)
4447         sigcsq=fac+fac
4448         sigc=1.0D0/sigcsq
4449 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4450         sigsqtc=-4.0D0*sigcsq*sigtc
4451 c       print *,i,sig,sigtc,sigsqtc
4452 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4453         sigtc=-sigtc/(fac*fac)
4454 C Following variable is sigma(t_c)**(-2)
4455         sigcsq=sigcsq*sigcsq
4456         sig0i=sig0(it)
4457         sig0inv=1.0D0/sig0i**2
4458         delthec=thetai-thet_pred_mean
4459         delthe0=thetai-theta0i
4460         term1=-0.5D0*sigcsq*delthec*delthec
4461         term2=-0.5D0*sig0inv*delthe0*delthe0
4462 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4463 C NaNs in taking the logarithm. We extract the largest exponent which is added
4464 C to the energy (this being the log of the distribution) at the end of energy
4465 C term evaluation for this virtual-bond angle.
4466         if (term1.gt.term2) then
4467           termm=term1
4468           term2=dexp(term2-termm)
4469           term1=1.0d0
4470         else
4471           termm=term2
4472           term1=dexp(term1-termm)
4473           term2=1.0d0
4474         endif
4475 C The ratio between the gamma-independent and gamma-dependent lobes of
4476 C the distribution is a Gaussian function of thet_pred_mean too.
4477         diffak=gthet(2,it)-thet_pred_mean
4478         ratak=diffak/gthet(3,it)**2
4479         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4480 C Let's differentiate it in thet_pred_mean NOW.
4481         aktc=ak*ratak
4482 C Now put together the distribution terms to make complete distribution.
4483         termexp=term1+ak*term2
4484         termpre=sigc+ak*sig0i
4485 C Contribution of the bending energy from this theta is just the -log of
4486 C the sum of the contributions from the two lobes and the pre-exponential
4487 C factor. Simple enough, isn't it?
4488         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4489 C NOW the derivatives!!!
4490 C 6/6/97 Take into account the deformation.
4491         E_theta=(delthec*sigcsq*term1
4492      &       +ak*delthe0*sig0inv*term2)/termexp
4493         E_tc=((sigtc+aktc*sig0i)/termpre
4494      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4495      &       aktc*term2)/termexp)
4496       return
4497       end
4498 c-----------------------------------------------------------------------------
4499       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4500       implicit real*8 (a-h,o-z)
4501       include 'DIMENSIONS'
4502       include 'COMMON.LOCAL'
4503       include 'COMMON.IOUNITS'
4504       common /calcthet/ term1,term2,termm,diffak,ratak,
4505      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4506      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4507       delthec=thetai-thet_pred_mean
4508       delthe0=thetai-theta0i
4509 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4510       t3 = thetai-thet_pred_mean
4511       t6 = t3**2
4512       t9 = term1
4513       t12 = t3*sigcsq
4514       t14 = t12+t6*sigsqtc
4515       t16 = 1.0d0
4516       t21 = thetai-theta0i
4517       t23 = t21**2
4518       t26 = term2
4519       t27 = t21*t26
4520       t32 = termexp
4521       t40 = t32**2
4522       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4523      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4524      & *(-t12*t9-ak*sig0inv*t27)
4525       return
4526       end
4527 #else
4528 C--------------------------------------------------------------------------
4529       subroutine ebend(etheta)
4530 C
4531 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4532 C angles gamma and its derivatives in consecutive thetas and gammas.
4533 C ab initio-derived potentials from
4534 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4535 C
4536       implicit real*8 (a-h,o-z)
4537       include 'DIMENSIONS'
4538       include 'COMMON.LOCAL'
4539       include 'COMMON.GEO'
4540       include 'COMMON.INTERACT'
4541       include 'COMMON.DERIV'
4542       include 'COMMON.VAR'
4543       include 'COMMON.CHAIN'
4544       include 'COMMON.IOUNITS'
4545       include 'COMMON.NAMES'
4546       include 'COMMON.FFIELD'
4547       include 'COMMON.CONTROL'
4548       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4549      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4550      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4551      & sinph1ph2(maxdouble,maxdouble)
4552       logical lprn /.false./, lprn1 /.false./
4553       etheta=0.0D0
4554       do i=ithet_start,ithet_end
4555         if (itype(i-1).eq.ntyp1) cycle
4556         if (iabs(itype(i+1)).eq.20) iblock=2
4557         if (iabs(itype(i+1)).ne.20) iblock=1
4558         dethetai=0.0d0
4559         dephii=0.0d0
4560         dephii1=0.0d0
4561         theti2=0.5d0*theta(i)
4562         ityp2=ithetyp((itype(i-1)))
4563         do k=1,nntheterm
4564           coskt(k)=dcos(k*theti2)
4565           sinkt(k)=dsin(k*theti2)
4566         enddo
4567         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4568 #ifdef OSF
4569           phii=phi(i)
4570           if (phii.ne.phii) phii=150.0
4571 #else
4572           phii=phi(i)
4573 #endif
4574           ityp1=ithetyp((itype(i-2)))
4575 C propagation of chirality for glycine type
4576           do k=1,nsingle
4577             cosph1(k)=dcos(k*phii)
4578             sinph1(k)=dsin(k*phii)
4579           enddo
4580         else
4581           phii=0.0d0
4582           ityp1=nthetyp+1
4583           do k=1,nsingle
4584             cosph1(k)=0.0d0
4585             sinph1(k)=0.0d0
4586           enddo
4587         endif
4588         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4589 #ifdef OSF
4590           phii1=phi(i+1)
4591           if (phii1.ne.phii1) phii1=150.0
4592           phii1=pinorm(phii1)
4593 #else
4594           phii1=phi(i+1)
4595 #endif
4596           ityp3=ithetyp((itype(i)))
4597           do k=1,nsingle
4598             cosph2(k)=dcos(k*phii1)
4599             sinph2(k)=dsin(k*phii1)
4600           enddo
4601         else
4602           phii1=0.0d0
4603           ityp3=nthetyp+1
4604           do k=1,nsingle
4605             cosph2(k)=0.0d0
4606             sinph2(k)=0.0d0
4607           enddo
4608         endif
4609         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4610         do k=1,ndouble
4611           do l=1,k-1
4612             ccl=cosph1(l)*cosph2(k-l)
4613             ssl=sinph1(l)*sinph2(k-l)
4614             scl=sinph1(l)*cosph2(k-l)
4615             csl=cosph1(l)*sinph2(k-l)
4616             cosph1ph2(l,k)=ccl-ssl
4617             cosph1ph2(k,l)=ccl+ssl
4618             sinph1ph2(l,k)=scl+csl
4619             sinph1ph2(k,l)=scl-csl
4620           enddo
4621         enddo
4622         if (lprn) then
4623         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4624      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4625         write (iout,*) "coskt and sinkt"
4626         do k=1,nntheterm
4627           write (iout,*) k,coskt(k),sinkt(k)
4628         enddo
4629         endif
4630         do k=1,ntheterm
4631           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4632           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4633      &      *coskt(k)
4634           if (lprn)
4635      &    write (iout,*) "k",k,"
4636      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4637      &     " ethetai",ethetai
4638         enddo
4639         if (lprn) then
4640         write (iout,*) "cosph and sinph"
4641         do k=1,nsingle
4642           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4643         enddo
4644         write (iout,*) "cosph1ph2 and sinph2ph2"
4645         do k=2,ndouble
4646           do l=1,k-1
4647             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4648      &         sinph1ph2(l,k),sinph1ph2(k,l)
4649           enddo
4650         enddo
4651         write(iout,*) "ethetai",ethetai
4652         endif
4653         do m=1,ntheterm2
4654           do k=1,nsingle
4655             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4656      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4657      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4658      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4659             ethetai=ethetai+sinkt(m)*aux
4660             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4661             dephii=dephii+k*sinkt(m)*(
4662      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4663      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4664             dephii1=dephii1+k*sinkt(m)*(
4665      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4666      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4667             if (lprn)
4668      &      write (iout,*) "m",m," k",k," bbthet",
4669      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4670      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4671      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4672      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4673           enddo
4674         enddo
4675         if (lprn)
4676      &  write(iout,*) "ethetai",ethetai
4677         do m=1,ntheterm3
4678           do k=2,ndouble
4679             do l=1,k-1
4680               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4681      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4682      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4683      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4684               ethetai=ethetai+sinkt(m)*aux
4685               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4686               dephii=dephii+l*sinkt(m)*(
4687      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4688      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4689      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4690      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4691               dephii1=dephii1+(k-l)*sinkt(m)*(
4692      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4693      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4694      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4695      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4696               if (lprn) then
4697               write (iout,*) "m",m," k",k," l",l," ffthet",
4698      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4699      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4700      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4701      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4702      &            " ethetai",ethetai
4703               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4704      &            cosph1ph2(k,l)*sinkt(m),
4705      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4706               endif
4707             enddo
4708           enddo
4709         enddo
4710 10      continue
4711 c        lprn1=.true.
4712         if (lprn1)
4713      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4714      &   i,theta(i)*rad2deg,phii*rad2deg,
4715      &   phii1*rad2deg,ethetai
4716 c        lprn1=.false.
4717         etheta=etheta+ethetai
4718         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4719         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4720         gloc(nphi+i-2,icg)=wang*dethetai
4721       enddo
4722       return
4723       end
4724 #endif
4725 #ifdef CRYST_SC
4726 c-----------------------------------------------------------------------------
4727       subroutine esc(escloc)
4728 C Calculate the local energy of a side chain and its derivatives in the
4729 C corresponding virtual-bond valence angles THETA and the spherical angles
4730 C ALPHA and OMEGA.
4731       implicit real*8 (a-h,o-z)
4732       include 'DIMENSIONS'
4733       include 'COMMON.GEO'
4734       include 'COMMON.LOCAL'
4735       include 'COMMON.VAR'
4736       include 'COMMON.INTERACT'
4737       include 'COMMON.DERIV'
4738       include 'COMMON.CHAIN'
4739       include 'COMMON.IOUNITS'
4740       include 'COMMON.NAMES'
4741       include 'COMMON.FFIELD'
4742       include 'COMMON.CONTROL'
4743       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4744      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4745       common /sccalc/ time11,time12,time112,theti,it,nlobit
4746       delta=0.02d0*pi
4747       escloc=0.0D0
4748 c     write (iout,'(a)') 'ESC'
4749       do i=loc_start,loc_end
4750         it=itype(i)
4751         if (it.eq.ntyp1) cycle
4752         if (it.eq.10) goto 1
4753         nlobit=nlob(iabs(it))
4754 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4755 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4756         theti=theta(i+1)-pipol
4757         x(1)=dtan(theti)
4758         x(2)=alph(i)
4759         x(3)=omeg(i)
4760
4761         if (x(2).gt.pi-delta) then
4762           xtemp(1)=x(1)
4763           xtemp(2)=pi-delta
4764           xtemp(3)=x(3)
4765           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4766           xtemp(2)=pi
4767           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4768           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4769      &        escloci,dersc(2))
4770           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4771      &        ddersc0(1),dersc(1))
4772           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4773      &        ddersc0(3),dersc(3))
4774           xtemp(2)=pi-delta
4775           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4776           xtemp(2)=pi
4777           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4778           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4779      &            dersc0(2),esclocbi,dersc02)
4780           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4781      &            dersc12,dersc01)
4782           call splinthet(x(2),0.5d0*delta,ss,ssd)
4783           dersc0(1)=dersc01
4784           dersc0(2)=dersc02
4785           dersc0(3)=0.0d0
4786           do k=1,3
4787             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4788           enddo
4789           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4790 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4791 c    &             esclocbi,ss,ssd
4792           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4793 c         escloci=esclocbi
4794 c         write (iout,*) escloci
4795         else if (x(2).lt.delta) then
4796           xtemp(1)=x(1)
4797           xtemp(2)=delta
4798           xtemp(3)=x(3)
4799           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4800           xtemp(2)=0.0d0
4801           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4802           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4803      &        escloci,dersc(2))
4804           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4805      &        ddersc0(1),dersc(1))
4806           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4807      &        ddersc0(3),dersc(3))
4808           xtemp(2)=delta
4809           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4810           xtemp(2)=0.0d0
4811           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4812           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4813      &            dersc0(2),esclocbi,dersc02)
4814           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4815      &            dersc12,dersc01)
4816           dersc0(1)=dersc01
4817           dersc0(2)=dersc02
4818           dersc0(3)=0.0d0
4819           call splinthet(x(2),0.5d0*delta,ss,ssd)
4820           do k=1,3
4821             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4822           enddo
4823           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4824 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4825 c    &             esclocbi,ss,ssd
4826           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4827 c         write (iout,*) escloci
4828         else
4829           call enesc(x,escloci,dersc,ddummy,.false.)
4830         endif
4831
4832         escloc=escloc+escloci
4833         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4834      &     'escloc',i,escloci
4835 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4836
4837         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4838      &   wscloc*dersc(1)
4839         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4840         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4841     1   continue
4842       enddo
4843       return
4844       end
4845 C---------------------------------------------------------------------------
4846       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4847       implicit real*8 (a-h,o-z)
4848       include 'DIMENSIONS'
4849       include 'COMMON.GEO'
4850       include 'COMMON.LOCAL'
4851       include 'COMMON.IOUNITS'
4852       common /sccalc/ time11,time12,time112,theti,it,nlobit
4853       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4854       double precision contr(maxlob,-1:1)
4855       logical mixed
4856 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4857         escloc_i=0.0D0
4858         do j=1,3
4859           dersc(j)=0.0D0
4860           if (mixed) ddersc(j)=0.0d0
4861         enddo
4862         x3=x(3)
4863
4864 C Because of periodicity of the dependence of the SC energy in omega we have
4865 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4866 C To avoid underflows, first compute & store the exponents.
4867
4868         do iii=-1,1
4869
4870           x(3)=x3+iii*dwapi
4871
4872           do j=1,nlobit
4873             do k=1,3
4874               z(k)=x(k)-censc(k,j,it)
4875             enddo
4876             do k=1,3
4877               Axk=0.0D0
4878               do l=1,3
4879                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4880               enddo
4881               Ax(k,j,iii)=Axk
4882             enddo
4883             expfac=0.0D0
4884             do k=1,3
4885               expfac=expfac+Ax(k,j,iii)*z(k)
4886             enddo
4887             contr(j,iii)=expfac
4888           enddo ! j
4889
4890         enddo ! iii
4891
4892         x(3)=x3
4893 C As in the case of ebend, we want to avoid underflows in exponentiation and
4894 C subsequent NaNs and INFs in energy calculation.
4895 C Find the largest exponent
4896         emin=contr(1,-1)
4897         do iii=-1,1
4898           do j=1,nlobit
4899             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4900           enddo
4901         enddo
4902         emin=0.5D0*emin
4903 cd      print *,'it=',it,' emin=',emin
4904
4905 C Compute the contribution to SC energy and derivatives
4906         do iii=-1,1
4907
4908           do j=1,nlobit
4909 #ifdef OSF
4910             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4911             if(adexp.ne.adexp) adexp=1.0
4912             expfac=dexp(adexp)
4913 #else
4914             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4915 #endif
4916 cd          print *,'j=',j,' expfac=',expfac
4917             escloc_i=escloc_i+expfac
4918             do k=1,3
4919               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4920             enddo
4921             if (mixed) then
4922               do k=1,3,2
4923                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4924      &            +gaussc(k,2,j,it))*expfac
4925               enddo
4926             endif
4927           enddo
4928
4929         enddo ! iii
4930
4931         dersc(1)=dersc(1)/cos(theti)**2
4932         ddersc(1)=ddersc(1)/cos(theti)**2
4933         ddersc(3)=ddersc(3)
4934
4935         escloci=-(dlog(escloc_i)-emin)
4936         do j=1,3
4937           dersc(j)=dersc(j)/escloc_i
4938         enddo
4939         if (mixed) then
4940           do j=1,3,2
4941             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4942           enddo
4943         endif
4944       return
4945       end
4946 C------------------------------------------------------------------------------
4947       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4948       implicit real*8 (a-h,o-z)
4949       include 'DIMENSIONS'
4950       include 'COMMON.GEO'
4951       include 'COMMON.LOCAL'
4952       include 'COMMON.IOUNITS'
4953       common /sccalc/ time11,time12,time112,theti,it,nlobit
4954       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4955       double precision contr(maxlob)
4956       logical mixed
4957
4958       escloc_i=0.0D0
4959
4960       do j=1,3
4961         dersc(j)=0.0D0
4962       enddo
4963
4964       do j=1,nlobit
4965         do k=1,2
4966           z(k)=x(k)-censc(k,j,it)
4967         enddo
4968         z(3)=dwapi
4969         do k=1,3
4970           Axk=0.0D0
4971           do l=1,3
4972             Axk=Axk+gaussc(l,k,j,it)*z(l)
4973           enddo
4974           Ax(k,j)=Axk
4975         enddo
4976         expfac=0.0D0
4977         do k=1,3
4978           expfac=expfac+Ax(k,j)*z(k)
4979         enddo
4980         contr(j)=expfac
4981       enddo ! j
4982
4983 C As in the case of ebend, we want to avoid underflows in exponentiation and
4984 C subsequent NaNs and INFs in energy calculation.
4985 C Find the largest exponent
4986       emin=contr(1)
4987       do j=1,nlobit
4988         if (emin.gt.contr(j)) emin=contr(j)
4989       enddo
4990       emin=0.5D0*emin
4991
4992 C Compute the contribution to SC energy and derivatives
4993
4994       dersc12=0.0d0
4995       do j=1,nlobit
4996         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4997         escloc_i=escloc_i+expfac
4998         do k=1,2
4999           dersc(k)=dersc(k)+Ax(k,j)*expfac
5000         enddo
5001         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5002      &            +gaussc(1,2,j,it))*expfac
5003         dersc(3)=0.0d0
5004       enddo
5005
5006       dersc(1)=dersc(1)/cos(theti)**2
5007       dersc12=dersc12/cos(theti)**2
5008       escloci=-(dlog(escloc_i)-emin)
5009       do j=1,2
5010         dersc(j)=dersc(j)/escloc_i
5011       enddo
5012       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5013       return
5014       end
5015 #else
5016 c----------------------------------------------------------------------------------
5017       subroutine esc(escloc)
5018 C Calculate the local energy of a side chain and its derivatives in the
5019 C corresponding virtual-bond valence angles THETA and the spherical angles
5020 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5021 C added by Urszula Kozlowska. 07/11/2007
5022 C
5023       implicit real*8 (a-h,o-z)
5024       include 'DIMENSIONS'
5025       include 'COMMON.GEO'
5026       include 'COMMON.LOCAL'
5027       include 'COMMON.VAR'
5028       include 'COMMON.SCROT'
5029       include 'COMMON.INTERACT'
5030       include 'COMMON.DERIV'
5031       include 'COMMON.CHAIN'
5032       include 'COMMON.IOUNITS'
5033       include 'COMMON.NAMES'
5034       include 'COMMON.FFIELD'
5035       include 'COMMON.CONTROL'
5036       include 'COMMON.VECTORS'
5037       double precision x_prime(3),y_prime(3),z_prime(3)
5038      &    , sumene,dsc_i,dp2_i,x(65),
5039      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5040      &    de_dxx,de_dyy,de_dzz,de_dt
5041       double precision s1_t,s1_6_t,s2_t,s2_6_t
5042       double precision
5043      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5044      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5045      & dt_dCi(3),dt_dCi1(3)
5046       common /sccalc/ time11,time12,time112,theti,it,nlobit
5047       delta=0.02d0*pi
5048       escloc=0.0D0
5049       do i=loc_start,loc_end
5050         if (itype(i).eq.ntyp1) cycle
5051         costtab(i+1) =dcos(theta(i+1))
5052         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5053         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5054         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5055         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5056         cosfac=dsqrt(cosfac2)
5057         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5058         sinfac=dsqrt(sinfac2)
5059         it=iabs(itype(i))
5060         if (it.eq.10) goto 1
5061 c
5062 C  Compute the axes of tghe local cartesian coordinates system; store in
5063 c   x_prime, y_prime and z_prime
5064 c
5065         do j=1,3
5066           x_prime(j) = 0.00
5067           y_prime(j) = 0.00
5068           z_prime(j) = 0.00
5069         enddo
5070 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5071 C     &   dc_norm(3,i+nres)
5072         do j = 1,3
5073           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5074           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5075         enddo
5076         do j = 1,3
5077           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5078         enddo
5079 c       write (2,*) "i",i
5080 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5081 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5082 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5083 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5084 c      & " xy",scalar(x_prime(1),y_prime(1)),
5085 c      & " xz",scalar(x_prime(1),z_prime(1)),
5086 c      & " yy",scalar(y_prime(1),y_prime(1)),
5087 c      & " yz",scalar(y_prime(1),z_prime(1)),
5088 c      & " zz",scalar(z_prime(1),z_prime(1))
5089 c
5090 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5091 C to local coordinate system. Store in xx, yy, zz.
5092 c
5093         xx=0.0d0
5094         yy=0.0d0
5095         zz=0.0d0
5096         do j = 1,3
5097           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5098           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5099           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5100         enddo
5101
5102         xxtab(i)=xx
5103         yytab(i)=yy
5104         zztab(i)=zz
5105 C
5106 C Compute the energy of the ith side cbain
5107 C
5108 c        write (2,*) "xx",xx," yy",yy," zz",zz
5109         it=iabs(itype(i))
5110         do j = 1,65
5111           x(j) = sc_parmin(j,it)
5112         enddo
5113 #ifdef CHECK_COORD
5114 Cc diagnostics - remove later
5115         xx1 = dcos(alph(2))
5116         yy1 = dsin(alph(2))*dcos(omeg(2))
5117         zz1 = -dsign(1.0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5118         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5119      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5120      &    xx1,yy1,zz1
5121 C,"  --- ", xx_w,yy_w,zz_w
5122 c end diagnostics
5123 #endif
5124         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5125      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5126      &   + x(10)*yy*zz
5127         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5128      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5129      & + x(20)*yy*zz
5130         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5131      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5132      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5133      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5134      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5135      &  +x(40)*xx*yy*zz
5136         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5137      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5138      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5139      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5140      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5141      &  +x(60)*xx*yy*zz
5142         dsc_i   = 0.743d0+x(61)
5143         dp2_i   = 1.9d0+x(62)
5144         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5145      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5146         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5147      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5148         s1=(1+x(63))/(0.1d0 + dscp1)
5149         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5150         s2=(1+x(65))/(0.1d0 + dscp2)
5151         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5152         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5153      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5154 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5155 c     &   sumene4,
5156 c     &   dscp1,dscp2,sumene
5157 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5158         escloc = escloc + sumene
5159 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5160 c     & ,zz,xx,yy
5161 c#define DEBUG
5162 #ifdef DEBUG
5163 C
5164 C This section to check the numerical derivatives of the energy of ith side
5165 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5166 C #define DEBUG in the code to turn it on.
5167 C
5168         write (2,*) "sumene               =",sumene
5169         aincr=1.0d-7
5170         xxsave=xx
5171         xx=xx+aincr
5172         write (2,*) xx,yy,zz
5173         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5174         de_dxx_num=(sumenep-sumene)/aincr
5175         xx=xxsave
5176         write (2,*) "xx+ sumene from enesc=",sumenep
5177         yysave=yy
5178         yy=yy+aincr
5179         write (2,*) xx,yy,zz
5180         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5181         de_dyy_num=(sumenep-sumene)/aincr
5182         yy=yysave
5183         write (2,*) "yy+ sumene from enesc=",sumenep
5184         zzsave=zz
5185         zz=zz+aincr
5186         write (2,*) xx,yy,zz
5187         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5188         de_dzz_num=(sumenep-sumene)/aincr
5189         zz=zzsave
5190         write (2,*) "zz+ sumene from enesc=",sumenep
5191         costsave=cost2tab(i+1)
5192         sintsave=sint2tab(i+1)
5193         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5194         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5195         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5196         de_dt_num=(sumenep-sumene)/aincr
5197         write (2,*) " t+ sumene from enesc=",sumenep
5198         cost2tab(i+1)=costsave
5199         sint2tab(i+1)=sintsave
5200 C End of diagnostics section.
5201 #endif
5202 C
5203 C Compute the gradient of esc
5204 C
5205 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5206         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5207         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5208         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5209         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5210         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5211         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5212         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5213         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5214         pom1=(sumene3*sint2tab(i+1)+sumene1)
5215      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5216         pom2=(sumene4*cost2tab(i+1)+sumene2)
5217      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5218         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5219         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5220      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5221      &  +x(40)*yy*zz
5222         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5223         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5224      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5225      &  +x(60)*yy*zz
5226         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5227      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5228      &        +(pom1+pom2)*pom_dx
5229 #ifdef DEBUG
5230         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5231 #endif
5232 C
5233         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5234         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5235      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5236      &  +x(40)*xx*zz
5237         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5238         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5239      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5240      &  +x(59)*zz**2 +x(60)*xx*zz
5241         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5242      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5243      &        +(pom1-pom2)*pom_dy
5244 #ifdef DEBUG
5245         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5246 #endif
5247 C
5248         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5249      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5250      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5251      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5252      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5253      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5254      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5255      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5256 #ifdef DEBUG
5257         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5258 #endif
5259 C
5260         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5261      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5262      &  +pom1*pom_dt1+pom2*pom_dt2
5263 #ifdef DEBUG
5264         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5265 #endif
5266 c#undef DEBUG
5267 c
5268 C
5269        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5270        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5271        cosfac2xx=cosfac2*xx
5272        sinfac2yy=sinfac2*yy
5273        do k = 1,3
5274          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5275      &      vbld_inv(i+1)
5276          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5277      &      vbld_inv(i)
5278          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5279          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5280 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5281 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5282 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5283 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5284          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5285          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5286          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5287          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5288          dZZ_Ci1(k)=0.0d0
5289          dZZ_Ci(k)=0.0d0
5290          do j=1,3
5291            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5292      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5293            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5294      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5295          enddo
5296
5297          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5298          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5299          dZZ_XYZ(k)=vbld_inv(i+nres)*
5300      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5301 c
5302          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5303          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5304        enddo
5305
5306        do k=1,3
5307          dXX_Ctab(k,i)=dXX_Ci(k)
5308          dXX_C1tab(k,i)=dXX_Ci1(k)
5309          dYY_Ctab(k,i)=dYY_Ci(k)
5310          dYY_C1tab(k,i)=dYY_Ci1(k)
5311          dZZ_Ctab(k,i)=dZZ_Ci(k)
5312          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5313          dXX_XYZtab(k,i)=dXX_XYZ(k)
5314          dYY_XYZtab(k,i)=dYY_XYZ(k)
5315          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5316        enddo
5317
5318        do k = 1,3
5319 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5320 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5321 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5322 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5323 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5324 c     &    dt_dci(k)
5325 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5326 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5327          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5328      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5329          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5330      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5331          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5332      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5333        enddo
5334 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5335 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5336
5337 C to check gradient call subroutine check_grad
5338
5339     1 continue
5340       enddo
5341       return
5342       end
5343 c------------------------------------------------------------------------------
5344       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5345       implicit none
5346       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5347      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5348       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5349      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5350      &   + x(10)*yy*zz
5351       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5352      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5353      & + x(20)*yy*zz
5354       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5355      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5356      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5357      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5358      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5359      &  +x(40)*xx*yy*zz
5360       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5361      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5362      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5363      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5364      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5365      &  +x(60)*xx*yy*zz
5366       dsc_i   = 0.743d0+x(61)
5367       dp2_i   = 1.9d0+x(62)
5368       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5369      &          *(xx*cost2+yy*sint2))
5370       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5371      &          *(xx*cost2-yy*sint2))
5372       s1=(1+x(63))/(0.1d0 + dscp1)
5373       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5374       s2=(1+x(65))/(0.1d0 + dscp2)
5375       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5376       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5377      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5378       enesc=sumene
5379       return
5380       end
5381 #endif
5382 c------------------------------------------------------------------------------
5383       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5384 C
5385 C This procedure calculates two-body contact function g(rij) and its derivative:
5386 C
5387 C           eps0ij                                     !       x < -1
5388 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5389 C            0                                         !       x > 1
5390 C
5391 C where x=(rij-r0ij)/delta
5392 C
5393 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5394 C
5395       implicit none
5396       double precision rij,r0ij,eps0ij,fcont,fprimcont
5397       double precision x,x2,x4,delta
5398 c     delta=0.02D0*r0ij
5399 c      delta=0.2D0*r0ij
5400       x=(rij-r0ij)/delta
5401       if (x.lt.-1.0D0) then
5402         fcont=eps0ij
5403         fprimcont=0.0D0
5404       else if (x.le.1.0D0) then
5405         x2=x*x
5406         x4=x2*x2
5407         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5408         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5409       else
5410         fcont=0.0D0
5411         fprimcont=0.0D0
5412       endif
5413       return
5414       end
5415 c------------------------------------------------------------------------------
5416       subroutine splinthet(theti,delta,ss,ssder)
5417       implicit real*8 (a-h,o-z)
5418       include 'DIMENSIONS'
5419       include 'COMMON.VAR'
5420       include 'COMMON.GEO'
5421       thetup=pi-delta
5422       thetlow=delta
5423       if (theti.gt.pipol) then
5424         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5425       else
5426         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5427         ssder=-ssder
5428       endif
5429       return
5430       end
5431 c------------------------------------------------------------------------------
5432       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5433       implicit none
5434       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5435       double precision ksi,ksi2,ksi3,a1,a2,a3
5436       a1=fprim0*delta/(f1-f0)
5437       a2=3.0d0-2.0d0*a1
5438       a3=a1-2.0d0
5439       ksi=(x-x0)/delta
5440       ksi2=ksi*ksi
5441       ksi3=ksi2*ksi
5442       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5443       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5444       return
5445       end
5446 c------------------------------------------------------------------------------
5447       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5448       implicit none
5449       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5450       double precision ksi,ksi2,ksi3,a1,a2,a3
5451       ksi=(x-x0)/delta
5452       ksi2=ksi*ksi
5453       ksi3=ksi2*ksi
5454       a1=fprim0x*delta
5455       a2=3*(f1x-f0x)-2*fprim0x*delta
5456       a3=fprim0x*delta-2*(f1x-f0x)
5457       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5458       return
5459       end
5460 C-----------------------------------------------------------------------------
5461 #ifdef CRYST_TOR
5462 C-----------------------------------------------------------------------------
5463       subroutine etor(etors,edihcnstr)
5464       implicit real*8 (a-h,o-z)
5465       include 'DIMENSIONS'
5466       include 'COMMON.VAR'
5467       include 'COMMON.GEO'
5468       include 'COMMON.LOCAL'
5469       include 'COMMON.TORSION'
5470       include 'COMMON.INTERACT'
5471       include 'COMMON.DERIV'
5472       include 'COMMON.CHAIN'
5473       include 'COMMON.NAMES'
5474       include 'COMMON.IOUNITS'
5475       include 'COMMON.FFIELD'
5476       include 'COMMON.TORCNSTR'
5477       include 'COMMON.CONTROL'
5478       logical lprn
5479 C Set lprn=.true. for debugging
5480       lprn=.false.
5481 c      lprn=.true.
5482       etors=0.0D0
5483       do i=iphi_start,iphi_end
5484       etors_ii=0.0D0
5485         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5486      &      .or. itype(i).eq.ntyp1) cycle
5487         itori=itortyp(itype(i-2))
5488         itori1=itortyp(itype(i-1))
5489         phii=phi(i)
5490         gloci=0.0D0
5491 C Proline-Proline pair is a special case...
5492         if (itori.eq.3 .and. itori1.eq.3) then
5493           if (phii.gt.-dwapi3) then
5494             cosphi=dcos(3*phii)
5495             fac=1.0D0/(1.0D0-cosphi)
5496             etorsi=v1(1,3,3)*fac
5497             etorsi=etorsi+etorsi
5498             etors=etors+etorsi-v1(1,3,3)
5499             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5500             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5501           endif
5502           do j=1,3
5503             v1ij=v1(j+1,itori,itori1)
5504             v2ij=v2(j+1,itori,itori1)
5505             cosphi=dcos(j*phii)
5506             sinphi=dsin(j*phii)
5507             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5508             if (energy_dec) etors_ii=etors_ii+
5509      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5510             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5511           enddo
5512         else
5513           do j=1,nterm_old
5514             v1ij=v1(j,itori,itori1)
5515             v2ij=v2(j,itori,itori1)
5516             cosphi=dcos(j*phii)
5517             sinphi=dsin(j*phii)
5518             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5519             if (energy_dec) etors_ii=etors_ii+
5520      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5521             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5522           enddo
5523         endif
5524         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5525              'etor',i,etors_ii
5526         if (lprn)
5527      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5528      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5529      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5530         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5531 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5532       enddo
5533 ! 6/20/98 - dihedral angle constraints
5534       edihcnstr=0.0d0
5535       do i=1,ndih_constr
5536         itori=idih_constr(i)
5537         phii=phi(itori)
5538         difi=phii-phi0(i)
5539         if (difi.gt.drange(i)) then
5540           difi=difi-drange(i)
5541           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5542           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5543         else if (difi.lt.-drange(i)) then
5544           difi=difi+drange(i)
5545           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5546           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5547         endif
5548 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5549 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5550       enddo
5551 !      write (iout,*) 'edihcnstr',edihcnstr
5552       return
5553       end
5554 c------------------------------------------------------------------------------
5555       subroutine etor_d(etors_d)
5556       etors_d=0.0d0
5557       return
5558       end
5559 c----------------------------------------------------------------------------
5560 #else
5561       subroutine etor(etors,edihcnstr)
5562       implicit real*8 (a-h,o-z)
5563       include 'DIMENSIONS'
5564       include 'COMMON.VAR'
5565       include 'COMMON.GEO'
5566       include 'COMMON.LOCAL'
5567       include 'COMMON.TORSION'
5568       include 'COMMON.INTERACT'
5569       include 'COMMON.DERIV'
5570       include 'COMMON.CHAIN'
5571       include 'COMMON.NAMES'
5572       include 'COMMON.IOUNITS'
5573       include 'COMMON.FFIELD'
5574       include 'COMMON.TORCNSTR'
5575       include 'COMMON.CONTROL'
5576       logical lprn
5577 C Set lprn=.true. for debugging
5578       lprn=.false.
5579 c     lprn=.true.
5580       etors=0.0D0
5581       do i=iphi_start,iphi_end
5582         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5583      &       .or. itype(i).eq.ntyp1) cycle
5584         etors_ii=0.0D0
5585          if (iabs(itype(i)).eq.20) then
5586          iblock=2
5587          else
5588          iblock=1
5589          endif
5590         itori=itortyp(itype(i-2))
5591         itori1=itortyp(itype(i-1))
5592         phii=phi(i)
5593         gloci=0.0D0
5594 C Regular cosine and sine terms
5595         do j=1,nterm(itori,itori1,iblock)
5596           v1ij=v1(j,itori,itori1,iblock)
5597           v2ij=v2(j,itori,itori1,iblock)
5598           cosphi=dcos(j*phii)
5599           sinphi=dsin(j*phii)
5600           etors=etors+v1ij*cosphi+v2ij*sinphi
5601           if (energy_dec) etors_ii=etors_ii+
5602      &                v1ij*cosphi+v2ij*sinphi
5603           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5604         enddo
5605 C Lorentz terms
5606 C                         v1
5607 C  E = SUM ----------------------------------- - v1
5608 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5609 C
5610         cosphi=dcos(0.5d0*phii)
5611         sinphi=dsin(0.5d0*phii)
5612         do j=1,nlor(itori,itori1,iblock)
5613           vl1ij=vlor1(j,itori,itori1)
5614           vl2ij=vlor2(j,itori,itori1)
5615           vl3ij=vlor3(j,itori,itori1)
5616           pom=vl2ij*cosphi+vl3ij*sinphi
5617           pom1=1.0d0/(pom*pom+1.0d0)
5618           etors=etors+vl1ij*pom1
5619           if (energy_dec) etors_ii=etors_ii+
5620      &                vl1ij*pom1
5621           pom=-pom*pom1*pom1
5622           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5623         enddo
5624 C Subtract the constant term
5625         etors=etors-v0(itori,itori1,iblock)
5626           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5627      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5628         if (lprn)
5629      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5630      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5631      &  (v1(j,itori,itori1,iblock),j=1,6),
5632      &  (v2(j,itori,itori1,iblock),j=1,6)
5633         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5634 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5635       enddo
5636 ! 6/20/98 - dihedral angle constraints
5637       edihcnstr=0.0d0
5638 c      do i=1,ndih_constr
5639       do i=idihconstr_start,idihconstr_end
5640         itori=idih_constr(i)
5641         phii=phi(itori)
5642         difi=pinorm(phii-phi0(i))
5643         if (difi.gt.drange(i)) then
5644           difi=difi-drange(i)
5645           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5646           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5647         else if (difi.lt.-drange(i)) then
5648           difi=difi+drange(i)
5649           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5650           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5651         else
5652           difi=0.0
5653         endif
5654 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5655 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5656 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5657       enddo
5658 cd       write (iout,*) 'edihcnstr',edihcnstr
5659       return
5660       end
5661 c----------------------------------------------------------------------------
5662       subroutine etor_d(etors_d)
5663 C 6/23/01 Compute double torsional energy
5664       implicit real*8 (a-h,o-z)
5665       include 'DIMENSIONS'
5666       include 'COMMON.VAR'
5667       include 'COMMON.GEO'
5668       include 'COMMON.LOCAL'
5669       include 'COMMON.TORSION'
5670       include 'COMMON.INTERACT'
5671       include 'COMMON.DERIV'
5672       include 'COMMON.CHAIN'
5673       include 'COMMON.NAMES'
5674       include 'COMMON.IOUNITS'
5675       include 'COMMON.FFIELD'
5676       include 'COMMON.TORCNSTR'
5677       logical lprn
5678 C Set lprn=.true. for debugging
5679       lprn=.false.
5680 c     lprn=.true.
5681       etors_d=0.0D0
5682 c      write(iout,*) "a tu??"
5683       do i=iphid_start,iphid_end
5684         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5685      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5686         itori=itortyp(itype(i-2))
5687         itori1=itortyp(itype(i-1))
5688         itori2=itortyp(itype(i))
5689         phii=phi(i)
5690         phii1=phi(i+1)
5691         gloci1=0.0D0
5692         gloci2=0.0D0
5693         iblock=1
5694         if (iabs(itype(i+1)).eq.20) iblock=2
5695
5696 C Regular cosine and sine terms
5697         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5698           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5699           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5700           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5701           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5702           cosphi1=dcos(j*phii)
5703           sinphi1=dsin(j*phii)
5704           cosphi2=dcos(j*phii1)
5705           sinphi2=dsin(j*phii1)
5706           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5707      &     v2cij*cosphi2+v2sij*sinphi2
5708           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5709           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5710         enddo
5711         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5712           do l=1,k-1
5713             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5714             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5715             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5716             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5717             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5718             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5719             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5720             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5721             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5722      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5723             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5724      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5725             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5726      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5727           enddo
5728         enddo
5729         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5730         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5731       enddo
5732       return
5733       end
5734 #endif
5735 c------------------------------------------------------------------------------
5736       subroutine eback_sc_corr(esccor)
5737 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5738 c        conformational states; temporarily implemented as differences
5739 c        between UNRES torsional potentials (dependent on three types of
5740 c        residues) and the torsional potentials dependent on all 20 types
5741 c        of residues computed from AM1  energy surfaces of terminally-blocked
5742 c        amino-acid residues.
5743       implicit real*8 (a-h,o-z)
5744       include 'DIMENSIONS'
5745       include 'COMMON.VAR'
5746       include 'COMMON.GEO'
5747       include 'COMMON.LOCAL'
5748       include 'COMMON.TORSION'
5749       include 'COMMON.SCCOR'
5750       include 'COMMON.INTERACT'
5751       include 'COMMON.DERIV'
5752       include 'COMMON.CHAIN'
5753       include 'COMMON.NAMES'
5754       include 'COMMON.IOUNITS'
5755       include 'COMMON.FFIELD'
5756       include 'COMMON.CONTROL'
5757       logical lprn
5758 C Set lprn=.true. for debugging
5759       lprn=.false.
5760 c      lprn=.true.
5761 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5762       esccor=0.0D0
5763       do i=itau_start,itau_end
5764         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5765         esccor_ii=0.0D0
5766         isccori=isccortyp(itype(i-2))
5767         isccori1=isccortyp(itype(i-1))
5768 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5769         phii=phi(i)
5770         do intertyp=1,3 !intertyp
5771 cc Added 09 May 2012 (Adasko)
5772 cc  Intertyp means interaction type of backbone mainchain correlation:
5773 c   1 = SC...Ca...Ca...Ca
5774 c   2 = Ca...Ca...Ca...SC
5775 c   3 = SC...Ca...Ca...SCi
5776         gloci=0.0D0
5777         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5778      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5779      &      (itype(i-1).eq.ntyp1)))
5780      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5781      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5782      &     .or.(itype(i).eq.ntyp1)))
5783      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5784      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5785      &      (itype(i-3).eq.ntyp1)))) cycle
5786         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5787         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5788      & cycle
5789        do j=1,nterm_sccor(isccori,isccori1)
5790           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5791           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5792           cosphi=dcos(j*tauangle(intertyp,i))
5793           sinphi=dsin(j*tauangle(intertyp,i))
5794           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5795           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5796         enddo
5797 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5798         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5799         if (lprn)
5800      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5801      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5802      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5803      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5804         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5805        enddo !intertyp
5806       enddo
5807
5808       return
5809       end
5810 c----------------------------------------------------------------------------
5811       subroutine multibody(ecorr)
5812 C This subroutine calculates multi-body contributions to energy following
5813 C the idea of Skolnick et al. If side chains I and J make a contact and
5814 C at the same time side chains I+1 and J+1 make a contact, an extra
5815 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5816       implicit real*8 (a-h,o-z)
5817       include 'DIMENSIONS'
5818       include 'COMMON.IOUNITS'
5819       include 'COMMON.DERIV'
5820       include 'COMMON.INTERACT'
5821       include 'COMMON.CONTACTS'
5822       double precision gx(3),gx1(3)
5823       logical lprn
5824
5825 C Set lprn=.true. for debugging
5826       lprn=.false.
5827
5828       if (lprn) then
5829         write (iout,'(a)') 'Contact function values:'
5830         do i=nnt,nct-2
5831           write (iout,'(i2,20(1x,i2,f10.5))')
5832      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5833         enddo
5834       endif
5835       ecorr=0.0D0
5836       do i=nnt,nct
5837         do j=1,3
5838           gradcorr(j,i)=0.0D0
5839           gradxorr(j,i)=0.0D0
5840         enddo
5841       enddo
5842       do i=nnt,nct-2
5843
5844         DO ISHIFT = 3,4
5845
5846         i1=i+ishift
5847         num_conti=num_cont(i)
5848         num_conti1=num_cont(i1)
5849         do jj=1,num_conti
5850           j=jcont(jj,i)
5851           do kk=1,num_conti1
5852             j1=jcont(kk,i1)
5853             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5854 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5855 cd   &                   ' ishift=',ishift
5856 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5857 C The system gains extra energy.
5858               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5859             endif   ! j1==j+-ishift
5860           enddo     ! kk
5861         enddo       ! jj
5862
5863         ENDDO ! ISHIFT
5864
5865       enddo         ! i
5866       return
5867       end
5868 c------------------------------------------------------------------------------
5869       double precision function esccorr(i,j,k,l,jj,kk)
5870       implicit real*8 (a-h,o-z)
5871       include 'DIMENSIONS'
5872       include 'COMMON.IOUNITS'
5873       include 'COMMON.DERIV'
5874       include 'COMMON.INTERACT'
5875       include 'COMMON.CONTACTS'
5876       double precision gx(3),gx1(3)
5877       logical lprn
5878       lprn=.false.
5879       eij=facont(jj,i)
5880       ekl=facont(kk,k)
5881 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5882 C Calculate the multi-body contribution to energy.
5883 C Calculate multi-body contributions to the gradient.
5884 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5885 cd   & k,l,(gacont(m,kk,k),m=1,3)
5886       do m=1,3
5887         gx(m) =ekl*gacont(m,jj,i)
5888         gx1(m)=eij*gacont(m,kk,k)
5889         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5890         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5891         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5892         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5893       enddo
5894       do m=i,j-1
5895         do ll=1,3
5896           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5897         enddo
5898       enddo
5899       do m=k,l-1
5900         do ll=1,3
5901           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5902         enddo
5903       enddo
5904       esccorr=-eij*ekl
5905       return
5906       end
5907 c------------------------------------------------------------------------------
5908       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5909 C This subroutine calculates multi-body contributions to hydrogen-bonding
5910       implicit real*8 (a-h,o-z)
5911       include 'DIMENSIONS'
5912       include 'COMMON.IOUNITS'
5913 #ifdef MPI
5914       include "mpif.h"
5915       parameter (max_cont=maxconts)
5916       parameter (max_dim=26)
5917       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5918       double precision zapas(max_dim,maxconts,max_fg_procs),
5919      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5920       common /przechowalnia/ zapas
5921       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5922      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5923 #endif
5924       include 'COMMON.SETUP'
5925       include 'COMMON.FFIELD'
5926       include 'COMMON.DERIV'
5927       include 'COMMON.INTERACT'
5928       include 'COMMON.CONTACTS'
5929       include 'COMMON.CONTROL'
5930       include 'COMMON.LOCAL'
5931       double precision gx(3),gx1(3),time00
5932       logical lprn,ldone
5933
5934 C Set lprn=.true. for debugging
5935       lprn=.false.
5936 #ifdef MPI
5937       n_corr=0
5938       n_corr1=0
5939       if (nfgtasks.le.1) goto 30
5940       if (lprn) then
5941         write (iout,'(a)') 'Contact function values before RECEIVE:'
5942         do i=nnt,nct-2
5943           write (iout,'(2i3,50(1x,i2,f5.2))')
5944      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5945      &    j=1,num_cont_hb(i))
5946         enddo
5947       endif
5948       call flush(iout)
5949       do i=1,ntask_cont_from
5950         ncont_recv(i)=0
5951       enddo
5952       do i=1,ntask_cont_to
5953         ncont_sent(i)=0
5954       enddo
5955 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5956 c     & ntask_cont_to
5957 C Make the list of contacts to send to send to other procesors
5958 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5959 c      call flush(iout)
5960       do i=iturn3_start,iturn3_end
5961 c        write (iout,*) "make contact list turn3",i," num_cont",
5962 c     &    num_cont_hb(i)
5963         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5964       enddo
5965       do i=iturn4_start,iturn4_end
5966 c        write (iout,*) "make contact list turn4",i," num_cont",
5967 c     &   num_cont_hb(i)
5968         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5969       enddo
5970       do ii=1,nat_sent
5971         i=iat_sent(ii)
5972 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5973 c     &    num_cont_hb(i)
5974         do j=1,num_cont_hb(i)
5975         do k=1,4
5976           jjc=jcont_hb(j,i)
5977           iproc=iint_sent_local(k,jjc,ii)
5978 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5979           if (iproc.gt.0) then
5980             ncont_sent(iproc)=ncont_sent(iproc)+1
5981             nn=ncont_sent(iproc)
5982             zapas(1,nn,iproc)=i
5983             zapas(2,nn,iproc)=jjc
5984             zapas(3,nn,iproc)=facont_hb(j,i)
5985             zapas(4,nn,iproc)=ees0p(j,i)
5986             zapas(5,nn,iproc)=ees0m(j,i)
5987             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5988             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5989             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5990             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5991             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5992             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5993             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5994             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5995             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5996             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5997             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5998             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5999             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6000             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6001             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6002             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6003             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6004             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6005             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6006             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6007             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6008           endif
6009         enddo
6010         enddo
6011       enddo
6012       if (lprn) then
6013       write (iout,*)
6014      &  "Numbers of contacts to be sent to other processors",
6015      &  (ncont_sent(i),i=1,ntask_cont_to)
6016       write (iout,*) "Contacts sent"
6017       do ii=1,ntask_cont_to
6018         nn=ncont_sent(ii)
6019         iproc=itask_cont_to(ii)
6020         write (iout,*) nn," contacts to processor",iproc,
6021      &   " of CONT_TO_COMM group"
6022         do i=1,nn
6023           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6024         enddo
6025       enddo
6026       call flush(iout)
6027       endif
6028       CorrelType=477
6029       CorrelID=fg_rank+1
6030       CorrelType1=478
6031       CorrelID1=nfgtasks+fg_rank+1
6032       ireq=0
6033 C Receive the numbers of needed contacts from other processors
6034       do ii=1,ntask_cont_from
6035         iproc=itask_cont_from(ii)
6036         ireq=ireq+1
6037         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6038      &    FG_COMM,req(ireq),IERR)
6039       enddo
6040 c      write (iout,*) "IRECV ended"
6041 c      call flush(iout)
6042 C Send the number of contacts needed by other processors
6043       do ii=1,ntask_cont_to
6044         iproc=itask_cont_to(ii)
6045         ireq=ireq+1
6046         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6047      &    FG_COMM,req(ireq),IERR)
6048       enddo
6049 c      write (iout,*) "ISEND ended"
6050 c      write (iout,*) "number of requests (nn)",ireq
6051       call flush(iout)
6052       if (ireq.gt.0)
6053      &  call MPI_Waitall(ireq,req,status_array,ierr)
6054 c      write (iout,*)
6055 c     &  "Numbers of contacts to be received from other processors",
6056 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6057 c      call flush(iout)
6058 C Receive contacts
6059       ireq=0
6060       do ii=1,ntask_cont_from
6061         iproc=itask_cont_from(ii)
6062         nn=ncont_recv(ii)
6063 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6064 c     &   " of CONT_TO_COMM group"
6065         call flush(iout)
6066         if (nn.gt.0) then
6067           ireq=ireq+1
6068           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6069      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6070 c          write (iout,*) "ireq,req",ireq,req(ireq)
6071         endif
6072       enddo
6073 C Send the contacts to processors that need them
6074       do ii=1,ntask_cont_to
6075         iproc=itask_cont_to(ii)
6076         nn=ncont_sent(ii)
6077 c        write (iout,*) nn," contacts to processor",iproc,
6078 c     &   " of CONT_TO_COMM group"
6079         if (nn.gt.0) then
6080           ireq=ireq+1
6081           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6082      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6083 c          write (iout,*) "ireq,req",ireq,req(ireq)
6084 c          do i=1,nn
6085 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6086 c          enddo
6087         endif
6088       enddo
6089 c      write (iout,*) "number of requests (contacts)",ireq
6090 c      write (iout,*) "req",(req(i),i=1,4)
6091 c      call flush(iout)
6092       if (ireq.gt.0)
6093      & call MPI_Waitall(ireq,req,status_array,ierr)
6094       do iii=1,ntask_cont_from
6095         iproc=itask_cont_from(iii)
6096         nn=ncont_recv(iii)
6097         if (lprn) then
6098         write (iout,*) "Received",nn," contacts from processor",iproc,
6099      &   " of CONT_FROM_COMM group"
6100         call flush(iout)
6101         do i=1,nn
6102           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6103         enddo
6104         call flush(iout)
6105         endif
6106         do i=1,nn
6107           ii=zapas_recv(1,i,iii)
6108 c Flag the received contacts to prevent double-counting
6109           jj=-zapas_recv(2,i,iii)
6110 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6111 c          call flush(iout)
6112           nnn=num_cont_hb(ii)+1
6113           num_cont_hb(ii)=nnn
6114           jcont_hb(nnn,ii)=jj
6115           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6116           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6117           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6118           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6119           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6120           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6121           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6122           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6123           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6124           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6125           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6126           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6127           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6128           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6129           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6130           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6131           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6132           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6133           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6134           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6135           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6136           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6137           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6138           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6139         enddo
6140       enddo
6141       call flush(iout)
6142       if (lprn) then
6143         write (iout,'(a)') 'Contact function values after receive:'
6144         do i=nnt,nct-2
6145           write (iout,'(2i3,50(1x,i3,f5.2))')
6146      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6147      &    j=1,num_cont_hb(i))
6148         enddo
6149         call flush(iout)
6150       endif
6151    30 continue
6152 #endif
6153       if (lprn) then
6154         write (iout,'(a)') 'Contact function values:'
6155         do i=nnt,nct-2
6156           write (iout,'(2i3,50(1x,i3,f5.2))')
6157      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6158      &    j=1,num_cont_hb(i))
6159         enddo
6160       endif
6161       ecorr=0.0D0
6162 C Remove the loop below after debugging !!!
6163       do i=nnt,nct
6164         do j=1,3
6165           gradcorr(j,i)=0.0D0
6166           gradxorr(j,i)=0.0D0
6167         enddo
6168       enddo
6169 C Calculate the local-electrostatic correlation terms
6170       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6171         i1=i+1
6172         num_conti=num_cont_hb(i)
6173         num_conti1=num_cont_hb(i+1)
6174         do jj=1,num_conti
6175           j=jcont_hb(jj,i)
6176           jp=iabs(j)
6177           do kk=1,num_conti1
6178             j1=jcont_hb(kk,i1)
6179             jp1=iabs(j1)
6180 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6181 c     &         ' jj=',jj,' kk=',kk
6182             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6183      &          .or. j.lt.0 .and. j1.gt.0) .and.
6184      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6185 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6186 C The system gains extra energy.
6187               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6188               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6189      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6190               n_corr=n_corr+1
6191             else if (j1.eq.j) then
6192 C Contacts I-J and I-(J+1) occur simultaneously.
6193 C The system loses extra energy.
6194 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6195             endif
6196           enddo ! kk
6197           do kk=1,num_conti
6198             j1=jcont_hb(kk,i)
6199 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6200 c    &         ' jj=',jj,' kk=',kk
6201             if (j1.eq.j+1) then
6202 C Contacts I-J and (I+1)-J occur simultaneously.
6203 C The system loses extra energy.
6204 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6205             endif ! j1==j+1
6206           enddo ! kk
6207         enddo ! jj
6208       enddo ! i
6209       return
6210       end
6211 c------------------------------------------------------------------------------
6212       subroutine add_hb_contact(ii,jj,itask)
6213       implicit real*8 (a-h,o-z)
6214       include "DIMENSIONS"
6215       include "COMMON.IOUNITS"
6216       integer max_cont
6217       integer max_dim
6218       parameter (max_cont=maxconts)
6219       parameter (max_dim=26)
6220       include "COMMON.CONTACTS"
6221       double precision zapas(max_dim,maxconts,max_fg_procs),
6222      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6223       common /przechowalnia/ zapas
6224       integer i,j,ii,jj,iproc,itask(4),nn
6225 c      write (iout,*) "itask",itask
6226       do i=1,2
6227         iproc=itask(i)
6228         if (iproc.gt.0) then
6229           do j=1,num_cont_hb(ii)
6230             jjc=jcont_hb(j,ii)
6231 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6232             if (jjc.eq.jj) then
6233               ncont_sent(iproc)=ncont_sent(iproc)+1
6234               nn=ncont_sent(iproc)
6235               zapas(1,nn,iproc)=ii
6236               zapas(2,nn,iproc)=jjc
6237               zapas(3,nn,iproc)=facont_hb(j,ii)
6238               zapas(4,nn,iproc)=ees0p(j,ii)
6239               zapas(5,nn,iproc)=ees0m(j,ii)
6240               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6241               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6242               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6243               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6244               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6245               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6246               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6247               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6248               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6249               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6250               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6251               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6252               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6253               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6254               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6255               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6256               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6257               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6258               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6259               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6260               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6261               exit
6262             endif
6263           enddo
6264         endif
6265       enddo
6266       return
6267       end
6268 c------------------------------------------------------------------------------
6269       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6270      &  n_corr1)
6271 C This subroutine calculates multi-body contributions to hydrogen-bonding
6272       implicit real*8 (a-h,o-z)
6273       include 'DIMENSIONS'
6274       include 'COMMON.IOUNITS'
6275 #ifdef MPI
6276       include "mpif.h"
6277       parameter (max_cont=maxconts)
6278       parameter (max_dim=70)
6279       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6280       double precision zapas(max_dim,maxconts,max_fg_procs),
6281      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6282       common /przechowalnia/ zapas
6283       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6284      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6285 #endif
6286       include 'COMMON.SETUP'
6287       include 'COMMON.FFIELD'
6288       include 'COMMON.DERIV'
6289       include 'COMMON.LOCAL'
6290       include 'COMMON.INTERACT'
6291       include 'COMMON.CONTACTS'
6292       include 'COMMON.CHAIN'
6293       include 'COMMON.CONTROL'
6294       double precision gx(3),gx1(3)
6295       integer num_cont_hb_old(maxres)
6296       logical lprn,ldone
6297       double precision eello4,eello5,eelo6,eello_turn6
6298       external eello4,eello5,eello6,eello_turn6
6299 C Set lprn=.true. for debugging
6300       lprn=.false.
6301       eturn6=0.0d0
6302 #ifdef MPI
6303       do i=1,nres
6304         num_cont_hb_old(i)=num_cont_hb(i)
6305       enddo
6306       n_corr=0
6307       n_corr1=0
6308       if (nfgtasks.le.1) goto 30
6309       if (lprn) then
6310         write (iout,'(a)') 'Contact function values before RECEIVE:'
6311         do i=nnt,nct-2
6312           write (iout,'(2i3,50(1x,i2,f5.2))')
6313      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6314      &    j=1,num_cont_hb(i))
6315         enddo
6316       endif
6317       call flush(iout)
6318       do i=1,ntask_cont_from
6319         ncont_recv(i)=0
6320       enddo
6321       do i=1,ntask_cont_to
6322         ncont_sent(i)=0
6323       enddo
6324 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6325 c     & ntask_cont_to
6326 C Make the list of contacts to send to send to other procesors
6327       do i=iturn3_start,iturn3_end
6328 c        write (iout,*) "make contact list turn3",i," num_cont",
6329 c     &    num_cont_hb(i)
6330         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6331       enddo
6332       do i=iturn4_start,iturn4_end
6333 c        write (iout,*) "make contact list turn4",i," num_cont",
6334 c     &   num_cont_hb(i)
6335         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6336       enddo
6337       do ii=1,nat_sent
6338         i=iat_sent(ii)
6339 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6340 c     &    num_cont_hb(i)
6341         do j=1,num_cont_hb(i)
6342         do k=1,4
6343           jjc=jcont_hb(j,i)
6344           iproc=iint_sent_local(k,jjc,ii)
6345 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6346           if (iproc.ne.0) then
6347             ncont_sent(iproc)=ncont_sent(iproc)+1
6348             nn=ncont_sent(iproc)
6349             zapas(1,nn,iproc)=i
6350             zapas(2,nn,iproc)=jjc
6351             zapas(3,nn,iproc)=d_cont(j,i)
6352             ind=3
6353             do kk=1,3
6354               ind=ind+1
6355               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6356             enddo
6357             do kk=1,2
6358               do ll=1,2
6359                 ind=ind+1
6360                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6361               enddo
6362             enddo
6363             do jj=1,5
6364               do kk=1,3
6365                 do ll=1,2
6366                   do mm=1,2
6367                     ind=ind+1
6368                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6369                   enddo
6370                 enddo
6371               enddo
6372             enddo
6373           endif
6374         enddo
6375         enddo
6376       enddo
6377       if (lprn) then
6378       write (iout,*)
6379      &  "Numbers of contacts to be sent to other processors",
6380      &  (ncont_sent(i),i=1,ntask_cont_to)
6381       write (iout,*) "Contacts sent"
6382       do ii=1,ntask_cont_to
6383         nn=ncont_sent(ii)
6384         iproc=itask_cont_to(ii)
6385         write (iout,*) nn," contacts to processor",iproc,
6386      &   " of CONT_TO_COMM group"
6387         do i=1,nn
6388           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6389         enddo
6390       enddo
6391       call flush(iout)
6392       endif
6393       CorrelType=477
6394       CorrelID=fg_rank+1
6395       CorrelType1=478
6396       CorrelID1=nfgtasks+fg_rank+1
6397       ireq=0
6398 C Receive the numbers of needed contacts from other processors
6399       do ii=1,ntask_cont_from
6400         iproc=itask_cont_from(ii)
6401         ireq=ireq+1
6402         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6403      &    FG_COMM,req(ireq),IERR)
6404       enddo
6405 c      write (iout,*) "IRECV ended"
6406 c      call flush(iout)
6407 C Send the number of contacts needed by other processors
6408       do ii=1,ntask_cont_to
6409         iproc=itask_cont_to(ii)
6410         ireq=ireq+1
6411         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6412      &    FG_COMM,req(ireq),IERR)
6413       enddo
6414 c      write (iout,*) "ISEND ended"
6415 c      write (iout,*) "number of requests (nn)",ireq
6416       call flush(iout)
6417       if (ireq.gt.0)
6418      &  call MPI_Waitall(ireq,req,status_array,ierr)
6419 c      write (iout,*)
6420 c     &  "Numbers of contacts to be received from other processors",
6421 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6422 c      call flush(iout)
6423 C Receive contacts
6424       ireq=0
6425       do ii=1,ntask_cont_from
6426         iproc=itask_cont_from(ii)
6427         nn=ncont_recv(ii)
6428 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6429 c     &   " of CONT_TO_COMM group"
6430         call flush(iout)
6431         if (nn.gt.0) then
6432           ireq=ireq+1
6433           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6434      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6435 c          write (iout,*) "ireq,req",ireq,req(ireq)
6436         endif
6437       enddo
6438 C Send the contacts to processors that need them
6439       do ii=1,ntask_cont_to
6440         iproc=itask_cont_to(ii)
6441         nn=ncont_sent(ii)
6442 c        write (iout,*) nn," contacts to processor",iproc,
6443 c     &   " of CONT_TO_COMM group"
6444         if (nn.gt.0) then
6445           ireq=ireq+1
6446           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6447      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6448 c          write (iout,*) "ireq,req",ireq,req(ireq)
6449 c          do i=1,nn
6450 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6451 c          enddo
6452         endif
6453       enddo
6454 c      write (iout,*) "number of requests (contacts)",ireq
6455 c      write (iout,*) "req",(req(i),i=1,4)
6456 c      call flush(iout)
6457       if (ireq.gt.0)
6458      & call MPI_Waitall(ireq,req,status_array,ierr)
6459       do iii=1,ntask_cont_from
6460         iproc=itask_cont_from(iii)
6461         nn=ncont_recv(iii)
6462         if (lprn) then
6463         write (iout,*) "Received",nn," contacts from processor",iproc,
6464      &   " of CONT_FROM_COMM group"
6465         call flush(iout)
6466         do i=1,nn
6467           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6468         enddo
6469         call flush(iout)
6470         endif
6471         do i=1,nn
6472           ii=zapas_recv(1,i,iii)
6473 c Flag the received contacts to prevent double-counting
6474           jj=-zapas_recv(2,i,iii)
6475 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6476 c          call flush(iout)
6477           nnn=num_cont_hb(ii)+1
6478           num_cont_hb(ii)=nnn
6479           jcont_hb(nnn,ii)=jj
6480           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6481           ind=3
6482           do kk=1,3
6483             ind=ind+1
6484             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6485           enddo
6486           do kk=1,2
6487             do ll=1,2
6488               ind=ind+1
6489               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6490             enddo
6491           enddo
6492           do jj=1,5
6493             do kk=1,3
6494               do ll=1,2
6495                 do mm=1,2
6496                   ind=ind+1
6497                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6498                 enddo
6499               enddo
6500             enddo
6501           enddo
6502         enddo
6503       enddo
6504       call flush(iout)
6505       if (lprn) then
6506         write (iout,'(a)') 'Contact function values after receive:'
6507         do i=nnt,nct-2
6508           write (iout,'(2i3,50(1x,i3,5f6.3))')
6509      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6510      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6511         enddo
6512         call flush(iout)
6513       endif
6514    30 continue
6515 #endif
6516       if (lprn) then
6517         write (iout,'(a)') 'Contact function values:'
6518         do i=nnt,nct-2
6519           write (iout,'(2i3,50(1x,i2,5f6.3))')
6520      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6521      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6522         enddo
6523       endif
6524       ecorr=0.0D0
6525       ecorr5=0.0d0
6526       ecorr6=0.0d0
6527 C Remove the loop below after debugging !!!
6528       do i=nnt,nct
6529         do j=1,3
6530           gradcorr(j,i)=0.0D0
6531           gradxorr(j,i)=0.0D0
6532         enddo
6533       enddo
6534 C Calculate the dipole-dipole interaction energies
6535       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6536       do i=iatel_s,iatel_e+1
6537         num_conti=num_cont_hb(i)
6538         do jj=1,num_conti
6539           j=jcont_hb(jj,i)
6540 #ifdef MOMENT
6541           call dipole(i,j,jj)
6542 #endif
6543         enddo
6544       enddo
6545       endif
6546 C Calculate the local-electrostatic correlation terms
6547 c                write (iout,*) "gradcorr5 in eello5 before loop"
6548 c                do iii=1,nres
6549 c                  write (iout,'(i5,3f10.5)')
6550 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6551 c                enddo
6552       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6553 c        write (iout,*) "corr loop i",i
6554         i1=i+1
6555         num_conti=num_cont_hb(i)
6556         num_conti1=num_cont_hb(i+1)
6557         do jj=1,num_conti
6558           j=jcont_hb(jj,i)
6559           jp=iabs(j)
6560           do kk=1,num_conti1
6561             j1=jcont_hb(kk,i1)
6562             jp1=iabs(j1)
6563 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6564 c     &         ' jj=',jj,' kk=',kk
6565 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6566             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6567      &          .or. j.lt.0 .and. j1.gt.0) .and.
6568      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6569 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6570 C The system gains extra energy.
6571               n_corr=n_corr+1
6572               sqd1=dsqrt(d_cont(jj,i))
6573               sqd2=dsqrt(d_cont(kk,i1))
6574               sred_geom = sqd1*sqd2
6575               IF (sred_geom.lt.cutoff_corr) THEN
6576                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6577      &            ekont,fprimcont)
6578 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6579 cd     &         ' jj=',jj,' kk=',kk
6580                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6581                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6582                 do l=1,3
6583                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6584                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6585                 enddo
6586                 n_corr1=n_corr1+1
6587 cd               write (iout,*) 'sred_geom=',sred_geom,
6588 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6589 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6590 cd               write (iout,*) "g_contij",g_contij
6591 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6592 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6593                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6594                 if (wcorr4.gt.0.0d0)
6595      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6596                   if (energy_dec.and.wcorr4.gt.0.0d0)
6597      1                 write (iout,'(a6,4i5,0pf7.3)')
6598      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6599 c                write (iout,*) "gradcorr5 before eello5"
6600 c                do iii=1,nres
6601 c                  write (iout,'(i5,3f10.5)')
6602 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6603 c                enddo
6604                 if (wcorr5.gt.0.0d0)
6605      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6606 c                write (iout,*) "gradcorr5 after eello5"
6607 c                do iii=1,nres
6608 c                  write (iout,'(i5,3f10.5)')
6609 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6610 c                enddo
6611                   if (energy_dec.and.wcorr5.gt.0.0d0)
6612      1                 write (iout,'(a6,4i5,0pf7.3)')
6613      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6614 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6615 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6616                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6617      &               .or. wturn6.eq.0.0d0))then
6618 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6619                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6620                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6621      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6622 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6623 cd     &            'ecorr6=',ecorr6
6624 cd                write (iout,'(4e15.5)') sred_geom,
6625 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6626 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6627 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6628                 else if (wturn6.gt.0.0d0
6629      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6630 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6631                   eturn6=eturn6+eello_turn6(i,jj,kk)
6632                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6633      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6634 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6635                 endif
6636               ENDIF
6637 1111          continue
6638             endif
6639           enddo ! kk
6640         enddo ! jj
6641       enddo ! i
6642       do i=1,nres
6643         num_cont_hb(i)=num_cont_hb_old(i)
6644       enddo
6645 c                write (iout,*) "gradcorr5 in eello5"
6646 c                do iii=1,nres
6647 c                  write (iout,'(i5,3f10.5)')
6648 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6649 c                enddo
6650       return
6651       end
6652 c------------------------------------------------------------------------------
6653       subroutine add_hb_contact_eello(ii,jj,itask)
6654       implicit real*8 (a-h,o-z)
6655       include "DIMENSIONS"
6656       include "COMMON.IOUNITS"
6657       integer max_cont
6658       integer max_dim
6659       parameter (max_cont=maxconts)
6660       parameter (max_dim=70)
6661       include "COMMON.CONTACTS"
6662       double precision zapas(max_dim,maxconts,max_fg_procs),
6663      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6664       common /przechowalnia/ zapas
6665       integer i,j,ii,jj,iproc,itask(4),nn
6666 c      write (iout,*) "itask",itask
6667       do i=1,2
6668         iproc=itask(i)
6669         if (iproc.gt.0) then
6670           do j=1,num_cont_hb(ii)
6671             jjc=jcont_hb(j,ii)
6672 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6673             if (jjc.eq.jj) then
6674               ncont_sent(iproc)=ncont_sent(iproc)+1
6675               nn=ncont_sent(iproc)
6676               zapas(1,nn,iproc)=ii
6677               zapas(2,nn,iproc)=jjc
6678               zapas(3,nn,iproc)=d_cont(j,ii)
6679               ind=3
6680               do kk=1,3
6681                 ind=ind+1
6682                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6683               enddo
6684               do kk=1,2
6685                 do ll=1,2
6686                   ind=ind+1
6687                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6688                 enddo
6689               enddo
6690               do jj=1,5
6691                 do kk=1,3
6692                   do ll=1,2
6693                     do mm=1,2
6694                       ind=ind+1
6695                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6696                     enddo
6697                   enddo
6698                 enddo
6699               enddo
6700               exit
6701             endif
6702           enddo
6703         endif
6704       enddo
6705       return
6706       end
6707 c------------------------------------------------------------------------------
6708       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6709       implicit real*8 (a-h,o-z)
6710       include 'DIMENSIONS'
6711       include 'COMMON.IOUNITS'
6712       include 'COMMON.DERIV'
6713       include 'COMMON.INTERACT'
6714       include 'COMMON.CONTACTS'
6715       double precision gx(3),gx1(3)
6716       logical lprn
6717       lprn=.false.
6718       eij=facont_hb(jj,i)
6719       ekl=facont_hb(kk,k)
6720       ees0pij=ees0p(jj,i)
6721       ees0pkl=ees0p(kk,k)
6722       ees0mij=ees0m(jj,i)
6723       ees0mkl=ees0m(kk,k)
6724       ekont=eij*ekl
6725       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6726 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6727 C Following 4 lines for diagnostics.
6728 cd    ees0pkl=0.0D0
6729 cd    ees0pij=1.0D0
6730 cd    ees0mkl=0.0D0
6731 cd    ees0mij=1.0D0
6732 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6733 c     & 'Contacts ',i,j,
6734 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6735 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6736 c     & 'gradcorr_long'
6737 C Calculate the multi-body contribution to energy.
6738 c      ecorr=ecorr+ekont*ees
6739 C Calculate multi-body contributions to the gradient.
6740       coeffpees0pij=coeffp*ees0pij
6741       coeffmees0mij=coeffm*ees0mij
6742       coeffpees0pkl=coeffp*ees0pkl
6743       coeffmees0mkl=coeffm*ees0mkl
6744       do ll=1,3
6745 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6746         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6747      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6748      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6749         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6750      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6751      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6752 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6753         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6754      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6755      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6756         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6757      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6758      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6759         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6760      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6761      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6762         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6763         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6764         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6765      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6766      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6767         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6768         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6769 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6770       enddo
6771 c      write (iout,*)
6772 cgrad      do m=i+1,j-1
6773 cgrad        do ll=1,3
6774 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6775 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6776 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6777 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6778 cgrad        enddo
6779 cgrad      enddo
6780 cgrad      do m=k+1,l-1
6781 cgrad        do ll=1,3
6782 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6783 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6784 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6785 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6786 cgrad        enddo
6787 cgrad      enddo
6788 c      write (iout,*) "ehbcorr",ekont*ees
6789       ehbcorr=ekont*ees
6790       return
6791       end
6792 #ifdef MOMENT
6793 C---------------------------------------------------------------------------
6794       subroutine dipole(i,j,jj)
6795       implicit real*8 (a-h,o-z)
6796       include 'DIMENSIONS'
6797       include 'COMMON.IOUNITS'
6798       include 'COMMON.CHAIN'
6799       include 'COMMON.FFIELD'
6800       include 'COMMON.DERIV'
6801       include 'COMMON.INTERACT'
6802       include 'COMMON.CONTACTS'
6803       include 'COMMON.TORSION'
6804       include 'COMMON.VAR'
6805       include 'COMMON.GEO'
6806       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6807      &  auxmat(2,2)
6808       iti1 = itortyp(itype(i+1))
6809       if (j.lt.nres-1) then
6810         itj1 = itortyp(itype(j+1))
6811       else
6812         itj1=ntortyp+1
6813       endif
6814       do iii=1,2
6815         dipi(iii,1)=Ub2(iii,i)
6816         dipderi(iii)=Ub2der(iii,i)
6817         dipi(iii,2)=b1(iii,iti1)
6818         dipj(iii,1)=Ub2(iii,j)
6819         dipderj(iii)=Ub2der(iii,j)
6820         dipj(iii,2)=b1(iii,itj1)
6821       enddo
6822       kkk=0
6823       do iii=1,2
6824         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6825         do jjj=1,2
6826           kkk=kkk+1
6827           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6828         enddo
6829       enddo
6830       do kkk=1,5
6831         do lll=1,3
6832           mmm=0
6833           do iii=1,2
6834             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6835      &        auxvec(1))
6836             do jjj=1,2
6837               mmm=mmm+1
6838               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6839             enddo
6840           enddo
6841         enddo
6842       enddo
6843       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6844       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6845       do iii=1,2
6846         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6847       enddo
6848       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6849       do iii=1,2
6850         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6851       enddo
6852       return
6853       end
6854 #endif
6855 C---------------------------------------------------------------------------
6856       subroutine calc_eello(i,j,k,l,jj,kk)
6857 C
6858 C This subroutine computes matrices and vectors needed to calculate
6859 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6860 C
6861       implicit real*8 (a-h,o-z)
6862       include 'DIMENSIONS'
6863       include 'COMMON.IOUNITS'
6864       include 'COMMON.CHAIN'
6865       include 'COMMON.DERIV'
6866       include 'COMMON.INTERACT'
6867       include 'COMMON.CONTACTS'
6868       include 'COMMON.TORSION'
6869       include 'COMMON.VAR'
6870       include 'COMMON.GEO'
6871       include 'COMMON.FFIELD'
6872       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6873      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6874       logical lprn
6875       common /kutas/ lprn
6876 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6877 cd     & ' jj=',jj,' kk=',kk
6878 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6879 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6880 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6881       do iii=1,2
6882         do jjj=1,2
6883           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6884           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6885         enddo
6886       enddo
6887       call transpose2(aa1(1,1),aa1t(1,1))
6888       call transpose2(aa2(1,1),aa2t(1,1))
6889       do kkk=1,5
6890         do lll=1,3
6891           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6892      &      aa1tder(1,1,lll,kkk))
6893           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6894      &      aa2tder(1,1,lll,kkk))
6895         enddo
6896       enddo
6897       if (l.eq.j+1) then
6898 C parallel orientation of the two CA-CA-CA frames.
6899         if (i.gt.1) then
6900           iti=itortyp(itype(i))
6901         else
6902           iti=ntortyp+1
6903         endif
6904         itk1=itortyp(itype(k+1))
6905         itj=itortyp(itype(j))
6906         if (l.lt.nres-1) then
6907           itl1=itortyp(itype(l+1))
6908         else
6909           itl1=ntortyp+1
6910         endif
6911 C A1 kernel(j+1) A2T
6912 cd        do iii=1,2
6913 cd          write (iout,'(3f10.5,5x,3f10.5)')
6914 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6915 cd        enddo
6916         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6917      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6918      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6919 C Following matrices are needed only for 6-th order cumulants
6920         IF (wcorr6.gt.0.0d0) THEN
6921         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6922      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6923      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6924         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6925      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6926      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6927      &   ADtEAderx(1,1,1,1,1,1))
6928         lprn=.false.
6929         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6930      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6931      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6932      &   ADtEA1derx(1,1,1,1,1,1))
6933         ENDIF
6934 C End 6-th order cumulants
6935 cd        lprn=.false.
6936 cd        if (lprn) then
6937 cd        write (2,*) 'In calc_eello6'
6938 cd        do iii=1,2
6939 cd          write (2,*) 'iii=',iii
6940 cd          do kkk=1,5
6941 cd            write (2,*) 'kkk=',kkk
6942 cd            do jjj=1,2
6943 cd              write (2,'(3(2f10.5),5x)')
6944 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6945 cd            enddo
6946 cd          enddo
6947 cd        enddo
6948 cd        endif
6949         call transpose2(EUgder(1,1,k),auxmat(1,1))
6950         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6951         call transpose2(EUg(1,1,k),auxmat(1,1))
6952         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6953         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6954         do iii=1,2
6955           do kkk=1,5
6956             do lll=1,3
6957               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6958      &          EAEAderx(1,1,lll,kkk,iii,1))
6959             enddo
6960           enddo
6961         enddo
6962 C A1T kernel(i+1) A2
6963         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6964      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6965      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6966 C Following matrices are needed only for 6-th order cumulants
6967         IF (wcorr6.gt.0.0d0) THEN
6968         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6969      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6970      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6971         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6972      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6973      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6974      &   ADtEAderx(1,1,1,1,1,2))
6975         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6976      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6977      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6978      &   ADtEA1derx(1,1,1,1,1,2))
6979         ENDIF
6980 C End 6-th order cumulants
6981         call transpose2(EUgder(1,1,l),auxmat(1,1))
6982         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6983         call transpose2(EUg(1,1,l),auxmat(1,1))
6984         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6985         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6986         do iii=1,2
6987           do kkk=1,5
6988             do lll=1,3
6989               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6990      &          EAEAderx(1,1,lll,kkk,iii,2))
6991             enddo
6992           enddo
6993         enddo
6994 C AEAb1 and AEAb2
6995 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6996 C They are needed only when the fifth- or the sixth-order cumulants are
6997 C indluded.
6998         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6999         call transpose2(AEA(1,1,1),auxmat(1,1))
7000         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7001         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7002         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7003         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7004         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7005         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7006         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7007         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7008         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7009         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7010         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7011         call transpose2(AEA(1,1,2),auxmat(1,1))
7012         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7013         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7014         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7015         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7016         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7017         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7018         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7019         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7020         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7021         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7022         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7023 C Calculate the Cartesian derivatives of the vectors.
7024         do iii=1,2
7025           do kkk=1,5
7026             do lll=1,3
7027               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7028               call matvec2(auxmat(1,1),b1(1,iti),
7029      &          AEAb1derx(1,lll,kkk,iii,1,1))
7030               call matvec2(auxmat(1,1),Ub2(1,i),
7031      &          AEAb2derx(1,lll,kkk,iii,1,1))
7032               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7033      &          AEAb1derx(1,lll,kkk,iii,2,1))
7034               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7035      &          AEAb2derx(1,lll,kkk,iii,2,1))
7036               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7037               call matvec2(auxmat(1,1),b1(1,itj),
7038      &          AEAb1derx(1,lll,kkk,iii,1,2))
7039               call matvec2(auxmat(1,1),Ub2(1,j),
7040      &          AEAb2derx(1,lll,kkk,iii,1,2))
7041               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7042      &          AEAb1derx(1,lll,kkk,iii,2,2))
7043               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7044      &          AEAb2derx(1,lll,kkk,iii,2,2))
7045             enddo
7046           enddo
7047         enddo
7048         ENDIF
7049 C End vectors
7050       else
7051 C Antiparallel orientation of the two CA-CA-CA frames.
7052         if (i.gt.1) then
7053           iti=itortyp(itype(i))
7054         else
7055           iti=ntortyp+1
7056         endif
7057         itk1=itortyp(itype(k+1))
7058         itl=itortyp(itype(l))
7059         itj=itortyp(itype(j))
7060         if (j.lt.nres-1) then
7061           itj1=itortyp(itype(j+1))
7062         else
7063           itj1=ntortyp+1
7064         endif
7065 C A2 kernel(j-1)T A1T
7066         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7067      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7068      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7069 C Following matrices are needed only for 6-th order cumulants
7070         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7071      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7072         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7073      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7074      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7075         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7076      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7077      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7078      &   ADtEAderx(1,1,1,1,1,1))
7079         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7080      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7081      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7082      &   ADtEA1derx(1,1,1,1,1,1))
7083         ENDIF
7084 C End 6-th order cumulants
7085         call transpose2(EUgder(1,1,k),auxmat(1,1))
7086         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7087         call transpose2(EUg(1,1,k),auxmat(1,1))
7088         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7089         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7090         do iii=1,2
7091           do kkk=1,5
7092             do lll=1,3
7093               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7094      &          EAEAderx(1,1,lll,kkk,iii,1))
7095             enddo
7096           enddo
7097         enddo
7098 C A2T kernel(i+1)T A1
7099         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7100      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7101      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7102 C Following matrices are needed only for 6-th order cumulants
7103         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7104      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7105         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7106      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7107      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7108         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7109      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7110      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7111      &   ADtEAderx(1,1,1,1,1,2))
7112         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7113      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7114      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7115      &   ADtEA1derx(1,1,1,1,1,2))
7116         ENDIF
7117 C End 6-th order cumulants
7118         call transpose2(EUgder(1,1,j),auxmat(1,1))
7119         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7120         call transpose2(EUg(1,1,j),auxmat(1,1))
7121         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7122         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7123         do iii=1,2
7124           do kkk=1,5
7125             do lll=1,3
7126               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7127      &          EAEAderx(1,1,lll,kkk,iii,2))
7128             enddo
7129           enddo
7130         enddo
7131 C AEAb1 and AEAb2
7132 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7133 C They are needed only when the fifth- or the sixth-order cumulants are
7134 C indluded.
7135         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7136      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7137         call transpose2(AEA(1,1,1),auxmat(1,1))
7138         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7139         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7140         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7141         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7142         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7143         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7144         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7145         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7146         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7147         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7148         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7149         call transpose2(AEA(1,1,2),auxmat(1,1))
7150         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7151         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7152         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7153         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7154         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7155         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7156         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7157         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7158         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7159         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7160         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7161 C Calculate the Cartesian derivatives of the vectors.
7162         do iii=1,2
7163           do kkk=1,5
7164             do lll=1,3
7165               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7166               call matvec2(auxmat(1,1),b1(1,iti),
7167      &          AEAb1derx(1,lll,kkk,iii,1,1))
7168               call matvec2(auxmat(1,1),Ub2(1,i),
7169      &          AEAb2derx(1,lll,kkk,iii,1,1))
7170               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7171      &          AEAb1derx(1,lll,kkk,iii,2,1))
7172               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7173      &          AEAb2derx(1,lll,kkk,iii,2,1))
7174               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7175               call matvec2(auxmat(1,1),b1(1,itl),
7176      &          AEAb1derx(1,lll,kkk,iii,1,2))
7177               call matvec2(auxmat(1,1),Ub2(1,l),
7178      &          AEAb2derx(1,lll,kkk,iii,1,2))
7179               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7180      &          AEAb1derx(1,lll,kkk,iii,2,2))
7181               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7182      &          AEAb2derx(1,lll,kkk,iii,2,2))
7183             enddo
7184           enddo
7185         enddo
7186         ENDIF
7187 C End vectors
7188       endif
7189       return
7190       end
7191 C---------------------------------------------------------------------------
7192       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7193      &  KK,KKderg,AKA,AKAderg,AKAderx)
7194       implicit none
7195       integer nderg
7196       logical transp
7197       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7198      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7199      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7200       integer iii,kkk,lll
7201       integer jjj,mmm
7202       logical lprn
7203       common /kutas/ lprn
7204       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7205       do iii=1,nderg
7206         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7207      &    AKAderg(1,1,iii))
7208       enddo
7209 cd      if (lprn) write (2,*) 'In kernel'
7210       do kkk=1,5
7211 cd        if (lprn) write (2,*) 'kkk=',kkk
7212         do lll=1,3
7213           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7214      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7215 cd          if (lprn) then
7216 cd            write (2,*) 'lll=',lll
7217 cd            write (2,*) 'iii=1'
7218 cd            do jjj=1,2
7219 cd              write (2,'(3(2f10.5),5x)')
7220 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7221 cd            enddo
7222 cd          endif
7223           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7224      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7225 cd          if (lprn) then
7226 cd            write (2,*) 'lll=',lll
7227 cd            write (2,*) 'iii=2'
7228 cd            do jjj=1,2
7229 cd              write (2,'(3(2f10.5),5x)')
7230 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7231 cd            enddo
7232 cd          endif
7233         enddo
7234       enddo
7235       return
7236       end
7237 C---------------------------------------------------------------------------
7238       double precision function eello4(i,j,k,l,jj,kk)
7239       implicit real*8 (a-h,o-z)
7240       include 'DIMENSIONS'
7241       include 'COMMON.IOUNITS'
7242       include 'COMMON.CHAIN'
7243       include 'COMMON.DERIV'
7244       include 'COMMON.INTERACT'
7245       include 'COMMON.CONTACTS'
7246       include 'COMMON.TORSION'
7247       include 'COMMON.VAR'
7248       include 'COMMON.GEO'
7249       double precision pizda(2,2),ggg1(3),ggg2(3)
7250 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7251 cd        eello4=0.0d0
7252 cd        return
7253 cd      endif
7254 cd      print *,'eello4:',i,j,k,l,jj,kk
7255 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7256 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7257 cold      eij=facont_hb(jj,i)
7258 cold      ekl=facont_hb(kk,k)
7259 cold      ekont=eij*ekl
7260       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7261 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7262       gcorr_loc(k-1)=gcorr_loc(k-1)
7263      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7264       if (l.eq.j+1) then
7265         gcorr_loc(l-1)=gcorr_loc(l-1)
7266      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7267       else
7268         gcorr_loc(j-1)=gcorr_loc(j-1)
7269      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7270       endif
7271       do iii=1,2
7272         do kkk=1,5
7273           do lll=1,3
7274             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7275      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7276 cd            derx(lll,kkk,iii)=0.0d0
7277           enddo
7278         enddo
7279       enddo
7280 cd      gcorr_loc(l-1)=0.0d0
7281 cd      gcorr_loc(j-1)=0.0d0
7282 cd      gcorr_loc(k-1)=0.0d0
7283 cd      eel4=1.0d0
7284 cd      write (iout,*)'Contacts have occurred for peptide groups',
7285 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7286 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7287       if (j.lt.nres-1) then
7288         j1=j+1
7289         j2=j-1
7290       else
7291         j1=j-1
7292         j2=j-2
7293       endif
7294       if (l.lt.nres-1) then
7295         l1=l+1
7296         l2=l-1
7297       else
7298         l1=l-1
7299         l2=l-2
7300       endif
7301       do ll=1,3
7302 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7303 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7304         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7305         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7306 cgrad        ghalf=0.5d0*ggg1(ll)
7307         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7308         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7309         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7310         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7311         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7312         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7313 cgrad        ghalf=0.5d0*ggg2(ll)
7314         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7315         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7316         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7317         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7318         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7319         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7320       enddo
7321 cgrad      do m=i+1,j-1
7322 cgrad        do ll=1,3
7323 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7324 cgrad        enddo
7325 cgrad      enddo
7326 cgrad      do m=k+1,l-1
7327 cgrad        do ll=1,3
7328 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7329 cgrad        enddo
7330 cgrad      enddo
7331 cgrad      do m=i+2,j2
7332 cgrad        do ll=1,3
7333 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7334 cgrad        enddo
7335 cgrad      enddo
7336 cgrad      do m=k+2,l2
7337 cgrad        do ll=1,3
7338 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7339 cgrad        enddo
7340 cgrad      enddo
7341 cd      do iii=1,nres-3
7342 cd        write (2,*) iii,gcorr_loc(iii)
7343 cd      enddo
7344       eello4=ekont*eel4
7345 cd      write (2,*) 'ekont',ekont
7346 cd      write (iout,*) 'eello4',ekont*eel4
7347       return
7348       end
7349 C---------------------------------------------------------------------------
7350       double precision function eello5(i,j,k,l,jj,kk)
7351       implicit real*8 (a-h,o-z)
7352       include 'DIMENSIONS'
7353       include 'COMMON.IOUNITS'
7354       include 'COMMON.CHAIN'
7355       include 'COMMON.DERIV'
7356       include 'COMMON.INTERACT'
7357       include 'COMMON.CONTACTS'
7358       include 'COMMON.TORSION'
7359       include 'COMMON.VAR'
7360       include 'COMMON.GEO'
7361       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7362       double precision ggg1(3),ggg2(3)
7363 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7364 C                                                                              C
7365 C                            Parallel chains                                   C
7366 C                                                                              C
7367 C          o             o                   o             o                   C
7368 C         /l\           / \             \   / \           / \   /              C
7369 C        /   \         /   \             \ /   \         /   \ /               C
7370 C       j| o |l1       | o |              o| o |         | o |o                C
7371 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7372 C      \i/   \         /   \ /             /   \         /   \                 C
7373 C       o    k1             o                                                  C
7374 C         (I)          (II)                (III)          (IV)                 C
7375 C                                                                              C
7376 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7377 C                                                                              C
7378 C                            Antiparallel chains                               C
7379 C                                                                              C
7380 C          o             o                   o             o                   C
7381 C         /j\           / \             \   / \           / \   /              C
7382 C        /   \         /   \             \ /   \         /   \ /               C
7383 C      j1| o |l        | o |              o| o |         | o |o                C
7384 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7385 C      \i/   \         /   \ /             /   \         /   \                 C
7386 C       o     k1            o                                                  C
7387 C         (I)          (II)                (III)          (IV)                 C
7388 C                                                                              C
7389 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7390 C                                                                              C
7391 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7392 C                                                                              C
7393 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7394 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7395 cd        eello5=0.0d0
7396 cd        return
7397 cd      endif
7398 cd      write (iout,*)
7399 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7400 cd     &   ' and',k,l
7401       itk=itortyp(itype(k))
7402       itl=itortyp(itype(l))
7403       itj=itortyp(itype(j))
7404       eello5_1=0.0d0
7405       eello5_2=0.0d0
7406       eello5_3=0.0d0
7407       eello5_4=0.0d0
7408 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7409 cd     &   eel5_3_num,eel5_4_num)
7410       do iii=1,2
7411         do kkk=1,5
7412           do lll=1,3
7413             derx(lll,kkk,iii)=0.0d0
7414           enddo
7415         enddo
7416       enddo
7417 cd      eij=facont_hb(jj,i)
7418 cd      ekl=facont_hb(kk,k)
7419 cd      ekont=eij*ekl
7420 cd      write (iout,*)'Contacts have occurred for peptide groups',
7421 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7422 cd      goto 1111
7423 C Contribution from the graph I.
7424 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7425 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7426       call transpose2(EUg(1,1,k),auxmat(1,1))
7427       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7428       vv(1)=pizda(1,1)-pizda(2,2)
7429       vv(2)=pizda(1,2)+pizda(2,1)
7430       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7431      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7432 C Explicit gradient in virtual-dihedral angles.
7433       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7434      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7435      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7436       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7437       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7438       vv(1)=pizda(1,1)-pizda(2,2)
7439       vv(2)=pizda(1,2)+pizda(2,1)
7440       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7441      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7442      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7443       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7444       vv(1)=pizda(1,1)-pizda(2,2)
7445       vv(2)=pizda(1,2)+pizda(2,1)
7446       if (l.eq.j+1) then
7447         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7448      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7449      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7450       else
7451         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7452      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7453      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7454       endif
7455 C Cartesian gradient
7456       do iii=1,2
7457         do kkk=1,5
7458           do lll=1,3
7459             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7460      &        pizda(1,1))
7461             vv(1)=pizda(1,1)-pizda(2,2)
7462             vv(2)=pizda(1,2)+pizda(2,1)
7463             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7464      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7465      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7466           enddo
7467         enddo
7468       enddo
7469 c      goto 1112
7470 c1111  continue
7471 C Contribution from graph II
7472       call transpose2(EE(1,1,itk),auxmat(1,1))
7473       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7474       vv(1)=pizda(1,1)+pizda(2,2)
7475       vv(2)=pizda(2,1)-pizda(1,2)
7476       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7477      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7478 C Explicit gradient in virtual-dihedral angles.
7479       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7480      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7481       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7482       vv(1)=pizda(1,1)+pizda(2,2)
7483       vv(2)=pizda(2,1)-pizda(1,2)
7484       if (l.eq.j+1) then
7485         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7486      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7487      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7488       else
7489         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7490      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7491      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7492       endif
7493 C Cartesian gradient
7494       do iii=1,2
7495         do kkk=1,5
7496           do lll=1,3
7497             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7498      &        pizda(1,1))
7499             vv(1)=pizda(1,1)+pizda(2,2)
7500             vv(2)=pizda(2,1)-pizda(1,2)
7501             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7502      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7503      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7504           enddo
7505         enddo
7506       enddo
7507 cd      goto 1112
7508 cd1111  continue
7509       if (l.eq.j+1) then
7510 cd        goto 1110
7511 C Parallel orientation
7512 C Contribution from graph III
7513         call transpose2(EUg(1,1,l),auxmat(1,1))
7514         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7515         vv(1)=pizda(1,1)-pizda(2,2)
7516         vv(2)=pizda(1,2)+pizda(2,1)
7517         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7518      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7519 C Explicit gradient in virtual-dihedral angles.
7520         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7521      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7522      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7523         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7524         vv(1)=pizda(1,1)-pizda(2,2)
7525         vv(2)=pizda(1,2)+pizda(2,1)
7526         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7527      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7528      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7529         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7530         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7531         vv(1)=pizda(1,1)-pizda(2,2)
7532         vv(2)=pizda(1,2)+pizda(2,1)
7533         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7534      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7535      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7536 C Cartesian gradient
7537         do iii=1,2
7538           do kkk=1,5
7539             do lll=1,3
7540               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7541      &          pizda(1,1))
7542               vv(1)=pizda(1,1)-pizda(2,2)
7543               vv(2)=pizda(1,2)+pizda(2,1)
7544               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7545      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7546      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7547             enddo
7548           enddo
7549         enddo
7550 cd        goto 1112
7551 C Contribution from graph IV
7552 cd1110    continue
7553         call transpose2(EE(1,1,itl),auxmat(1,1))
7554         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7555         vv(1)=pizda(1,1)+pizda(2,2)
7556         vv(2)=pizda(2,1)-pizda(1,2)
7557         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7558      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7559 C Explicit gradient in virtual-dihedral angles.
7560         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7561      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7562         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7563         vv(1)=pizda(1,1)+pizda(2,2)
7564         vv(2)=pizda(2,1)-pizda(1,2)
7565         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7566      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7567      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7568 C Cartesian gradient
7569         do iii=1,2
7570           do kkk=1,5
7571             do lll=1,3
7572               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7573      &          pizda(1,1))
7574               vv(1)=pizda(1,1)+pizda(2,2)
7575               vv(2)=pizda(2,1)-pizda(1,2)
7576               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7577      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7578      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7579             enddo
7580           enddo
7581         enddo
7582       else
7583 C Antiparallel orientation
7584 C Contribution from graph III
7585 c        goto 1110
7586         call transpose2(EUg(1,1,j),auxmat(1,1))
7587         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7588         vv(1)=pizda(1,1)-pizda(2,2)
7589         vv(2)=pizda(1,2)+pizda(2,1)
7590         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7591      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7592 C Explicit gradient in virtual-dihedral angles.
7593         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7594      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7595      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7596         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7597         vv(1)=pizda(1,1)-pizda(2,2)
7598         vv(2)=pizda(1,2)+pizda(2,1)
7599         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7600      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7601      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7602         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7603         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7604         vv(1)=pizda(1,1)-pizda(2,2)
7605         vv(2)=pizda(1,2)+pizda(2,1)
7606         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7607      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7608      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7609 C Cartesian gradient
7610         do iii=1,2
7611           do kkk=1,5
7612             do lll=1,3
7613               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7614      &          pizda(1,1))
7615               vv(1)=pizda(1,1)-pizda(2,2)
7616               vv(2)=pizda(1,2)+pizda(2,1)
7617               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7618      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7619      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7620             enddo
7621           enddo
7622         enddo
7623 cd        goto 1112
7624 C Contribution from graph IV
7625 1110    continue
7626         call transpose2(EE(1,1,itj),auxmat(1,1))
7627         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7628         vv(1)=pizda(1,1)+pizda(2,2)
7629         vv(2)=pizda(2,1)-pizda(1,2)
7630         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7631      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7632 C Explicit gradient in virtual-dihedral angles.
7633         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7634      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7635         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7636         vv(1)=pizda(1,1)+pizda(2,2)
7637         vv(2)=pizda(2,1)-pizda(1,2)
7638         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7639      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7640      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7641 C Cartesian gradient
7642         do iii=1,2
7643           do kkk=1,5
7644             do lll=1,3
7645               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7646      &          pizda(1,1))
7647               vv(1)=pizda(1,1)+pizda(2,2)
7648               vv(2)=pizda(2,1)-pizda(1,2)
7649               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7650      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7651      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7652             enddo
7653           enddo
7654         enddo
7655       endif
7656 1112  continue
7657       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7658 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7659 cd        write (2,*) 'ijkl',i,j,k,l
7660 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7661 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7662 cd      endif
7663 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7664 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7665 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7666 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7667       if (j.lt.nres-1) then
7668         j1=j+1
7669         j2=j-1
7670       else
7671         j1=j-1
7672         j2=j-2
7673       endif
7674       if (l.lt.nres-1) then
7675         l1=l+1
7676         l2=l-1
7677       else
7678         l1=l-1
7679         l2=l-2
7680       endif
7681 cd      eij=1.0d0
7682 cd      ekl=1.0d0
7683 cd      ekont=1.0d0
7684 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7685 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7686 C        summed up outside the subrouine as for the other subroutines
7687 C        handling long-range interactions. The old code is commented out
7688 C        with "cgrad" to keep track of changes.
7689       do ll=1,3
7690 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7691 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7692         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7693         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7694 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7695 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7696 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7697 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7698 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7699 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7700 c     &   gradcorr5ij,
7701 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7702 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7703 cgrad        ghalf=0.5d0*ggg1(ll)
7704 cd        ghalf=0.0d0
7705         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7706         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7707         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7708         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7709         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7710         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7711 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7712 cgrad        ghalf=0.5d0*ggg2(ll)
7713 cd        ghalf=0.0d0
7714         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7715         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7716         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7717         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7718         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7719         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7720       enddo
7721 cd      goto 1112
7722 cgrad      do m=i+1,j-1
7723 cgrad        do ll=1,3
7724 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7725 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7726 cgrad        enddo
7727 cgrad      enddo
7728 cgrad      do m=k+1,l-1
7729 cgrad        do ll=1,3
7730 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7731 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7732 cgrad        enddo
7733 cgrad      enddo
7734 c1112  continue
7735 cgrad      do m=i+2,j2
7736 cgrad        do ll=1,3
7737 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7738 cgrad        enddo
7739 cgrad      enddo
7740 cgrad      do m=k+2,l2
7741 cgrad        do ll=1,3
7742 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7743 cgrad        enddo
7744 cgrad      enddo
7745 cd      do iii=1,nres-3
7746 cd        write (2,*) iii,g_corr5_loc(iii)
7747 cd      enddo
7748       eello5=ekont*eel5
7749 cd      write (2,*) 'ekont',ekont
7750 cd      write (iout,*) 'eello5',ekont*eel5
7751       return
7752       end
7753 c--------------------------------------------------------------------------
7754       double precision function eello6(i,j,k,l,jj,kk)
7755       implicit real*8 (a-h,o-z)
7756       include 'DIMENSIONS'
7757       include 'COMMON.IOUNITS'
7758       include 'COMMON.CHAIN'
7759       include 'COMMON.DERIV'
7760       include 'COMMON.INTERACT'
7761       include 'COMMON.CONTACTS'
7762       include 'COMMON.TORSION'
7763       include 'COMMON.VAR'
7764       include 'COMMON.GEO'
7765       include 'COMMON.FFIELD'
7766       double precision ggg1(3),ggg2(3)
7767 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7768 cd        eello6=0.0d0
7769 cd        return
7770 cd      endif
7771 cd      write (iout,*)
7772 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7773 cd     &   ' and',k,l
7774       eello6_1=0.0d0
7775       eello6_2=0.0d0
7776       eello6_3=0.0d0
7777       eello6_4=0.0d0
7778       eello6_5=0.0d0
7779       eello6_6=0.0d0
7780 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7781 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7782       do iii=1,2
7783         do kkk=1,5
7784           do lll=1,3
7785             derx(lll,kkk,iii)=0.0d0
7786           enddo
7787         enddo
7788       enddo
7789 cd      eij=facont_hb(jj,i)
7790 cd      ekl=facont_hb(kk,k)
7791 cd      ekont=eij*ekl
7792 cd      eij=1.0d0
7793 cd      ekl=1.0d0
7794 cd      ekont=1.0d0
7795       if (l.eq.j+1) then
7796         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7797         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7798         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7799         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7800         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7801         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7802       else
7803         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7804         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7805         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7806         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7807         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7808           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7809         else
7810           eello6_5=0.0d0
7811         endif
7812         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7813       endif
7814 C If turn contributions are considered, they will be handled separately.
7815       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7816 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7817 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7818 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7819 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7820 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7821 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7822 cd      goto 1112
7823       if (j.lt.nres-1) then
7824         j1=j+1
7825         j2=j-1
7826       else
7827         j1=j-1
7828         j2=j-2
7829       endif
7830       if (l.lt.nres-1) then
7831         l1=l+1
7832         l2=l-1
7833       else
7834         l1=l-1
7835         l2=l-2
7836       endif
7837       do ll=1,3
7838 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7839 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7840 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7841 cgrad        ghalf=0.5d0*ggg1(ll)
7842 cd        ghalf=0.0d0
7843         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7844         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7845         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7846         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7847         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7848         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7849         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7850         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7851 cgrad        ghalf=0.5d0*ggg2(ll)
7852 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7853 cd        ghalf=0.0d0
7854         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7855         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7856         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7857         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7858         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7859         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7860       enddo
7861 cd      goto 1112
7862 cgrad      do m=i+1,j-1
7863 cgrad        do ll=1,3
7864 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7865 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7866 cgrad        enddo
7867 cgrad      enddo
7868 cgrad      do m=k+1,l-1
7869 cgrad        do ll=1,3
7870 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7871 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7872 cgrad        enddo
7873 cgrad      enddo
7874 cgrad1112  continue
7875 cgrad      do m=i+2,j2
7876 cgrad        do ll=1,3
7877 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7878 cgrad        enddo
7879 cgrad      enddo
7880 cgrad      do m=k+2,l2
7881 cgrad        do ll=1,3
7882 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7883 cgrad        enddo
7884 cgrad      enddo
7885 cd      do iii=1,nres-3
7886 cd        write (2,*) iii,g_corr6_loc(iii)
7887 cd      enddo
7888       eello6=ekont*eel6
7889 cd      write (2,*) 'ekont',ekont
7890 cd      write (iout,*) 'eello6',ekont*eel6
7891       return
7892       end
7893 c--------------------------------------------------------------------------
7894       double precision function eello6_graph1(i,j,k,l,imat,swap)
7895       implicit real*8 (a-h,o-z)
7896       include 'DIMENSIONS'
7897       include 'COMMON.IOUNITS'
7898       include 'COMMON.CHAIN'
7899       include 'COMMON.DERIV'
7900       include 'COMMON.INTERACT'
7901       include 'COMMON.CONTACTS'
7902       include 'COMMON.TORSION'
7903       include 'COMMON.VAR'
7904       include 'COMMON.GEO'
7905       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7906       logical swap
7907       logical lprn
7908       common /kutas/ lprn
7909 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7910 C                                                                              C
7911 C      Parallel       Antiparallel                                             C
7912 C                                                                              C
7913 C          o             o                                                     C
7914 C         /l\           /j\                                                    C
7915 C        /   \         /   \                                                   C
7916 C       /| o |         | o |\                                                  C
7917 C     \ j|/k\|  /   \  |/k\|l /                                                C
7918 C      \ /   \ /     \ /   \ /                                                 C
7919 C       o     o       o     o                                                  C
7920 C       i             i                                                        C
7921 C                                                                              C
7922 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7923       itk=itortyp(itype(k))
7924       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7925       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7926       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7927       call transpose2(EUgC(1,1,k),auxmat(1,1))
7928       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7929       vv1(1)=pizda1(1,1)-pizda1(2,2)
7930       vv1(2)=pizda1(1,2)+pizda1(2,1)
7931       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7932       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7933       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7934       s5=scalar2(vv(1),Dtobr2(1,i))
7935 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7936       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7937       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7938      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7939      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7940      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7941      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7942      & +scalar2(vv(1),Dtobr2der(1,i)))
7943       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7944       vv1(1)=pizda1(1,1)-pizda1(2,2)
7945       vv1(2)=pizda1(1,2)+pizda1(2,1)
7946       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7947       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7948       if (l.eq.j+1) then
7949         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7950      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7951      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7952      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7953      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7954       else
7955         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7956      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7957      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7958      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7959      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7960       endif
7961       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7962       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7963       vv1(1)=pizda1(1,1)-pizda1(2,2)
7964       vv1(2)=pizda1(1,2)+pizda1(2,1)
7965       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7966      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7967      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7968      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7969       do iii=1,2
7970         if (swap) then
7971           ind=3-iii
7972         else
7973           ind=iii
7974         endif
7975         do kkk=1,5
7976           do lll=1,3
7977             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7978             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7979             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7980             call transpose2(EUgC(1,1,k),auxmat(1,1))
7981             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7982      &        pizda1(1,1))
7983             vv1(1)=pizda1(1,1)-pizda1(2,2)
7984             vv1(2)=pizda1(1,2)+pizda1(2,1)
7985             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7986             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7987      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7988             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7989      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7990             s5=scalar2(vv(1),Dtobr2(1,i))
7991             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7992           enddo
7993         enddo
7994       enddo
7995       return
7996       end
7997 c----------------------------------------------------------------------------
7998       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7999       implicit real*8 (a-h,o-z)
8000       include 'DIMENSIONS'
8001       include 'COMMON.IOUNITS'
8002       include 'COMMON.CHAIN'
8003       include 'COMMON.DERIV'
8004       include 'COMMON.INTERACT'
8005       include 'COMMON.CONTACTS'
8006       include 'COMMON.TORSION'
8007       include 'COMMON.VAR'
8008       include 'COMMON.GEO'
8009       logical swap
8010       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8011      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8012       logical lprn
8013       common /kutas/ lprn
8014 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8015 C                                                                              C
8016 C      Parallel       Antiparallel                                             C
8017 C                                                                              C
8018 C          o             o                                                     C
8019 C     \   /l\           /j\   /                                                C
8020 C      \ /   \         /   \ /                                                 C
8021 C       o| o |         | o |o                                                  C
8022 C     \ j|/k\|      \  |/k\|l                                                  C
8023 C      \ /   \       \ /   \                                                   C
8024 C       o             o                                                        C
8025 C       i             i                                                        C
8026 C                                                                              C
8027 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8028 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8029 C AL 7/4/01 s1 would occur in the sixth-order moment,
8030 C           but not in a cluster cumulant
8031 #ifdef MOMENT
8032       s1=dip(1,jj,i)*dip(1,kk,k)
8033 #endif
8034       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8035       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8036       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8037       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8038       call transpose2(EUg(1,1,k),auxmat(1,1))
8039       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8040       vv(1)=pizda(1,1)-pizda(2,2)
8041       vv(2)=pizda(1,2)+pizda(2,1)
8042       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8043 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8044 #ifdef MOMENT
8045       eello6_graph2=-(s1+s2+s3+s4)
8046 #else
8047       eello6_graph2=-(s2+s3+s4)
8048 #endif
8049 c      eello6_graph2=-s3
8050 C Derivatives in gamma(i-1)
8051       if (i.gt.1) then
8052 #ifdef MOMENT
8053         s1=dipderg(1,jj,i)*dip(1,kk,k)
8054 #endif
8055         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8056         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8057         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8058         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8059 #ifdef MOMENT
8060         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8061 #else
8062         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8063 #endif
8064 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8065       endif
8066 C Derivatives in gamma(k-1)
8067 #ifdef MOMENT
8068       s1=dip(1,jj,i)*dipderg(1,kk,k)
8069 #endif
8070       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8071       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8072       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8073       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8074       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8075       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8076       vv(1)=pizda(1,1)-pizda(2,2)
8077       vv(2)=pizda(1,2)+pizda(2,1)
8078       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8079 #ifdef MOMENT
8080       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8081 #else
8082       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8083 #endif
8084 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8085 C Derivatives in gamma(j-1) or gamma(l-1)
8086       if (j.gt.1) then
8087 #ifdef MOMENT
8088         s1=dipderg(3,jj,i)*dip(1,kk,k)
8089 #endif
8090         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8091         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8092         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8093         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8094         vv(1)=pizda(1,1)-pizda(2,2)
8095         vv(2)=pizda(1,2)+pizda(2,1)
8096         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8097 #ifdef MOMENT
8098         if (swap) then
8099           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8100         else
8101           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8102         endif
8103 #endif
8104         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8105 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8106       endif
8107 C Derivatives in gamma(l-1) or gamma(j-1)
8108       if (l.gt.1) then
8109 #ifdef MOMENT
8110         s1=dip(1,jj,i)*dipderg(3,kk,k)
8111 #endif
8112         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8113         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8114         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8115         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8116         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8117         vv(1)=pizda(1,1)-pizda(2,2)
8118         vv(2)=pizda(1,2)+pizda(2,1)
8119         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8120 #ifdef MOMENT
8121         if (swap) then
8122           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8123         else
8124           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8125         endif
8126 #endif
8127         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8128 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8129       endif
8130 C Cartesian derivatives.
8131       if (lprn) then
8132         write (2,*) 'In eello6_graph2'
8133         do iii=1,2
8134           write (2,*) 'iii=',iii
8135           do kkk=1,5
8136             write (2,*) 'kkk=',kkk
8137             do jjj=1,2
8138               write (2,'(3(2f10.5),5x)')
8139      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8140             enddo
8141           enddo
8142         enddo
8143       endif
8144       do iii=1,2
8145         do kkk=1,5
8146           do lll=1,3
8147 #ifdef MOMENT
8148             if (iii.eq.1) then
8149               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8150             else
8151               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8152             endif
8153 #endif
8154             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8155      &        auxvec(1))
8156             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8157             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8158      &        auxvec(1))
8159             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8160             call transpose2(EUg(1,1,k),auxmat(1,1))
8161             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8162      &        pizda(1,1))
8163             vv(1)=pizda(1,1)-pizda(2,2)
8164             vv(2)=pizda(1,2)+pizda(2,1)
8165             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8166 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8167 #ifdef MOMENT
8168             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8169 #else
8170             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8171 #endif
8172             if (swap) then
8173               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8174             else
8175               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8176             endif
8177           enddo
8178         enddo
8179       enddo
8180       return
8181       end
8182 c----------------------------------------------------------------------------
8183       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8184       implicit real*8 (a-h,o-z)
8185       include 'DIMENSIONS'
8186       include 'COMMON.IOUNITS'
8187       include 'COMMON.CHAIN'
8188       include 'COMMON.DERIV'
8189       include 'COMMON.INTERACT'
8190       include 'COMMON.CONTACTS'
8191       include 'COMMON.TORSION'
8192       include 'COMMON.VAR'
8193       include 'COMMON.GEO'
8194       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8195       logical swap
8196 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8197 C                                                                              C
8198 C      Parallel       Antiparallel                                             C
8199 C                                                                              C
8200 C          o             o                                                     C
8201 C         /l\   /   \   /j\                                                    C
8202 C        /   \ /     \ /   \                                                   C
8203 C       /| o |o       o| o |\                                                  C
8204 C       j|/k\|  /      |/k\|l /                                                C
8205 C        /   \ /       /   \ /                                                 C
8206 C       /     o       /     o                                                  C
8207 C       i             i                                                        C
8208 C                                                                              C
8209 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8210 C
8211 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8212 C           energy moment and not to the cluster cumulant.
8213       iti=itortyp(itype(i))
8214       if (j.lt.nres-1) then
8215         itj1=itortyp(itype(j+1))
8216       else
8217         itj1=ntortyp+1
8218       endif
8219       itk=itortyp(itype(k))
8220       itk1=itortyp(itype(k+1))
8221       if (l.lt.nres-1) then
8222         itl1=itortyp(itype(l+1))
8223       else
8224         itl1=ntortyp+1
8225       endif
8226 #ifdef MOMENT
8227       s1=dip(4,jj,i)*dip(4,kk,k)
8228 #endif
8229       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8230       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8231       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8232       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8233       call transpose2(EE(1,1,itk),auxmat(1,1))
8234       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8235       vv(1)=pizda(1,1)+pizda(2,2)
8236       vv(2)=pizda(2,1)-pizda(1,2)
8237       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8238 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8239 cd     & "sum",-(s2+s3+s4)
8240 #ifdef MOMENT
8241       eello6_graph3=-(s1+s2+s3+s4)
8242 #else
8243       eello6_graph3=-(s2+s3+s4)
8244 #endif
8245 c      eello6_graph3=-s4
8246 C Derivatives in gamma(k-1)
8247       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8248       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8249       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8250       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8251 C Derivatives in gamma(l-1)
8252       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8253       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8254       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8255       vv(1)=pizda(1,1)+pizda(2,2)
8256       vv(2)=pizda(2,1)-pizda(1,2)
8257       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8258       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8259 C Cartesian derivatives.
8260       do iii=1,2
8261         do kkk=1,5
8262           do lll=1,3
8263 #ifdef MOMENT
8264             if (iii.eq.1) then
8265               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8266             else
8267               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8268             endif
8269 #endif
8270             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8271      &        auxvec(1))
8272             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8273             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8274      &        auxvec(1))
8275             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8276             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8277      &        pizda(1,1))
8278             vv(1)=pizda(1,1)+pizda(2,2)
8279             vv(2)=pizda(2,1)-pizda(1,2)
8280             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8281 #ifdef MOMENT
8282             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8283 #else
8284             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8285 #endif
8286             if (swap) then
8287               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8288             else
8289               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8290             endif
8291 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8292           enddo
8293         enddo
8294       enddo
8295       return
8296       end
8297 c----------------------------------------------------------------------------
8298       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8299       implicit real*8 (a-h,o-z)
8300       include 'DIMENSIONS'
8301       include 'COMMON.IOUNITS'
8302       include 'COMMON.CHAIN'
8303       include 'COMMON.DERIV'
8304       include 'COMMON.INTERACT'
8305       include 'COMMON.CONTACTS'
8306       include 'COMMON.TORSION'
8307       include 'COMMON.VAR'
8308       include 'COMMON.GEO'
8309       include 'COMMON.FFIELD'
8310       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8311      & auxvec1(2),auxmat1(2,2)
8312       logical swap
8313 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8314 C                                                                              C
8315 C      Parallel       Antiparallel                                             C
8316 C                                                                              C
8317 C          o             o                                                     C
8318 C         /l\   /   \   /j\                                                    C
8319 C        /   \ /     \ /   \                                                   C
8320 C       /| o |o       o| o |\                                                  C
8321 C     \ j|/k\|      \  |/k\|l                                                  C
8322 C      \ /   \       \ /   \                                                   C
8323 C       o     \       o     \                                                  C
8324 C       i             i                                                        C
8325 C                                                                              C
8326 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8327 C
8328 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8329 C           energy moment and not to the cluster cumulant.
8330 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8331       iti=itortyp(itype(i))
8332       itj=itortyp(itype(j))
8333       if (j.lt.nres-1) then
8334         itj1=itortyp(itype(j+1))
8335       else
8336         itj1=ntortyp+1
8337       endif
8338       itk=itortyp(itype(k))
8339       if (k.lt.nres-1) then
8340         itk1=itortyp(itype(k+1))
8341       else
8342         itk1=ntortyp+1
8343       endif
8344       itl=itortyp(itype(l))
8345       if (l.lt.nres-1) then
8346         itl1=itortyp(itype(l+1))
8347       else
8348         itl1=ntortyp+1
8349       endif
8350 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8351 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8352 cd     & ' itl',itl,' itl1',itl1
8353 #ifdef MOMENT
8354       if (imat.eq.1) then
8355         s1=dip(3,jj,i)*dip(3,kk,k)
8356       else
8357         s1=dip(2,jj,j)*dip(2,kk,l)
8358       endif
8359 #endif
8360       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8361       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8362       if (j.eq.l+1) then
8363         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8364         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8365       else
8366         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8367         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8368       endif
8369       call transpose2(EUg(1,1,k),auxmat(1,1))
8370       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8371       vv(1)=pizda(1,1)-pizda(2,2)
8372       vv(2)=pizda(2,1)+pizda(1,2)
8373       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8374 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8375 #ifdef MOMENT
8376       eello6_graph4=-(s1+s2+s3+s4)
8377 #else
8378       eello6_graph4=-(s2+s3+s4)
8379 #endif
8380 C Derivatives in gamma(i-1)
8381       if (i.gt.1) then
8382 #ifdef MOMENT
8383         if (imat.eq.1) then
8384           s1=dipderg(2,jj,i)*dip(3,kk,k)
8385         else
8386           s1=dipderg(4,jj,j)*dip(2,kk,l)
8387         endif
8388 #endif
8389         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8390         if (j.eq.l+1) then
8391           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8392           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8393         else
8394           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8395           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8396         endif
8397         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8398         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8399 cd          write (2,*) 'turn6 derivatives'
8400 #ifdef MOMENT
8401           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8402 #else
8403           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8404 #endif
8405         else
8406 #ifdef MOMENT
8407           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8408 #else
8409           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8410 #endif
8411         endif
8412       endif
8413 C Derivatives in gamma(k-1)
8414 #ifdef MOMENT
8415       if (imat.eq.1) then
8416         s1=dip(3,jj,i)*dipderg(2,kk,k)
8417       else
8418         s1=dip(2,jj,j)*dipderg(4,kk,l)
8419       endif
8420 #endif
8421       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8422       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8423       if (j.eq.l+1) then
8424         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8425         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8426       else
8427         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8428         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8429       endif
8430       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8431       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8432       vv(1)=pizda(1,1)-pizda(2,2)
8433       vv(2)=pizda(2,1)+pizda(1,2)
8434       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8435       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8436 #ifdef MOMENT
8437         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8438 #else
8439         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8440 #endif
8441       else
8442 #ifdef MOMENT
8443         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8444 #else
8445         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8446 #endif
8447       endif
8448 C Derivatives in gamma(j-1) or gamma(l-1)
8449       if (l.eq.j+1 .and. l.gt.1) then
8450         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8451         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8452         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8453         vv(1)=pizda(1,1)-pizda(2,2)
8454         vv(2)=pizda(2,1)+pizda(1,2)
8455         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8456         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8457       else if (j.gt.1) then
8458         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8459         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8460         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8461         vv(1)=pizda(1,1)-pizda(2,2)
8462         vv(2)=pizda(2,1)+pizda(1,2)
8463         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8464         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8465           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8466         else
8467           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8468         endif
8469       endif
8470 C Cartesian derivatives.
8471       do iii=1,2
8472         do kkk=1,5
8473           do lll=1,3
8474 #ifdef MOMENT
8475             if (iii.eq.1) then
8476               if (imat.eq.1) then
8477                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8478               else
8479                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8480               endif
8481             else
8482               if (imat.eq.1) then
8483                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8484               else
8485                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8486               endif
8487             endif
8488 #endif
8489             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8490      &        auxvec(1))
8491             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8492             if (j.eq.l+1) then
8493               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8494      &          b1(1,itj1),auxvec(1))
8495               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8496             else
8497               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8498      &          b1(1,itl1),auxvec(1))
8499               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8500             endif
8501             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8502      &        pizda(1,1))
8503             vv(1)=pizda(1,1)-pizda(2,2)
8504             vv(2)=pizda(2,1)+pizda(1,2)
8505             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8506             if (swap) then
8507               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8508 #ifdef MOMENT
8509                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8510      &             -(s1+s2+s4)
8511 #else
8512                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8513      &             -(s2+s4)
8514 #endif
8515                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8516               else
8517 #ifdef MOMENT
8518                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8519 #else
8520                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8521 #endif
8522                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8523               endif
8524             else
8525 #ifdef MOMENT
8526               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8527 #else
8528               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8529 #endif
8530               if (l.eq.j+1) then
8531                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8532               else
8533                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8534               endif
8535             endif
8536           enddo
8537         enddo
8538       enddo
8539       return
8540       end
8541 c----------------------------------------------------------------------------
8542       double precision function eello_turn6(i,jj,kk)
8543       implicit real*8 (a-h,o-z)
8544       include 'DIMENSIONS'
8545       include 'COMMON.IOUNITS'
8546       include 'COMMON.CHAIN'
8547       include 'COMMON.DERIV'
8548       include 'COMMON.INTERACT'
8549       include 'COMMON.CONTACTS'
8550       include 'COMMON.TORSION'
8551       include 'COMMON.VAR'
8552       include 'COMMON.GEO'
8553       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8554      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8555      &  ggg1(3),ggg2(3)
8556       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8557      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8558 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8559 C           the respective energy moment and not to the cluster cumulant.
8560       s1=0.0d0
8561       s8=0.0d0
8562       s13=0.0d0
8563 c
8564       eello_turn6=0.0d0
8565       j=i+4
8566       k=i+1
8567       l=i+3
8568       iti=itortyp(itype(i))
8569       itk=itortyp(itype(k))
8570       itk1=itortyp(itype(k+1))
8571       itl=itortyp(itype(l))
8572       itj=itortyp(itype(j))
8573 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8574 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8575 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8576 cd        eello6=0.0d0
8577 cd        return
8578 cd      endif
8579 cd      write (iout,*)
8580 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8581 cd     &   ' and',k,l
8582 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8583       do iii=1,2
8584         do kkk=1,5
8585           do lll=1,3
8586             derx_turn(lll,kkk,iii)=0.0d0
8587           enddo
8588         enddo
8589       enddo
8590 cd      eij=1.0d0
8591 cd      ekl=1.0d0
8592 cd      ekont=1.0d0
8593       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8594 cd      eello6_5=0.0d0
8595 cd      write (2,*) 'eello6_5',eello6_5
8596 #ifdef MOMENT
8597       call transpose2(AEA(1,1,1),auxmat(1,1))
8598       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8599       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8600       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8601 #endif
8602       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8603       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8604       s2 = scalar2(b1(1,itk),vtemp1(1))
8605 #ifdef MOMENT
8606       call transpose2(AEA(1,1,2),atemp(1,1))
8607       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8608       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8609       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8610 #endif
8611       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8612       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8613       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8614 #ifdef MOMENT
8615       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8616       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8617       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8618       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8619       ss13 = scalar2(b1(1,itk),vtemp4(1))
8620       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8621 #endif
8622 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8623 c      s1=0.0d0
8624 c      s2=0.0d0
8625 c      s8=0.0d0
8626 c      s12=0.0d0
8627 c      s13=0.0d0
8628       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8629 C Derivatives in gamma(i+2)
8630       s1d =0.0d0
8631       s8d =0.0d0
8632 #ifdef MOMENT
8633       call transpose2(AEA(1,1,1),auxmatd(1,1))
8634       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8635       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8636       call transpose2(AEAderg(1,1,2),atempd(1,1))
8637       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8638       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8639 #endif
8640       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8641       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8642       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8643 c      s1d=0.0d0
8644 c      s2d=0.0d0
8645 c      s8d=0.0d0
8646 c      s12d=0.0d0
8647 c      s13d=0.0d0
8648       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8649 C Derivatives in gamma(i+3)
8650 #ifdef MOMENT
8651       call transpose2(AEA(1,1,1),auxmatd(1,1))
8652       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8653       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8654       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8655 #endif
8656       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8657       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8658       s2d = scalar2(b1(1,itk),vtemp1d(1))
8659 #ifdef MOMENT
8660       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8661       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8662 #endif
8663       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8664 #ifdef MOMENT
8665       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8666       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8667       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8668 #endif
8669 c      s1d=0.0d0
8670 c      s2d=0.0d0
8671 c      s8d=0.0d0
8672 c      s12d=0.0d0
8673 c      s13d=0.0d0
8674 #ifdef MOMENT
8675       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8676      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8677 #else
8678       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8679      &               -0.5d0*ekont*(s2d+s12d)
8680 #endif
8681 C Derivatives in gamma(i+4)
8682       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8683       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8684       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8685 #ifdef MOMENT
8686       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8687       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8688       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8689 #endif
8690 c      s1d=0.0d0
8691 c      s2d=0.0d0
8692 c      s8d=0.0d0
8693 C      s12d=0.0d0
8694 c      s13d=0.0d0
8695 #ifdef MOMENT
8696       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8697 #else
8698       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8699 #endif
8700 C Derivatives in gamma(i+5)
8701 #ifdef MOMENT
8702       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8703       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8704       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8705 #endif
8706       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8707       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8708       s2d = scalar2(b1(1,itk),vtemp1d(1))
8709 #ifdef MOMENT
8710       call transpose2(AEA(1,1,2),atempd(1,1))
8711       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8712       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8713 #endif
8714       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8715       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8716 #ifdef MOMENT
8717       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8718       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8719       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8720 #endif
8721 c      s1d=0.0d0
8722 c      s2d=0.0d0
8723 c      s8d=0.0d0
8724 c      s12d=0.0d0
8725 c      s13d=0.0d0
8726 #ifdef MOMENT
8727       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8728      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8729 #else
8730       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8731      &               -0.5d0*ekont*(s2d+s12d)
8732 #endif
8733 C Cartesian derivatives
8734       do iii=1,2
8735         do kkk=1,5
8736           do lll=1,3
8737 #ifdef MOMENT
8738             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8739             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8740             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8741 #endif
8742             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8743             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8744      &          vtemp1d(1))
8745             s2d = scalar2(b1(1,itk),vtemp1d(1))
8746 #ifdef MOMENT
8747             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8748             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8749             s8d = -(atempd(1,1)+atempd(2,2))*
8750      &           scalar2(cc(1,1,itl),vtemp2(1))
8751 #endif
8752             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8753      &           auxmatd(1,1))
8754             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8755             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8756 c      s1d=0.0d0
8757 c      s2d=0.0d0
8758 c      s8d=0.0d0
8759 c      s12d=0.0d0
8760 c      s13d=0.0d0
8761 #ifdef MOMENT
8762             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8763      &        - 0.5d0*(s1d+s2d)
8764 #else
8765             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8766      &        - 0.5d0*s2d
8767 #endif
8768 #ifdef MOMENT
8769             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8770      &        - 0.5d0*(s8d+s12d)
8771 #else
8772             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8773      &        - 0.5d0*s12d
8774 #endif
8775           enddo
8776         enddo
8777       enddo
8778 #ifdef MOMENT
8779       do kkk=1,5
8780         do lll=1,3
8781           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8782      &      achuj_tempd(1,1))
8783           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8784           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8785           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8786           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8787           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8788      &      vtemp4d(1))
8789           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8790           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8791           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8792         enddo
8793       enddo
8794 #endif
8795 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8796 cd     &  16*eel_turn6_num
8797 cd      goto 1112
8798       if (j.lt.nres-1) then
8799         j1=j+1
8800         j2=j-1
8801       else
8802         j1=j-1
8803         j2=j-2
8804       endif
8805       if (l.lt.nres-1) then
8806         l1=l+1
8807         l2=l-1
8808       else
8809         l1=l-1
8810         l2=l-2
8811       endif
8812       do ll=1,3
8813 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8814 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8815 cgrad        ghalf=0.5d0*ggg1(ll)
8816 cd        ghalf=0.0d0
8817         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8818         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8819         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8820      &    +ekont*derx_turn(ll,2,1)
8821         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8822         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8823      &    +ekont*derx_turn(ll,4,1)
8824         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8825         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8826         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8827 cgrad        ghalf=0.5d0*ggg2(ll)
8828 cd        ghalf=0.0d0
8829         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8830      &    +ekont*derx_turn(ll,2,2)
8831         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8832         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8833      &    +ekont*derx_turn(ll,4,2)
8834         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8835         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8836         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8837       enddo
8838 cd      goto 1112
8839 cgrad      do m=i+1,j-1
8840 cgrad        do ll=1,3
8841 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8842 cgrad        enddo
8843 cgrad      enddo
8844 cgrad      do m=k+1,l-1
8845 cgrad        do ll=1,3
8846 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8847 cgrad        enddo
8848 cgrad      enddo
8849 cgrad1112  continue
8850 cgrad      do m=i+2,j2
8851 cgrad        do ll=1,3
8852 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8853 cgrad        enddo
8854 cgrad      enddo
8855 cgrad      do m=k+2,l2
8856 cgrad        do ll=1,3
8857 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8858 cgrad        enddo
8859 cgrad      enddo
8860 cd      do iii=1,nres-3
8861 cd        write (2,*) iii,g_corr6_loc(iii)
8862 cd      enddo
8863       eello_turn6=ekont*eel_turn6
8864 cd      write (2,*) 'ekont',ekont
8865 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8866       return
8867       end
8868
8869 C-----------------------------------------------------------------------------
8870       double precision function scalar(u,v)
8871 !DIR$ INLINEALWAYS scalar
8872 #ifndef OSF
8873 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8874 #endif
8875       implicit none
8876       double precision u(3),v(3)
8877 cd      double precision sc
8878 cd      integer i
8879 cd      sc=0.0d0
8880 cd      do i=1,3
8881 cd        sc=sc+u(i)*v(i)
8882 cd      enddo
8883 cd      scalar=sc
8884
8885       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8886       return
8887       end
8888 crc-------------------------------------------------
8889       SUBROUTINE MATVEC2(A1,V1,V2)
8890 !DIR$ INLINEALWAYS MATVEC2
8891 #ifndef OSF
8892 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8893 #endif
8894       implicit real*8 (a-h,o-z)
8895       include 'DIMENSIONS'
8896       DIMENSION A1(2,2),V1(2),V2(2)
8897 c      DO 1 I=1,2
8898 c        VI=0.0
8899 c        DO 3 K=1,2
8900 c    3     VI=VI+A1(I,K)*V1(K)
8901 c        Vaux(I)=VI
8902 c    1 CONTINUE
8903
8904       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8905       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8906
8907       v2(1)=vaux1
8908       v2(2)=vaux2
8909       END
8910 C---------------------------------------
8911       SUBROUTINE MATMAT2(A1,A2,A3)
8912 #ifndef OSF
8913 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8914 #endif
8915       implicit real*8 (a-h,o-z)
8916       include 'DIMENSIONS'
8917       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8918 c      DIMENSION AI3(2,2)
8919 c        DO  J=1,2
8920 c          A3IJ=0.0
8921 c          DO K=1,2
8922 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8923 c          enddo
8924 c          A3(I,J)=A3IJ
8925 c       enddo
8926 c      enddo
8927
8928       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8929       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8930       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8931       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8932
8933       A3(1,1)=AI3_11
8934       A3(2,1)=AI3_21
8935       A3(1,2)=AI3_12
8936       A3(2,2)=AI3_22
8937       END
8938
8939 c-------------------------------------------------------------------------
8940       double precision function scalar2(u,v)
8941 !DIR$ INLINEALWAYS scalar2
8942       implicit none
8943       double precision u(2),v(2)
8944       double precision sc
8945       integer i
8946       scalar2=u(1)*v(1)+u(2)*v(2)
8947       return
8948       end
8949
8950 C-----------------------------------------------------------------------------
8951
8952       subroutine transpose2(a,at)
8953 !DIR$ INLINEALWAYS transpose2
8954 #ifndef OSF
8955 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8956 #endif
8957       implicit none
8958       double precision a(2,2),at(2,2)
8959       at(1,1)=a(1,1)
8960       at(1,2)=a(2,1)
8961       at(2,1)=a(1,2)
8962       at(2,2)=a(2,2)
8963       return
8964       end
8965 c--------------------------------------------------------------------------
8966       subroutine transpose(n,a,at)
8967       implicit none
8968       integer n,i,j
8969       double precision a(n,n),at(n,n)
8970       do i=1,n
8971         do j=1,n
8972           at(j,i)=a(i,j)
8973         enddo
8974       enddo
8975       return
8976       end
8977 C---------------------------------------------------------------------------
8978       subroutine prodmat3(a1,a2,kk,transp,prod)
8979 !DIR$ INLINEALWAYS prodmat3
8980 #ifndef OSF
8981 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8982 #endif
8983       implicit none
8984       integer i,j
8985       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8986       logical transp
8987 crc      double precision auxmat(2,2),prod_(2,2)
8988
8989       if (transp) then
8990 crc        call transpose2(kk(1,1),auxmat(1,1))
8991 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8992 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8993
8994            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8995      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8996            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8997      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8998            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8999      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9000            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9001      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9002
9003       else
9004 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9005 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9006
9007            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9008      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9009            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9010      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9011            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9012      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9013            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9014      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9015
9016       endif
9017 c      call transpose2(a2(1,1),a2t(1,1))
9018
9019 crc      print *,transp
9020 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9021 crc      print *,((prod(i,j),i=1,2),j=1,2)
9022
9023       return
9024       end
9025