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 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.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 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 c      print *," Processor",myrank," calls SUM_ENERGY"
 305       call sum_energy(energia,.true.)
 306       if (dyn_ss) call dyn_set_nss
 307 c      print *," Processor",myrank," left SUM_ENERGY"
 308 #ifdef TIMING
 309       time_sumene=time_sumene+MPI_Wtime()-time00
 310 #endif
 311       return
 312       end
 313 c-------------------------------------------------------------------------------
 314       subroutine sum_energy(energia,reduce)
 315       implicit real*8 (a-h,o-z)
 316       include 'DIMENSIONS'
 317 #ifndef ISNAN
 318       external proc_proc
 319 #ifdef WINPGI
 320 cMS$ATTRIBUTES C ::  proc_proc
 321 #endif
 322 #endif
 323 #ifdef MPI
 324       include "mpif.h"
 325 #endif
 326       include 'COMMON.SETUP'
 327       include 'COMMON.IOUNITS'
 328       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 329       include 'COMMON.FFIELD'
 330       include 'COMMON.DERIV'
 331       include 'COMMON.INTERACT'
 332       include 'COMMON.SBRIDGE'
 333       include 'COMMON.CHAIN'
 334       include 'COMMON.VAR'
 335       include 'COMMON.CONTROL'
 336       include 'COMMON.TIME1'
 337       logical reduce
 338 #ifdef MPI
 339       if (nfgtasks.gt.1 .and. reduce) then
 340 #ifdef DEBUG
 341         write (iout,*) "energies before REDUCE"
 342         call enerprint(energia)
 343         call flush(iout)
 344 #endif
 345         do i=0,n_ene
 346           enebuff(i)=energia(i)
 347         enddo
 348         time00=MPI_Wtime()
 349         call MPI_Barrier(FG_COMM,IERR)
 350         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 351         time00=MPI_Wtime()
 352         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 353      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 354 #ifdef DEBUG
 355         write (iout,*) "energies after REDUCE"
 356         call enerprint(energia)
 357         call flush(iout)
 358 #endif
 359         time_Reduce=time_Reduce+MPI_Wtime()-time00
 360       endif
 361       if (fg_rank.eq.0) then
 362 #endif
 363       evdw=energia(1)
 364 #ifdef SCP14
 365       evdw2=energia(2)+energia(18)
 366       evdw2_14=energia(18)
 367 #else
 368       evdw2=energia(2)
 369 #endif
 370 #ifdef SPLITELE
 371       ees=energia(3)
 372       evdw1=energia(16)
 373 #else
 374       ees=energia(3)
 375       evdw1=0.0d0
 376 #endif
 377       ecorr=energia(4)
 378       ecorr5=energia(5)
 379       ecorr6=energia(6)
 380       eel_loc=energia(7)
 381       eello_turn3=energia(8)
 382       eello_turn4=energia(9)
 383       eturn6=energia(10)
 384       ebe=energia(11)
 385       escloc=energia(12)
 386       etors=energia(13)
 387       etors_d=energia(14)
 388       ehpb=energia(15)
 389       edihcnstr=energia(19)
 390       estr=energia(17)
 391       Uconst=energia(20)
 392       esccor=energia(21)
 393 #ifdef SPLITELE
 394       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 395      & +wang*ebe+wtor*etors+wscloc*escloc
 396      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 397      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 398      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 399      & +wbond*estr+Uconst+wsccor*esccor
 400 #else
 401       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 402      & +wang*ebe+wtor*etors+wscloc*escloc
 403      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 404      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 405      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 406      & +wbond*estr+Uconst+wsccor*esccor
 407 #endif
 408       energia(0)=etot
 409 c detecting NaNQ
 410 #ifdef ISNAN
 411 #ifdef AIX
 412       if (isnan(etot).ne.0) energia(0)=1.0d+99
 413 #else
 414       if (isnan(etot)) energia(0)=1.0d+99
 415 #endif
 416 #else
 417       i=0
 418 #ifdef WINPGI
 419       idumm=proc_proc(etot,i)
 420 #else
 421       call proc_proc(etot,i)
 422 #endif
 423       if(i.eq.1)energia(0)=1.0d+99
 424 #endif
 425 #ifdef MPI
 426       endif
 427 #endif
 428       return
 429       end
 430 c-------------------------------------------------------------------------------
 431       subroutine sum_gradient
 432       implicit real*8 (a-h,o-z)
 433       include 'DIMENSIONS'
 434 #ifndef ISNAN
 435       external proc_proc
 436 #ifdef WINPGI
 437 cMS$ATTRIBUTES C ::  proc_proc
 438 #endif
 439 #endif
 440 #ifdef MPI
 441       include 'mpif.h'
 442 #endif
 443       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 444      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 445 #endif
 446       include 'COMMON.SETUP'
 447       include 'COMMON.IOUNITS'
 448       include 'COMMON.FFIELD'
 449       include 'COMMON.DERIV'
 450       include 'COMMON.INTERACT'
 451       include 'COMMON.SBRIDGE'
 452       include 'COMMON.CHAIN'
 453       include 'COMMON.VAR'
 454       include 'COMMON.CONTROL'
 455       include 'COMMON.TIME1'
 456       include 'COMMON.MAXGRAD'
 457       include 'COMMON.SCCOR'
 458 #ifdef TIMING
 459       time01=MPI_Wtime()
 460 #endif
 461 #ifdef DEBUG
 462       write (iout,*) "sum_gradient gvdwc, gvdwx"
 463       do i=1,nres
 464         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 465      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 466       enddo
 467       call flush(iout)
 468 #endif
 469 #ifdef MPI
 470 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 471         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 472      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 473 #endif
 474 C
 475 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 476 C            in virtual-bond-vector coordinates
 477 C
 478 #ifdef DEBUG
 479 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 482 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 483 c      enddo
 484 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 485 c      do i=1,nres-1
 486 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 487 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 488 c      enddo
 489       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 490       do i=1,nres
 491         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 492      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 493      &   g_corr5_loc(i)
 494       enddo
 495       call flush(iout)
 496 #endif
 497 #ifdef SPLITELE
 498       do i=1,nct
 499         do j=1,3
 500           gradbufc(j,i)=wsc*gvdwc(j,i)+
 501      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 502      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 503      &                wel_loc*gel_loc_long(j,i)+
 504      &                wcorr*gradcorr_long(j,i)+
 505      &                wcorr5*gradcorr5_long(j,i)+
 506      &                wcorr6*gradcorr6_long(j,i)+
 507      &                wturn6*gcorr6_turn_long(j,i)+
 508      &                wstrain*ghpbc(j,i)
 509         enddo
 510       enddo
 511 #else
 512       do i=1,nct
 513         do j=1,3
 514           gradbufc(j,i)=wsc*gvdwc(j,i)+
 515      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 516      &                welec*gelc_long(j,i)+
 517      &                wbond*gradb(j,i)+
 518      &                wel_loc*gel_loc_long(j,i)+
 519      &                wcorr*gradcorr_long(j,i)+
 520      &                wcorr5*gradcorr5_long(j,i)+
 521      &                wcorr6*gradcorr6_long(j,i)+
 522      &                wturn6*gcorr6_turn_long(j,i)+
 523      &                wstrain*ghpbc(j,i)
 524         enddo
 525       enddo
 526 #endif
 527 #ifdef MPI
 528       if (nfgtasks.gt.1) then
 529       time00=MPI_Wtime()
 530 #ifdef DEBUG
 531       write (iout,*) "gradbufc before allreduce"
 532       do i=1,nres
 533         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 534       enddo
 535       call flush(iout)
 536 #endif
 537       do i=1,nres
 538         do j=1,3
 539           gradbufc_sum(j,i)=gradbufc(j,i)
 540         enddo
 541       enddo
 542 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 543 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 544 c      time_reduce=time_reduce+MPI_Wtime()-time00
 545 #ifdef DEBUG
 546 c      write (iout,*) "gradbufc_sum after allreduce"
 547 c      do i=1,nres
 548 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 549 c      enddo
 550 c      call flush(iout)
 551 #endif
 552 #ifdef TIMING
 553 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 554 #endif
 555       do i=nnt,nres
 556         do k=1,3
 557           gradbufc(k,i)=0.0d0
 558         enddo
 559       enddo
 560 #ifdef DEBUG
 561       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 562       write (iout,*) (i," jgrad_start",jgrad_start(i),
 563      &                  " jgrad_end  ",jgrad_end(i),
 564      &                  i=igrad_start,igrad_end)
 565 #endif
 566 c
 567 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 568 c do not parallelize this part.
 569 c
 570 c      do i=igrad_start,igrad_end
 571 c        do j=jgrad_start(i),jgrad_end(i)
 572 c          do k=1,3
 573 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 574 c          enddo
 575 c        enddo
 576 c      enddo
 577       do j=1,3
 578         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 579       enddo
 580       do i=nres-2,nnt,-1
 581         do j=1,3
 582           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 583         enddo
 584       enddo
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc after summing"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       else
 593 #endif
 594 #ifdef DEBUG
 595       write (iout,*) "gradbufc"
 596       do i=1,nres
 597         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 598       enddo
 599       call flush(iout)
 600 #endif
 601       do i=1,nres
 602         do j=1,3
 603           gradbufc_sum(j,i)=gradbufc(j,i)
 604           gradbufc(j,i)=0.0d0
 605         enddo
 606       enddo
 607       do j=1,3
 608         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 609       enddo
 610       do i=nres-2,nnt,-1
 611         do j=1,3
 612           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 613         enddo
 614       enddo
 615 c      do i=nnt,nres-1
 616 c        do k=1,3
 617 c          gradbufc(k,i)=0.0d0
 618 c        enddo
 619 c        do j=i+1,nres
 620 c          do k=1,3
 621 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 622 c          enddo
 623 c        enddo
 624 c      enddo
 625 #ifdef DEBUG
 626       write (iout,*) "gradbufc after summing"
 627       do i=1,nres
 628         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632 #ifdef MPI
 633       endif
 634 #endif
 635       do k=1,3
 636         gradbufc(k,nres)=0.0d0
 637       enddo
 638       do i=1,nct
 639         do j=1,3
 640 #ifdef SPLITELE
 641           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 642      &                wel_loc*gel_loc(j,i)+
 643      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 644      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 645      &                wel_loc*gel_loc_long(j,i)+
 646      &                wcorr*gradcorr_long(j,i)+
 647      &                wcorr5*gradcorr5_long(j,i)+
 648      &                wcorr6*gradcorr6_long(j,i)+
 649      &                wturn6*gcorr6_turn_long(j,i))+
 650      &                wbond*gradb(j,i)+
 651      &                wcorr*gradcorr(j,i)+
 652      &                wturn3*gcorr3_turn(j,i)+
 653      &                wturn4*gcorr4_turn(j,i)+
 654      &                wcorr5*gradcorr5(j,i)+
 655      &                wcorr6*gradcorr6(j,i)+
 656      &                wturn6*gcorr6_turn(j,i)+
 657      &                wsccor*gsccorc(j,i)
 658      &               +wscloc*gscloc(j,i)
 659 #else
 660           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 661      &                wel_loc*gel_loc(j,i)+
 662      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 663      &                welec*gelc_long(j,i)
 664      &                wel_loc*gel_loc_long(j,i)+
 665      &                wcorr*gcorr_long(j,i)+
 666      &                wcorr5*gradcorr5_long(j,i)+
 667      &                wcorr6*gradcorr6_long(j,i)+
 668      &                wturn6*gcorr6_turn_long(j,i))+
 669      &                wbond*gradb(j,i)+
 670      &                wcorr*gradcorr(j,i)+
 671      &                wturn3*gcorr3_turn(j,i)+
 672      &                wturn4*gcorr4_turn(j,i)+
 673      &                wcorr5*gradcorr5(j,i)+
 674      &                wcorr6*gradcorr6(j,i)+
 675      &                wturn6*gcorr6_turn(j,i)+
 676      &                wsccor*gsccorc(j,i)
 677      &               +wscloc*gscloc(j,i)
 678 #endif
 679           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 680      &                  wbond*gradbx(j,i)+
 681      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 682      &                  wsccor*gsccorx(j,i)
 683      &                 +wscloc*gsclocx(j,i)
 684         enddo
 685       enddo
 686 #ifdef DEBUG
 687       write (iout,*) "gloc before adding corr"
 688       do i=1,4*nres
 689         write (iout,*) i,gloc(i,icg)
 690       enddo
 691 #endif
 692       do i=1,nres-3
 693         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 694      &   +wcorr5*g_corr5_loc(i)
 695      &   +wcorr6*g_corr6_loc(i)
 696      &   +wturn4*gel_loc_turn4(i)
 697      &   +wturn3*gel_loc_turn3(i)
 698      &   +wturn6*gel_loc_turn6(i)
 699      &   +wel_loc*gel_loc_loc(i)
 700       enddo
 701 #ifdef DEBUG
 702       write (iout,*) "gloc after adding corr"
 703       do i=1,4*nres
 704         write (iout,*) i,gloc(i,icg)
 705       enddo
 706 #endif
 707 #ifdef MPI
 708       if (nfgtasks.gt.1) then
 709         do j=1,3
 710           do i=1,nres
 711             gradbufc(j,i)=gradc(j,i,icg)
 712             gradbufx(j,i)=gradx(j,i,icg)
 713           enddo
 714         enddo
 715         do i=1,4*nres
 716           glocbuf(i)=gloc(i,icg)
 717         enddo
 718 #define DEBUG
 719 #ifdef DEBUG
 720       write (iout,*) "gloc_sc before reduce"
 721       do i=1,nres
 722        do j=1,1
 723         write (iout,*) i,j,gloc_sc(j,i,icg)
 724        enddo
 725       enddo
 726 #endif
 727 #undef DEBUG
 728         do i=1,nres
 729          do j=1,3
 730           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 731          enddo
 732         enddo
 733         time00=MPI_Wtime()
 734         call MPI_Barrier(FG_COMM,IERR)
 735         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 736         time00=MPI_Wtime()
 737         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 738      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 739         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         time_reduce=time_reduce+MPI_Wtime()-time00
 744         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 745      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 746         time_reduce=time_reduce+MPI_Wtime()-time00
 747 #define DEBUG
 748 #ifdef DEBUG
 749       write (iout,*) "gloc_sc after reduce"
 750       do i=1,nres
 751        do j=1,1
 752         write (iout,*) i,j,gloc_sc(j,i,icg)
 753        enddo
 754       enddo
 755 #endif
 756 #undef DEBUG
 757 #ifdef DEBUG
 758       write (iout,*) "gloc after reduce"
 759       do i=1,4*nres
 760         write (iout,*) i,gloc(i,icg)
 761       enddo
 762 #endif
 763       endif
 764 #endif
 765       if (gnorm_check) then
 766 c
 767 c Compute the maximum elements of the gradient
 768 c
 769       gvdwc_max=0.0d0
 770       gvdwc_scp_max=0.0d0
 771       gelc_max=0.0d0
 772       gvdwpp_max=0.0d0
 773       gradb_max=0.0d0
 774       ghpbc_max=0.0d0
 775       gradcorr_max=0.0d0
 776       gel_loc_max=0.0d0
 777       gcorr3_turn_max=0.0d0
 778       gcorr4_turn_max=0.0d0
 779       gradcorr5_max=0.0d0
 780       gradcorr6_max=0.0d0
 781       gcorr6_turn_max=0.0d0
 782       gsccorc_max=0.0d0
 783       gscloc_max=0.0d0
 784       gvdwx_max=0.0d0
 785       gradx_scp_max=0.0d0
 786       ghpbx_max=0.0d0
 787       gradxorr_max=0.0d0
 788       gsccorx_max=0.0d0
 789       gsclocx_max=0.0d0
 790       do i=1,nct
 791         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 792         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 793         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 794         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 795      &   gvdwc_scp_max=gvdwc_scp_norm
 796         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 797         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 798         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 799         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 800         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 801         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 802         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 803         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 804         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 805         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 806         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 807         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 808         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 809      &    gcorr3_turn(1,i)))
 810         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 811      &    gcorr3_turn_max=gcorr3_turn_norm
 812         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 813      &    gcorr4_turn(1,i)))
 814         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 815      &    gcorr4_turn_max=gcorr4_turn_norm
 816         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 817         if (gradcorr5_norm.gt.gradcorr5_max)
 818      &    gradcorr5_max=gradcorr5_norm
 819         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 820         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 821         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 822      &    gcorr6_turn(1,i)))
 823         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 824      &    gcorr6_turn_max=gcorr6_turn_norm
 825         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 826         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 827         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 828         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 829         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 830         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 831         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 832         if (gradx_scp_norm.gt.gradx_scp_max)
 833      &    gradx_scp_max=gradx_scp_norm
 834         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 835         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 836         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 837         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 838         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 839         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 840         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 841         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 842       enddo
 843       if (gradout) then
 844 #ifdef AIX
 845         open(istat,file=statname,position="append")
 846 #else
 847         open(istat,file=statname,access="append")
 848 #endif
 849         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 850      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 851      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 852      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 853      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 854      &     gsccorx_max,gsclocx_max
 855         close(istat)
 856         if (gvdwc_max.gt.1.0d4) then
 857           write (iout,*) "gvdwc gvdwx gradb gradbx"
 858           do i=nnt,nct
 859             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 860      &        gradb(j,i),gradbx(j,i),j=1,3)
 861           enddo
 862           call pdbout(0.0d0,'cipiszcze',iout)
 863           call flush(iout)
 864         endif
 865       endif
 866       endif
 867 #ifdef DEBUG
 868       write (iout,*) "gradc gradx gloc"
 869       do i=1,nres
 870         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 871      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 872       enddo
 873 #endif
 874 #ifdef TIMING
 875       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 876 #endif
 877       return
 878       end
 879 c-------------------------------------------------------------------------------
 880       subroutine rescale_weights(t_bath)
 881       implicit real*8 (a-h,o-z)
 882       include 'DIMENSIONS'
 883       include 'COMMON.IOUNITS'
 884       include 'COMMON.FFIELD'
 885       include 'COMMON.SBRIDGE'
 886       double precision kfac /2.4d0/
 887       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 888 c      facT=temp0/t_bath
 889 c      facT=2*temp0/(t_bath+temp0)
 890       if (rescale_mode.eq.0) then
 891         facT=1.0d0
 892         facT2=1.0d0
 893         facT3=1.0d0
 894         facT4=1.0d0
 895         facT5=1.0d0
 896       else if (rescale_mode.eq.1) then
 897         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 898         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 899         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 900         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 901         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 902       else if (rescale_mode.eq.2) then
 903         x=t_bath/temp0
 904         x2=x*x
 905         x3=x2*x
 906         x4=x3*x
 907         x5=x4*x
 908         facT=licznik/dlog(dexp(x)+dexp(-x))
 909         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 910         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 911         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 912         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 913       else
 914         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 915         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 916 #ifdef MPI
 917        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 918 #endif
 919        stop 555
 920       endif
 921       welec=weights(3)*fact
 922       wcorr=weights(4)*fact3
 923       wcorr5=weights(5)*fact4
 924       wcorr6=weights(6)*fact5
 925       wel_loc=weights(7)*fact2
 926       wturn3=weights(8)*fact2
 927       wturn4=weights(9)*fact3
 928       wturn6=weights(10)*fact5
 929       wtor=weights(13)*fact
 930       wtor_d=weights(14)*fact2
 931       wsccor=weights(21)*fact
 932
 933       return
 934       end
 935 C------------------------------------------------------------------------
 936       subroutine enerprint(energia)
 937       implicit real*8 (a-h,o-z)
 938       include 'DIMENSIONS'
 939       include 'COMMON.IOUNITS'
 940       include 'COMMON.FFIELD'
 941       include 'COMMON.SBRIDGE'
 942       include 'COMMON.MD'
 943       double precision energia(0:n_ene)
 944       etot=energia(0)
 945       evdw=energia(1)
 946       evdw2=energia(2)
 947 #ifdef SCP14
 948       evdw2=energia(2)+energia(18)
 949 #else
 950       evdw2=energia(2)
 951 #endif
 952       ees=energia(3)
 953 #ifdef SPLITELE
 954       evdw1=energia(16)
 955 #endif
 956       ecorr=energia(4)
 957       ecorr5=energia(5)
 958       ecorr6=energia(6)
 959       eel_loc=energia(7)
 960       eello_turn3=energia(8)
 961       eello_turn4=energia(9)
 962       eello_turn6=energia(10)
 963       ebe=energia(11)
 964       escloc=energia(12)
 965       etors=energia(13)
 966       etors_d=energia(14)
 967       ehpb=energia(15)
 968       edihcnstr=energia(19)
 969       estr=energia(17)
 970       Uconst=energia(20)
 971       esccor=energia(21)
 972 #ifdef SPLITELE
 973       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 974      &  estr,wbond,ebe,wang,
 975      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 976      &  ecorr,wcorr,
 977      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 978      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 979      &  edihcnstr,ebr*nss,
 980      &  Uconst,etot
 981    10 format (/'Virtual-chain energies:'//
 982      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 983      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 984      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 985      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 986      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 987      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 988      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 989      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 990      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 991      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 992      & ' (SS bridges & dist. cnstr.)'/
 993      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 994      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 997      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 998      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 999      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1000      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1001      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1002      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1003      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1004      & 'ETOT=  ',1pE16.6,' (total)')
1005 #else
1006       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1007      &  estr,wbond,ebe,wang,
1008      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1009      &  ecorr,wcorr,
1010      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1011      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1012      &  ebr*nss,Uconst,etot
1013    10 format (/'Virtual-chain energies:'//
1014      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1015      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1016      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1017      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1018      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1019      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1020      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1021      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1022      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1023      & ' (SS bridges & dist. cnstr.)'/
1024      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1025      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1028      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1029      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1030      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1031      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1032      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1033      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1034      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1035      & 'ETOT=  ',1pE16.6,' (total)')
1036 #endif
1037       return
1038       end
1039 C-----------------------------------------------------------------------
1040       subroutine elj(evdw)
1041 C
1042 C This subroutine calculates the interaction energy of nonbonded side chains
1043 C assuming the LJ potential of interaction.
1044 C
1045       implicit real*8 (a-h,o-z)
1046       include 'DIMENSIONS'
1047       parameter (accur=1.0d-10)
1048       include 'COMMON.GEO'
1049       include 'COMMON.VAR'
1050       include 'COMMON.LOCAL'
1051       include 'COMMON.CHAIN'
1052       include 'COMMON.DERIV'
1053       include 'COMMON.INTERACT'
1054       include 'COMMON.TORSION'
1055       include 'COMMON.SBRIDGE'
1056       include 'COMMON.NAMES'
1057       include 'COMMON.IOUNITS'
1058       include 'COMMON.CONTACTS'
1059       dimension gg(3)
1060 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1061       evdw=0.0D0
1062       do i=iatsc_s,iatsc_e
1063         itypi=itype(i)
1064         if (itypi.eq.21) cycle
1065         itypi1=itype(i+1)
1066         xi=c(1,nres+i)
1067         yi=c(2,nres+i)
1068         zi=c(3,nres+i)
1069 C Change 12/1/95
1070         num_conti=0
1071 C
1072 C Calculate SC interaction energy.
1073 C
1074         do iint=1,nint_gr(i)
1075 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1076 cd   &                  'iend=',iend(i,iint)
1077           do j=istart(i,iint),iend(i,iint)
1078             itypj=itype(j)
1079             if (itypj.eq.21) cycle
1080             xj=c(1,nres+j)-xi
1081             yj=c(2,nres+j)-yi
1082             zj=c(3,nres+j)-zi
1083 C Change 12/1/95 to calculate four-body interactions
1084             rij=xj*xj+yj*yj+zj*zj
1085             rrij=1.0D0/rij
1086 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1087             eps0ij=eps(itypi,itypj)
1088             fac=rrij**expon2
1089             e1=fac*fac*aa(itypi,itypj)
1090             e2=fac*bb(itypi,itypj)
1091             evdwij=e1+e2
1092 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1093 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1094 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1095 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1096 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1097 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1098             evdw=evdw+evdwij
1099 C
1100 C Calculate the components of the gradient in DC and X
1101 C
1102             fac=-rrij*(e1+evdwij)
1103             gg(1)=xj*fac
1104             gg(2)=yj*fac
1105             gg(3)=zj*fac
1106             do k=1,3
1107               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1108               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1109               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1110               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1111             enddo
1112 cgrad            do k=i,j-1
1113 cgrad              do l=1,3
1114 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1115 cgrad              enddo
1116 cgrad            enddo
1117 C
1118 C 12/1/95, revised on 5/20/97
1119 C
1120 C Calculate the contact function. The ith column of the array JCONT will
1121 C contain the numbers of atoms that make contacts with the atom I (of numbers
1122 C greater than I). The arrays FACONT and GACONT will contain the values of
1123 C the contact function and its derivative.
1124 C
1125 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1126 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1127 C Uncomment next line, if the correlation interactions are contact function only
1128             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1129               rij=dsqrt(rij)
1130               sigij=sigma(itypi,itypj)
1131               r0ij=rs0(itypi,itypj)
1132 C
1133 C Check whether the SC's are not too far to make a contact.
1134 C
1135               rcut=1.5d0*r0ij
1136               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1137 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1138 C
1139               if (fcont.gt.0.0D0) then
1140 C If the SC-SC distance if close to sigma, apply spline.
1141 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1142 cAdam &             fcont1,fprimcont1)
1143 cAdam           fcont1=1.0d0-fcont1
1144 cAdam           if (fcont1.gt.0.0d0) then
1145 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1146 cAdam             fcont=fcont*fcont1
1147 cAdam           endif
1148 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1149 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1150 cga             do k=1,3
1151 cga               gg(k)=gg(k)*eps0ij
1152 cga             enddo
1153 cga             eps0ij=-evdwij*eps0ij
1154 C Uncomment for AL's type of SC correlation interactions.
1155 cadam           eps0ij=-evdwij
1156                 num_conti=num_conti+1
1157                 jcont(num_conti,i)=j
1158                 facont(num_conti,i)=fcont*eps0ij
1159                 fprimcont=eps0ij*fprimcont/rij
1160                 fcont=expon*fcont
1161 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1162 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1163 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1164 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1165                 gacont(1,num_conti,i)=-fprimcont*xj
1166                 gacont(2,num_conti,i)=-fprimcont*yj
1167                 gacont(3,num_conti,i)=-fprimcont*zj
1168 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1169 cd              write (iout,'(2i3,3f10.5)')
1170 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1171               endif
1172             endif
1173           enddo      ! j
1174         enddo        ! iint
1175 C Change 12/1/95
1176         num_cont(i)=num_conti
1177       enddo          ! i
1178       do i=1,nct
1179         do j=1,3
1180           gvdwc(j,i)=expon*gvdwc(j,i)
1181           gvdwx(j,i)=expon*gvdwx(j,i)
1182         enddo
1183       enddo
1184 C******************************************************************************
1185 C
1186 C                              N O T E !!!
1187 C
1188 C To save time, the factor of EXPON has been extracted from ALL components
1189 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1190 C use!
1191 C
1192 C******************************************************************************
1193       return
1194       end
1195 C-----------------------------------------------------------------------------
1196       subroutine eljk(evdw)
1197 C
1198 C This subroutine calculates the interaction energy of nonbonded side chains
1199 C assuming the LJK potential of interaction.
1200 C
1201       implicit real*8 (a-h,o-z)
1202       include 'DIMENSIONS'
1203       include 'COMMON.GEO'
1204       include 'COMMON.VAR'
1205       include 'COMMON.LOCAL'
1206       include 'COMMON.CHAIN'
1207       include 'COMMON.DERIV'
1208       include 'COMMON.INTERACT'
1209       include 'COMMON.IOUNITS'
1210       include 'COMMON.NAMES'
1211       dimension gg(3)
1212       logical scheck
1213 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1214       evdw=0.0D0
1215       do i=iatsc_s,iatsc_e
1216         itypi=itype(i)
1217         if (itypi.eq.21) cycle
1218         itypi1=itype(i+1)
1219         xi=c(1,nres+i)
1220         yi=c(2,nres+i)
1221         zi=c(3,nres+i)
1222 C
1223 C Calculate SC interaction energy.
1224 C
1225         do iint=1,nint_gr(i)
1226           do j=istart(i,iint),iend(i,iint)
1227             itypj=itype(j)
1228             if (itypj.eq.21) cycle
1229             xj=c(1,nres+j)-xi
1230             yj=c(2,nres+j)-yi
1231             zj=c(3,nres+j)-zi
1232             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1233             fac_augm=rrij**expon
1234             e_augm=augm(itypi,itypj)*fac_augm
1235             r_inv_ij=dsqrt(rrij)
1236             rij=1.0D0/r_inv_ij
1237             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1238             fac=r_shift_inv**expon
1239             e1=fac*fac*aa(itypi,itypj)
1240             e2=fac*bb(itypi,itypj)
1241             evdwij=e_augm+e1+e2
1242 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1243 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1244 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1245 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1246 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1247 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1248 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1249             evdw=evdw+evdwij
1250 C
1251 C Calculate the components of the gradient in DC and X
1252 C
1253             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1254             gg(1)=xj*fac
1255             gg(2)=yj*fac
1256             gg(3)=zj*fac
1257             do k=1,3
1258               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1259               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1260               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1261               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1262             enddo
1263 cgrad            do k=i,j-1
1264 cgrad              do l=1,3
1265 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1266 cgrad              enddo
1267 cgrad            enddo
1268           enddo      ! j
1269         enddo        ! iint
1270       enddo          ! i
1271       do i=1,nct
1272         do j=1,3
1273           gvdwc(j,i)=expon*gvdwc(j,i)
1274           gvdwx(j,i)=expon*gvdwx(j,i)
1275         enddo
1276       enddo
1277       return
1278       end
1279 C-----------------------------------------------------------------------------
1280       subroutine ebp(evdw)
1281 C
1282 C This subroutine calculates the interaction energy of nonbonded side chains
1283 C assuming the Berne-Pechukas potential of interaction.
1284 C
1285       implicit real*8 (a-h,o-z)
1286       include 'DIMENSIONS'
1287       include 'COMMON.GEO'
1288       include 'COMMON.VAR'
1289       include 'COMMON.LOCAL'
1290       include 'COMMON.CHAIN'
1291       include 'COMMON.DERIV'
1292       include 'COMMON.NAMES'
1293       include 'COMMON.INTERACT'
1294       include 'COMMON.IOUNITS'
1295       include 'COMMON.CALC'
1296       common /srutu/ icall
1297 c     double precision rrsave(maxdim)
1298       logical lprn
1299       evdw=0.0D0
1300 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1301       evdw=0.0D0
1302 c     if (icall.eq.0) then
1303 c       lprn=.true.
1304 c     else
1305         lprn=.false.
1306 c     endif
1307       ind=0
1308       do i=iatsc_s,iatsc_e
1309         itypi=itype(i)
1310         if (itypi.eq.21) cycle
1311         itypi1=itype(i+1)
1312         xi=c(1,nres+i)
1313         yi=c(2,nres+i)
1314         zi=c(3,nres+i)
1315         dxi=dc_norm(1,nres+i)
1316         dyi=dc_norm(2,nres+i)
1317         dzi=dc_norm(3,nres+i)
1318 c        dsci_inv=dsc_inv(itypi)
1319         dsci_inv=vbld_inv(i+nres)
1320 C
1321 C Calculate SC interaction energy.
1322 C
1323         do iint=1,nint_gr(i)
1324           do j=istart(i,iint),iend(i,iint)
1325             ind=ind+1
1326             itypj=itype(j)
1327             if (itypj.eq.21) cycle
1328 c            dscj_inv=dsc_inv(itypj)
1329             dscj_inv=vbld_inv(j+nres)
1330             chi1=chi(itypi,itypj)
1331             chi2=chi(itypj,itypi)
1332             chi12=chi1*chi2
1333             chip1=chip(itypi)
1334             chip2=chip(itypj)
1335             chip12=chip1*chip2
1336             alf1=alp(itypi)
1337             alf2=alp(itypj)
1338             alf12=0.5D0*(alf1+alf2)
1339 C For diagnostics only!!!
1340 c           chi1=0.0D0
1341 c           chi2=0.0D0
1342 c           chi12=0.0D0
1343 c           chip1=0.0D0
1344 c           chip2=0.0D0
1345 c           chip12=0.0D0
1346 c           alf1=0.0D0
1347 c           alf2=0.0D0
1348 c           alf12=0.0D0
1349             xj=c(1,nres+j)-xi
1350             yj=c(2,nres+j)-yi
1351             zj=c(3,nres+j)-zi
1352             dxj=dc_norm(1,nres+j)
1353             dyj=dc_norm(2,nres+j)
1354             dzj=dc_norm(3,nres+j)
1355             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1356 cd          if (icall.eq.0) then
1357 cd            rrsave(ind)=rrij
1358 cd          else
1359 cd            rrij=rrsave(ind)
1360 cd          endif
1361             rij=dsqrt(rrij)
1362 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1363             call sc_angular
1364 C Calculate whole angle-dependent part of epsilon and contributions
1365 C to its derivatives
1366             fac=(rrij*sigsq)**expon2
1367             e1=fac*fac*aa(itypi,itypj)
1368             e2=fac*bb(itypi,itypj)
1369             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1370             eps2der=evdwij*eps3rt
1371             eps3der=evdwij*eps2rt
1372             evdwij=evdwij*eps2rt*eps3rt
1373             evdw=evdw+evdwij
1374             if (lprn) then
1375             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1376             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1377 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1378 cd     &        restyp(itypi),i,restyp(itypj),j,
1379 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1380 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1381 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1382 cd     &        evdwij
1383             endif
1384 C Calculate gradient components.
1385             e1=e1*eps1*eps2rt**2*eps3rt**2
1386             fac=-expon*(e1+evdwij)
1387             sigder=fac/sigsq
1388             fac=rrij*fac
1389 C Calculate radial part of the gradient
1390             gg(1)=xj*fac
1391             gg(2)=yj*fac
1392             gg(3)=zj*fac
1393 C Calculate the angular part of the gradient and sum add the contributions
1394 C to the appropriate components of the Cartesian gradient.
1395             call sc_grad
1396           enddo      ! j
1397         enddo        ! iint
1398       enddo          ! i
1399 c     stop
1400       return
1401       end
1402 C-----------------------------------------------------------------------------
1403       subroutine egb(evdw)
1404 C
1405 C This subroutine calculates the interaction energy of nonbonded side chains
1406 C assuming the Gay-Berne potential of interaction.
1407 C
1408       implicit real*8 (a-h,o-z)
1409       include 'DIMENSIONS'
1410       include 'COMMON.GEO'
1411       include 'COMMON.VAR'
1412       include 'COMMON.LOCAL'
1413       include 'COMMON.CHAIN'
1414       include 'COMMON.DERIV'
1415       include 'COMMON.NAMES'
1416       include 'COMMON.INTERACT'
1417       include 'COMMON.IOUNITS'
1418       include 'COMMON.CALC'
1419       include 'COMMON.CONTROL'
1420       include 'COMMON.SBRIDGE'
1421       logical lprn
1422       evdw=0.0D0
1423 ccccc      energy_dec=.false.
1424 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1425       evdw=0.0D0
1426       lprn=.false.
1427 c     if (icall.eq.0) lprn=.false.
1428       ind=0
1429       do i=iatsc_s,iatsc_e
1430         itypi=itype(i)
1431         if (itypi.eq.21) cycle
1432         itypi1=itype(i+1)
1433         xi=c(1,nres+i)
1434         yi=c(2,nres+i)
1435         zi=c(3,nres+i)
1436         dxi=dc_norm(1,nres+i)
1437         dyi=dc_norm(2,nres+i)
1438         dzi=dc_norm(3,nres+i)
1439 c        dsci_inv=dsc_inv(itypi)
1440         dsci_inv=vbld_inv(i+nres)
1441 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1442 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1443 C
1444 C Calculate SC interaction energy.
1445 C
1446         do iint=1,nint_gr(i)
1447           do j=istart(i,iint),iend(i,iint)
1448             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1449               call dyn_ssbond_ene(i,j,evdwij)
1450               evdw=evdw+evdwij
1451               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1452      &                        'evdw',i,j,evdwij,' ss'
1453             ELSE
1454             ind=ind+1
1455             itypj=itype(j)
1456             if (itypj.eq.21) cycle
1457 c            dscj_inv=dsc_inv(itypj)
1458             dscj_inv=vbld_inv(j+nres)
1459 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1460 c     &       1.0d0/vbld(j+nres)
1461 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1462             sig0ij=sigma(itypi,itypj)
1463             chi1=chi(itypi,itypj)
1464             chi2=chi(itypj,itypi)
1465             chi12=chi1*chi2
1466             chip1=chip(itypi)
1467             chip2=chip(itypj)
1468             chip12=chip1*chip2
1469             alf1=alp(itypi)
1470             alf2=alp(itypj)
1471             alf12=0.5D0*(alf1+alf2)
1472 C For diagnostics only!!!
1473 c           chi1=0.0D0
1474 c           chi2=0.0D0
1475 c           chi12=0.0D0
1476 c           chip1=0.0D0
1477 c           chip2=0.0D0
1478 c           chip12=0.0D0
1479 c           alf1=0.0D0
1480 c           alf2=0.0D0
1481 c           alf12=0.0D0
1482             xj=c(1,nres+j)-xi
1483             yj=c(2,nres+j)-yi
1484             zj=c(3,nres+j)-zi
1485             dxj=dc_norm(1,nres+j)
1486             dyj=dc_norm(2,nres+j)
1487             dzj=dc_norm(3,nres+j)
1488 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1489 c            write (iout,*) "j",j," dc_norm",
1490 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1491             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1492             rij=dsqrt(rrij)
1493 C Calculate angle-dependent terms of energy and contributions to their
1494 C derivatives.
1495             call sc_angular
1496             sigsq=1.0D0/sigsq
1497             sig=sig0ij*dsqrt(sigsq)
1498             rij_shift=1.0D0/rij-sig+sig0ij
1499 c for diagnostics; uncomment
1500 c            rij_shift=1.2*sig0ij
1501 C I hate to put IF's in the loops, but here don't have another choice!!!!
1502             if (rij_shift.le.0.0D0) then
1503               evdw=1.0D20
1504 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1505 cd     &        restyp(itypi),i,restyp(itypj),j,
1506 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1507               return
1508             endif
1509             sigder=-sig*sigsq
1510 c---------------------------------------------------------------
1511             rij_shift=1.0D0/rij_shift
1512             fac=rij_shift**expon
1513             e1=fac*fac*aa(itypi,itypj)
1514             e2=fac*bb(itypi,itypj)
1515             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1516             eps2der=evdwij*eps3rt
1517             eps3der=evdwij*eps2rt
1518 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1519 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1520             evdwij=evdwij*eps2rt*eps3rt
1521             evdw=evdw+evdwij
1522             if (lprn) then
1523             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1524             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1525             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1526      &        restyp(itypi),i,restyp(itypj),j,
1527      &        epsi,sigm,chi1,chi2,chip1,chip2,
1528      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1529      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1530      &        evdwij
1531             endif
1532
1533             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1534      &                        'evdw',i,j,evdwij
1535
1536 C Calculate gradient components.
1537             e1=e1*eps1*eps2rt**2*eps3rt**2
1538             fac=-expon*(e1+evdwij)*rij_shift
1539             sigder=fac*sigder
1540             fac=rij*fac
1541 c            fac=0.0d0
1542 C Calculate the radial part of the gradient
1543             gg(1)=xj*fac
1544             gg(2)=yj*fac
1545             gg(3)=zj*fac
1546 C Calculate angular part of the gradient.
1547             call sc_grad
1548             ENDIF    ! dyn_ss
1549           enddo      ! j
1550         enddo        ! iint
1551       enddo          ! i
1552 c      write (iout,*) "Number of loop steps in EGB:",ind
1553 cccc      energy_dec=.false.
1554       return
1555       end
1556 C-----------------------------------------------------------------------------
1557       subroutine egbv(evdw)
1558 C
1559 C This subroutine calculates the interaction energy of nonbonded side chains
1560 C assuming the Gay-Berne-Vorobjev potential of interaction.
1561 C
1562       implicit real*8 (a-h,o-z)
1563       include 'DIMENSIONS'
1564       include 'COMMON.GEO'
1565       include 'COMMON.VAR'
1566       include 'COMMON.LOCAL'
1567       include 'COMMON.CHAIN'
1568       include 'COMMON.DERIV'
1569       include 'COMMON.NAMES'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.IOUNITS'
1572       include 'COMMON.CALC'
1573       common /srutu/ icall
1574       logical lprn
1575       evdw=0.0D0
1576 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1577       evdw=0.0D0
1578       lprn=.false.
1579 c     if (icall.eq.0) lprn=.true.
1580       ind=0
1581       do i=iatsc_s,iatsc_e
1582         itypi=itype(i)
1583         if (itypi.eq.21) cycle
1584         itypi1=itype(i+1)
1585         xi=c(1,nres+i)
1586         yi=c(2,nres+i)
1587         zi=c(3,nres+i)
1588         dxi=dc_norm(1,nres+i)
1589         dyi=dc_norm(2,nres+i)
1590         dzi=dc_norm(3,nres+i)
1591 c        dsci_inv=dsc_inv(itypi)
1592         dsci_inv=vbld_inv(i+nres)
1593 C
1594 C Calculate SC interaction energy.
1595 C
1596         do iint=1,nint_gr(i)
1597           do j=istart(i,iint),iend(i,iint)
1598             ind=ind+1
1599             itypj=itype(j)
1600             if (itypj.eq.21) cycle
1601 c            dscj_inv=dsc_inv(itypj)
1602             dscj_inv=vbld_inv(j+nres)
1603             sig0ij=sigma(itypi,itypj)
1604             r0ij=r0(itypi,itypj)
1605             chi1=chi(itypi,itypj)
1606             chi2=chi(itypj,itypi)
1607             chi12=chi1*chi2
1608             chip1=chip(itypi)
1609             chip2=chip(itypj)
1610             chip12=chip1*chip2
1611             alf1=alp(itypi)
1612             alf2=alp(itypj)
1613             alf12=0.5D0*(alf1+alf2)
1614 C For diagnostics only!!!
1615 c           chi1=0.0D0
1616 c           chi2=0.0D0
1617 c           chi12=0.0D0
1618 c           chip1=0.0D0
1619 c           chip2=0.0D0
1620 c           chip12=0.0D0
1621 c           alf1=0.0D0
1622 c           alf2=0.0D0
1623 c           alf12=0.0D0
1624             xj=c(1,nres+j)-xi
1625             yj=c(2,nres+j)-yi
1626             zj=c(3,nres+j)-zi
1627             dxj=dc_norm(1,nres+j)
1628             dyj=dc_norm(2,nres+j)
1629             dzj=dc_norm(3,nres+j)
1630             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1631             rij=dsqrt(rrij)
1632 C Calculate angle-dependent terms of energy and contributions to their
1633 C derivatives.
1634             call sc_angular
1635             sigsq=1.0D0/sigsq
1636             sig=sig0ij*dsqrt(sigsq)
1637             rij_shift=1.0D0/rij-sig+r0ij
1638 C I hate to put IF's in the loops, but here don't have another choice!!!!
1639             if (rij_shift.le.0.0D0) then
1640               evdw=1.0D20
1641               return
1642             endif
1643             sigder=-sig*sigsq
1644 c---------------------------------------------------------------
1645             rij_shift=1.0D0/rij_shift
1646             fac=rij_shift**expon
1647             e1=fac*fac*aa(itypi,itypj)
1648             e2=fac*bb(itypi,itypj)
1649             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1650             eps2der=evdwij*eps3rt
1651             eps3der=evdwij*eps2rt
1652             fac_augm=rrij**expon
1653             e_augm=augm(itypi,itypj)*fac_augm
1654             evdwij=evdwij*eps2rt*eps3rt
1655             evdw=evdw+evdwij+e_augm
1656             if (lprn) then
1657             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1658             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1659             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1660      &        restyp(itypi),i,restyp(itypj),j,
1661      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1662      &        chi1,chi2,chip1,chip2,
1663      &        eps1,eps2rt**2,eps3rt**2,
1664      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1665      &        evdwij+e_augm
1666             endif
1667 C Calculate gradient components.
1668             e1=e1*eps1*eps2rt**2*eps3rt**2
1669             fac=-expon*(e1+evdwij)*rij_shift
1670             sigder=fac*sigder
1671             fac=rij*fac-2*expon*rrij*e_augm
1672 C Calculate the radial part of the gradient
1673             gg(1)=xj*fac
1674             gg(2)=yj*fac
1675             gg(3)=zj*fac
1676 C Calculate angular part of the gradient.
1677             call sc_grad
1678           enddo      ! j
1679         enddo        ! iint
1680       enddo          ! i
1681       end
1682 C-----------------------------------------------------------------------------
1683       subroutine sc_angular
1684 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1685 C om12. Called by ebp, egb, and egbv.
1686       implicit none
1687       include 'COMMON.CALC'
1688       include 'COMMON.IOUNITS'
1689       erij(1)=xj*rij
1690       erij(2)=yj*rij
1691       erij(3)=zj*rij
1692       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1693       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1694       om12=dxi*dxj+dyi*dyj+dzi*dzj
1695       chiom12=chi12*om12
1696 C Calculate eps1(om12) and its derivative in om12
1697       faceps1=1.0D0-om12*chiom12
1698       faceps1_inv=1.0D0/faceps1
1699       eps1=dsqrt(faceps1_inv)
1700 C Following variable is eps1*deps1/dom12
1701       eps1_om12=faceps1_inv*chiom12
1702 c diagnostics only
1703 c      faceps1_inv=om12
1704 c      eps1=om12
1705 c      eps1_om12=1.0d0
1706 c      write (iout,*) "om12",om12," eps1",eps1
1707 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1708 C and om12.
1709       om1om2=om1*om2
1710       chiom1=chi1*om1
1711       chiom2=chi2*om2
1712       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1713       sigsq=1.0D0-facsig*faceps1_inv
1714       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1715       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1716       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1717 c diagnostics only
1718 c      sigsq=1.0d0
1719 c      sigsq_om1=0.0d0
1720 c      sigsq_om2=0.0d0
1721 c      sigsq_om12=0.0d0
1722 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1723 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1724 c     &    " eps1",eps1
1725 C Calculate eps2 and its derivatives in om1, om2, and om12.
1726       chipom1=chip1*om1
1727       chipom2=chip2*om2
1728       chipom12=chip12*om12
1729       facp=1.0D0-om12*chipom12
1730       facp_inv=1.0D0/facp
1731       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1732 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1733 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1734 C Following variable is the square root of eps2
1735       eps2rt=1.0D0-facp1*facp_inv
1736 C Following three variables are the derivatives of the square root of eps
1737 C in om1, om2, and om12.
1738       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1739       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1740       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1741 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1742       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1743 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1744 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1745 c     &  " eps2rt_om12",eps2rt_om12
1746 C Calculate whole angle-dependent part of epsilon and contributions
1747 C to its derivatives
1748       return
1749       end
1750 C----------------------------------------------------------------------------
1751       subroutine sc_grad
1752       implicit real*8 (a-h,o-z)
1753       include 'DIMENSIONS'
1754       include 'COMMON.CHAIN'
1755       include 'COMMON.DERIV'
1756       include 'COMMON.CALC'
1757       include 'COMMON.IOUNITS'
1758       double precision dcosom1(3),dcosom2(3)
1759       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1760       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1761       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1762      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1763 c diagnostics only
1764 c      eom1=0.0d0
1765 c      eom2=0.0d0
1766 c      eom12=evdwij*eps1_om12
1767 c end diagnostics
1768 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1769 c     &  " sigder",sigder
1770 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1771 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1772       do k=1,3
1773         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1774         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1775       enddo
1776       do k=1,3
1777         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1778       enddo
1779 c      write (iout,*) "gg",(gg(k),k=1,3)
1780       do k=1,3
1781         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1782      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1783      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1784         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1785      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1786      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1787 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1788 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1789 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1790 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1791       enddo
1792 C
1793 C Calculate the components of the gradient in DC and X
1794 C
1795 cgrad      do k=i,j-1
1796 cgrad        do l=1,3
1797 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1798 cgrad        enddo
1799 cgrad      enddo
1800       do l=1,3
1801         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1802         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1803       enddo
1804       return
1805       end
1806 C-----------------------------------------------------------------------
1807       subroutine e_softsphere(evdw)
1808 C
1809 C This subroutine calculates the interaction energy of nonbonded side chains
1810 C assuming the LJ potential of interaction.
1811 C
1812       implicit real*8 (a-h,o-z)
1813       include 'DIMENSIONS'
1814       parameter (accur=1.0d-10)
1815       include 'COMMON.GEO'
1816       include 'COMMON.VAR'
1817       include 'COMMON.LOCAL'
1818       include 'COMMON.CHAIN'
1819       include 'COMMON.DERIV'
1820       include 'COMMON.INTERACT'
1821       include 'COMMON.TORSION'
1822       include 'COMMON.SBRIDGE'
1823       include 'COMMON.NAMES'
1824       include 'COMMON.IOUNITS'
1825       include 'COMMON.CONTACTS'
1826       dimension gg(3)
1827 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1828       evdw=0.0D0
1829       do i=iatsc_s,iatsc_e
1830         itypi=itype(i)
1831         if (itypi.eq.21) cycle
1832         itypi1=itype(i+1)
1833         xi=c(1,nres+i)
1834         yi=c(2,nres+i)
1835         zi=c(3,nres+i)
1836 C
1837 C Calculate SC interaction energy.
1838 C
1839         do iint=1,nint_gr(i)
1840 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1841 cd   &                  'iend=',iend(i,iint)
1842           do j=istart(i,iint),iend(i,iint)
1843             itypj=itype(j)
1844             if (itypj.eq.21) cycle
1845             xj=c(1,nres+j)-xi
1846             yj=c(2,nres+j)-yi
1847             zj=c(3,nres+j)-zi
1848             rij=xj*xj+yj*yj+zj*zj
1849 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1850             r0ij=r0(itypi,itypj)
1851             r0ijsq=r0ij*r0ij
1852 c            print *,i,j,r0ij,dsqrt(rij)
1853             if (rij.lt.r0ijsq) then
1854               evdwij=0.25d0*(rij-r0ijsq)**2
1855               fac=rij-r0ijsq
1856             else
1857               evdwij=0.0d0
1858               fac=0.0d0
1859             endif
1860             evdw=evdw+evdwij
1861 C
1862 C Calculate the components of the gradient in DC and X
1863 C
1864             gg(1)=xj*fac
1865             gg(2)=yj*fac
1866             gg(3)=zj*fac
1867             do k=1,3
1868               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1869               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1870               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1871               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1872             enddo
1873 cgrad            do k=i,j-1
1874 cgrad              do l=1,3
1875 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1876 cgrad              enddo
1877 cgrad            enddo
1878           enddo ! j
1879         enddo ! iint
1880       enddo ! i
1881       return
1882       end
1883 C--------------------------------------------------------------------------
1884       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1885      &              eello_turn4)
1886 C
1887 C Soft-sphere potential of p-p interaction
1888 C
1889       implicit real*8 (a-h,o-z)
1890       include 'DIMENSIONS'
1891       include 'COMMON.CONTROL'
1892       include 'COMMON.IOUNITS'
1893       include 'COMMON.GEO'
1894       include 'COMMON.VAR'
1895       include 'COMMON.LOCAL'
1896       include 'COMMON.CHAIN'
1897       include 'COMMON.DERIV'
1898       include 'COMMON.INTERACT'
1899       include 'COMMON.CONTACTS'
1900       include 'COMMON.TORSION'
1901       include 'COMMON.VECTORS'
1902       include 'COMMON.FFIELD'
1903       dimension ggg(3)
1904 cd      write(iout,*) 'In EELEC_soft_sphere'
1905       ees=0.0D0
1906       evdw1=0.0D0
1907       eel_loc=0.0d0
1908       eello_turn3=0.0d0
1909       eello_turn4=0.0d0
1910       ind=0
1911       do i=iatel_s,iatel_e
1912         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1913         dxi=dc(1,i)
1914         dyi=dc(2,i)
1915         dzi=dc(3,i)
1916         xmedi=c(1,i)+0.5d0*dxi
1917         ymedi=c(2,i)+0.5d0*dyi
1918         zmedi=c(3,i)+0.5d0*dzi
1919         num_conti=0
1920 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1921         do j=ielstart(i),ielend(i)
1922           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1923           ind=ind+1
1924           iteli=itel(i)
1925           itelj=itel(j)
1926           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1927           r0ij=rpp(iteli,itelj)
1928           r0ijsq=r0ij*r0ij
1929           dxj=dc(1,j)
1930           dyj=dc(2,j)
1931           dzj=dc(3,j)
1932           xj=c(1,j)+0.5D0*dxj-xmedi
1933           yj=c(2,j)+0.5D0*dyj-ymedi
1934           zj=c(3,j)+0.5D0*dzj-zmedi
1935           rij=xj*xj+yj*yj+zj*zj
1936           if (rij.lt.r0ijsq) then
1937             evdw1ij=0.25d0*(rij-r0ijsq)**2
1938             fac=rij-r0ijsq
1939           else
1940             evdw1ij=0.0d0
1941             fac=0.0d0
1942           endif
1943           evdw1=evdw1+evdw1ij
1944 C
1945 C Calculate contributions to the Cartesian gradient.
1946 C
1947           ggg(1)=fac*xj
1948           ggg(2)=fac*yj
1949           ggg(3)=fac*zj
1950           do k=1,3
1951             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1952             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1953           enddo
1954 *
1955 * Loop over residues i+1 thru j-1.
1956 *
1957 cgrad          do k=i+1,j-1
1958 cgrad            do l=1,3
1959 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1960 cgrad            enddo
1961 cgrad          enddo
1962         enddo ! j
1963       enddo   ! i
1964 cgrad      do i=nnt,nct-1
1965 cgrad        do k=1,3
1966 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1967 cgrad        enddo
1968 cgrad        do j=i+1,nct-1
1969 cgrad          do k=1,3
1970 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1971 cgrad          enddo
1972 cgrad        enddo
1973 cgrad      enddo
1974       return
1975       end
1976 c------------------------------------------------------------------------------
1977       subroutine vec_and_deriv
1978       implicit real*8 (a-h,o-z)
1979       include 'DIMENSIONS'
1980 #ifdef MPI
1981       include 'mpif.h'
1982 #endif
1983       include 'COMMON.IOUNITS'
1984       include 'COMMON.GEO'
1985       include 'COMMON.VAR'
1986       include 'COMMON.LOCAL'
1987       include 'COMMON.CHAIN'
1988       include 'COMMON.VECTORS'
1989       include 'COMMON.SETUP'
1990       include 'COMMON.TIME1'
1991       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1992 C Compute the local reference systems. For reference system (i), the
1993 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1994 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1995 #ifdef PARVEC
1996       do i=ivec_start,ivec_end
1997 #else
1998       do i=1,nres-1
1999 #endif
2000           if (i.eq.nres-1) then
2001 C Case of the last full residue
2002 C Compute the Z-axis
2003             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2004             costh=dcos(pi-theta(nres))
2005             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2006             do k=1,3
2007               uz(k,i)=fac*uz(k,i)
2008             enddo
2009 C Compute the derivatives of uz
2010             uzder(1,1,1)= 0.0d0
2011             uzder(2,1,1)=-dc_norm(3,i-1)
2012             uzder(3,1,1)= dc_norm(2,i-1)
2013             uzder(1,2,1)= dc_norm(3,i-1)
2014             uzder(2,2,1)= 0.0d0
2015             uzder(3,2,1)=-dc_norm(1,i-1)
2016             uzder(1,3,1)=-dc_norm(2,i-1)
2017             uzder(2,3,1)= dc_norm(1,i-1)
2018             uzder(3,3,1)= 0.0d0
2019             uzder(1,1,2)= 0.0d0
2020             uzder(2,1,2)= dc_norm(3,i)
2021             uzder(3,1,2)=-dc_norm(2,i)
2022             uzder(1,2,2)=-dc_norm(3,i)
2023             uzder(2,2,2)= 0.0d0
2024             uzder(3,2,2)= dc_norm(1,i)
2025             uzder(1,3,2)= dc_norm(2,i)
2026             uzder(2,3,2)=-dc_norm(1,i)
2027             uzder(3,3,2)= 0.0d0
2028 C Compute the Y-axis
2029             facy=fac
2030             do k=1,3
2031               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2032             enddo
2033 C Compute the derivatives of uy
2034             do j=1,3
2035               do k=1,3
2036                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2037      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2038                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2039               enddo
2040               uyder(j,j,1)=uyder(j,j,1)-costh
2041               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2042             enddo
2043             do j=1,2
2044               do k=1,3
2045                 do l=1,3
2046                   uygrad(l,k,j,i)=uyder(l,k,j)
2047                   uzgrad(l,k,j,i)=uzder(l,k,j)
2048                 enddo
2049               enddo
2050             enddo
2051             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2052             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2053             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2054             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2055           else
2056 C Other residues
2057 C Compute the Z-axis
2058             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2059             costh=dcos(pi-theta(i+2))
2060             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2061             do k=1,3
2062               uz(k,i)=fac*uz(k,i)
2063             enddo
2064 C Compute the derivatives of uz
2065             uzder(1,1,1)= 0.0d0
2066             uzder(2,1,1)=-dc_norm(3,i+1)
2067             uzder(3,1,1)= dc_norm(2,i+1)
2068             uzder(1,2,1)= dc_norm(3,i+1)
2069             uzder(2,2,1)= 0.0d0
2070             uzder(3,2,1)=-dc_norm(1,i+1)
2071             uzder(1,3,1)=-dc_norm(2,i+1)
2072             uzder(2,3,1)= dc_norm(1,i+1)
2073             uzder(3,3,1)= 0.0d0
2074             uzder(1,1,2)= 0.0d0
2075             uzder(2,1,2)= dc_norm(3,i)
2076             uzder(3,1,2)=-dc_norm(2,i)
2077             uzder(1,2,2)=-dc_norm(3,i)
2078             uzder(2,2,2)= 0.0d0
2079             uzder(3,2,2)= dc_norm(1,i)
2080             uzder(1,3,2)= dc_norm(2,i)
2081             uzder(2,3,2)=-dc_norm(1,i)
2082             uzder(3,3,2)= 0.0d0
2083 C Compute the Y-axis
2084             facy=fac
2085             do k=1,3
2086               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2087             enddo
2088 C Compute the derivatives of uy
2089             do j=1,3
2090               do k=1,3
2091                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2092      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2093                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2094               enddo
2095               uyder(j,j,1)=uyder(j,j,1)-costh
2096               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2097             enddo
2098             do j=1,2
2099               do k=1,3
2100                 do l=1,3
2101                   uygrad(l,k,j,i)=uyder(l,k,j)
2102                   uzgrad(l,k,j,i)=uzder(l,k,j)
2103                 enddo
2104               enddo
2105             enddo
2106             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2107             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2108             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2109             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2110           endif
2111       enddo
2112       do i=1,nres-1
2113         vbld_inv_temp(1)=vbld_inv(i+1)
2114         if (i.lt.nres-1) then
2115           vbld_inv_temp(2)=vbld_inv(i+2)
2116           else
2117           vbld_inv_temp(2)=vbld_inv(i)
2118           endif
2119         do j=1,2
2120           do k=1,3
2121             do l=1,3
2122               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2123               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2124             enddo
2125           enddo
2126         enddo
2127       enddo
2128 #if defined(PARVEC) && defined(MPI)
2129       if (nfgtasks1.gt.1) then
2130         time00=MPI_Wtime()
2131 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2132 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2133 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2134         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2135      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2136      &   FG_COMM1,IERR)
2137         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2138      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2139      &   FG_COMM1,IERR)
2140         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2141      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2142      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2143         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2144      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2145      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2146         time_gather=time_gather+MPI_Wtime()-time00
2147       endif
2148 c      if (fg_rank.eq.0) then
2149 c        write (iout,*) "Arrays UY and UZ"
2150 c        do i=1,nres-1
2151 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2152 c     &     (uz(k,i),k=1,3)
2153 c        enddo
2154 c      endif
2155 #endif
2156       return
2157       end
2158 C-----------------------------------------------------------------------------
2159       subroutine check_vecgrad
2160       implicit real*8 (a-h,o-z)
2161       include 'DIMENSIONS'
2162       include 'COMMON.IOUNITS'
2163       include 'COMMON.GEO'
2164       include 'COMMON.VAR'
2165       include 'COMMON.LOCAL'
2166       include 'COMMON.CHAIN'
2167       include 'COMMON.VECTORS'
2168       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2169       dimension uyt(3,maxres),uzt(3,maxres)
2170       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2171       double precision delta /1.0d-7/
2172       call vec_and_deriv
2173 cd      do i=1,nres
2174 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2175 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2176 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2177 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2178 cd     &     (dc_norm(if90,i),if90=1,3)
2179 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2180 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2181 cd          write(iout,'(a)')
2182 cd      enddo
2183       do i=1,nres
2184         do j=1,2
2185           do k=1,3
2186             do l=1,3
2187               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2188               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2189             enddo
2190           enddo
2191         enddo
2192       enddo
2193       call vec_and_deriv
2194       do i=1,nres
2195         do j=1,3
2196           uyt(j,i)=uy(j,i)
2197           uzt(j,i)=uz(j,i)
2198         enddo
2199       enddo
2200       do i=1,nres
2201 cd        write (iout,*) 'i=',i
2202         do k=1,3
2203           erij(k)=dc_norm(k,i)
2204         enddo
2205         do j=1,3
2206           do k=1,3
2207             dc_norm(k,i)=erij(k)
2208           enddo
2209           dc_norm(j,i)=dc_norm(j,i)+delta
2210 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2211 c          do k=1,3
2212 c            dc_norm(k,i)=dc_norm(k,i)/fac
2213 c          enddo
2214 c          write (iout,*) (dc_norm(k,i),k=1,3)
2215 c          write (iout,*) (erij(k),k=1,3)
2216           call vec_and_deriv
2217           do k=1,3
2218             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2219             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2220             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2221             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2222           enddo
2223 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2224 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2225 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2226         enddo
2227         do k=1,3
2228           dc_norm(k,i)=erij(k)
2229         enddo
2230 cd        do k=1,3
2231 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2232 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2233 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2234 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2235 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2236 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2237 cd          write (iout,'(a)')
2238 cd        enddo
2239       enddo
2240       return
2241       end
2242 C--------------------------------------------------------------------------
2243       subroutine set_matrices
2244       implicit real*8 (a-h,o-z)
2245       include 'DIMENSIONS'
2246 #ifdef MPI
2247       include "mpif.h"
2248       include "COMMON.SETUP"
2249       integer IERR
2250       integer status(MPI_STATUS_SIZE)
2251 #endif
2252       include 'COMMON.IOUNITS'
2253       include 'COMMON.GEO'
2254       include 'COMMON.VAR'
2255       include 'COMMON.LOCAL'
2256       include 'COMMON.CHAIN'
2257       include 'COMMON.DERIV'
2258       include 'COMMON.INTERACT'
2259       include 'COMMON.CONTACTS'
2260       include 'COMMON.TORSION'
2261       include 'COMMON.VECTORS'
2262       include 'COMMON.FFIELD'
2263       double precision auxvec(2),auxmat(2,2)
2264 C
2265 C Compute the virtual-bond-torsional-angle dependent quantities needed
2266 C to calculate the el-loc multibody terms of various order.
2267 C
2268 #ifdef PARMAT
2269       do i=ivec_start+2,ivec_end+2
2270 #else
2271       do i=3,nres+1
2272 #endif
2273         if (i .lt. nres+1) then
2274           sin1=dsin(phi(i))
2275           cos1=dcos(phi(i))
2276           sintab(i-2)=sin1
2277           costab(i-2)=cos1
2278           obrot(1,i-2)=cos1
2279           obrot(2,i-2)=sin1
2280           sin2=dsin(2*phi(i))
2281           cos2=dcos(2*phi(i))
2282           sintab2(i-2)=sin2
2283           costab2(i-2)=cos2
2284           obrot2(1,i-2)=cos2
2285           obrot2(2,i-2)=sin2
2286           Ug(1,1,i-2)=-cos1
2287           Ug(1,2,i-2)=-sin1
2288           Ug(2,1,i-2)=-sin1
2289           Ug(2,2,i-2)= cos1
2290           Ug2(1,1,i-2)=-cos2
2291           Ug2(1,2,i-2)=-sin2
2292           Ug2(2,1,i-2)=-sin2
2293           Ug2(2,2,i-2)= cos2
2294         else
2295           costab(i-2)=1.0d0
2296           sintab(i-2)=0.0d0
2297           obrot(1,i-2)=1.0d0
2298           obrot(2,i-2)=0.0d0
2299           obrot2(1,i-2)=0.0d0
2300           obrot2(2,i-2)=0.0d0
2301           Ug(1,1,i-2)=1.0d0
2302           Ug(1,2,i-2)=0.0d0
2303           Ug(2,1,i-2)=0.0d0
2304           Ug(2,2,i-2)=1.0d0
2305           Ug2(1,1,i-2)=0.0d0
2306           Ug2(1,2,i-2)=0.0d0
2307           Ug2(2,1,i-2)=0.0d0
2308           Ug2(2,2,i-2)=0.0d0
2309         endif
2310         if (i .gt. 3 .and. i .lt. nres+1) then
2311           obrot_der(1,i-2)=-sin1
2312           obrot_der(2,i-2)= cos1
2313           Ugder(1,1,i-2)= sin1
2314           Ugder(1,2,i-2)=-cos1
2315           Ugder(2,1,i-2)=-cos1
2316           Ugder(2,2,i-2)=-sin1
2317           dwacos2=cos2+cos2
2318           dwasin2=sin2+sin2
2319           obrot2_der(1,i-2)=-dwasin2
2320           obrot2_der(2,i-2)= dwacos2
2321           Ug2der(1,1,i-2)= dwasin2
2322           Ug2der(1,2,i-2)=-dwacos2
2323           Ug2der(2,1,i-2)=-dwacos2
2324           Ug2der(2,2,i-2)=-dwasin2
2325         else
2326           obrot_der(1,i-2)=0.0d0
2327           obrot_der(2,i-2)=0.0d0
2328           Ugder(1,1,i-2)=0.0d0
2329           Ugder(1,2,i-2)=0.0d0
2330           Ugder(2,1,i-2)=0.0d0
2331           Ugder(2,2,i-2)=0.0d0
2332           obrot2_der(1,i-2)=0.0d0
2333           obrot2_der(2,i-2)=0.0d0
2334           Ug2der(1,1,i-2)=0.0d0
2335           Ug2der(1,2,i-2)=0.0d0
2336           Ug2der(2,1,i-2)=0.0d0
2337           Ug2der(2,2,i-2)=0.0d0
2338         endif
2339 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2340         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2341           iti = itortyp(itype(i-2))
2342         else
2343           iti=ntortyp+1
2344         endif
2345 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2346         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2347           iti1 = itortyp(itype(i-1))
2348         else
2349           iti1=ntortyp+1
2350         endif
2351 cd        write (iout,*) '*******i',i,' iti1',iti
2352 cd        write (iout,*) 'b1',b1(:,iti)
2353 cd        write (iout,*) 'b2',b2(:,iti)
2354 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2355 c        if (i .gt. iatel_s+2) then
2356         if (i .gt. nnt+2) then
2357           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2358           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2359           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2360      &    then
2361           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2362           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2363           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2364           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2365           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2366           endif
2367         else
2368           do k=1,2
2369             Ub2(k,i-2)=0.0d0
2370             Ctobr(k,i-2)=0.0d0
2371             Dtobr2(k,i-2)=0.0d0
2372             do l=1,2
2373               EUg(l,k,i-2)=0.0d0
2374               CUg(l,k,i-2)=0.0d0
2375               DUg(l,k,i-2)=0.0d0
2376               DtUg2(l,k,i-2)=0.0d0
2377             enddo
2378           enddo
2379         endif
2380         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2381         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2382         do k=1,2
2383           muder(k,i-2)=Ub2der(k,i-2)
2384         enddo
2385 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2386         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2387           iti1 = itortyp(itype(i-1))
2388         else
2389           iti1=ntortyp+1
2390         endif
2391         do k=1,2
2392           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2393         enddo
2394 cd        write (iout,*) 'mu ',mu(:,i-2)
2395 cd        write (iout,*) 'mu1',mu1(:,i-2)
2396 cd        write (iout,*) 'mu2',mu2(:,i-2)
2397         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2398      &  then
2399         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2400         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2401         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2402         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2403         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2404 C Vectors and matrices dependent on a single virtual-bond dihedral.
2405         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2406         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2407         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2408         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2409         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2410         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2411         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2412         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2413         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2414         endif
2415       enddo
2416 C Matrices dependent on two consecutive virtual-bond dihedrals.
2417 C The order of matrices is from left to right.
2418       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2419      &then
2420 c      do i=max0(ivec_start,2),ivec_end
2421       do i=2,nres-1
2422         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2423         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2424         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2425         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2426         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2427         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2428         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2429         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2430       enddo
2431       endif
2432 #if defined(MPI) && defined(PARMAT)
2433 #ifdef DEBUG
2434 c      if (fg_rank.eq.0) then
2435         write (iout,*) "Arrays UG and UGDER before GATHER"
2436         do i=1,nres-1
2437           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2438      &     ((ug(l,k,i),l=1,2),k=1,2),
2439      &     ((ugder(l,k,i),l=1,2),k=1,2)
2440         enddo
2441         write (iout,*) "Arrays UG2 and UG2DER"
2442         do i=1,nres-1
2443           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2444      &     ((ug2(l,k,i),l=1,2),k=1,2),
2445      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2446         enddo
2447         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2448         do i=1,nres-1
2449           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2450      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2451      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2452         enddo
2453         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2454         do i=1,nres-1
2455           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2456      &     costab(i),sintab(i),costab2(i),sintab2(i)
2457         enddo
2458         write (iout,*) "Array MUDER"
2459         do i=1,nres-1
2460           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2461         enddo
2462 c      endif
2463 #endif
2464       if (nfgtasks.gt.1) then
2465         time00=MPI_Wtime()
2466 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2467 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2468 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2469 #ifdef MATGATHER
2470         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2471      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2472      &   FG_COMM1,IERR)
2473         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2474      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2475      &   FG_COMM1,IERR)
2476         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2477      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2478      &   FG_COMM1,IERR)
2479         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2480      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2481      &   FG_COMM1,IERR)
2482         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2483      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2484      &   FG_COMM1,IERR)
2485         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2486      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2487      &   FG_COMM1,IERR)
2488         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2489      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2490      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2491         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2492      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2493      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2494         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2495      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2496      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2497         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2498      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2499      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2500         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2501      &  then
2502         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2503      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2504      &   FG_COMM1,IERR)
2505         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2506      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2507      &   FG_COMM1,IERR)
2508         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2509      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2510      &   FG_COMM1,IERR)
2511        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2512      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2513      &   FG_COMM1,IERR)
2514         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2515      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2516      &   FG_COMM1,IERR)
2517         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2518      &   ivec_count(fg_rank1),
2519      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2528      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2529      &   FG_COMM1,IERR)
2530         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2531      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2532      &   FG_COMM1,IERR)
2533         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2534      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2535      &   FG_COMM1,IERR)
2536         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2537      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2538      &   FG_COMM1,IERR)
2539         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2540      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2541      &   FG_COMM1,IERR)
2542         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2543      &   ivec_count(fg_rank1),
2544      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2545      &   FG_COMM1,IERR)
2546         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2547      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2548      &   FG_COMM1,IERR)
2549        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2550      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2551      &   FG_COMM1,IERR)
2552         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2554      &   FG_COMM1,IERR)
2555        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2559      &   ivec_count(fg_rank1),
2560      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2563      &   ivec_count(fg_rank1),
2564      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2565      &   FG_COMM1,IERR)
2566         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2567      &   ivec_count(fg_rank1),
2568      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2569      &   MPI_MAT2,FG_COMM1,IERR)
2570         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2571      &   ivec_count(fg_rank1),
2572      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2573      &   MPI_MAT2,FG_COMM1,IERR)
2574         endif
2575 #else
2576 c Passes matrix info through the ring
2577       isend=fg_rank1
2578       irecv=fg_rank1-1
2579       if (irecv.lt.0) irecv=nfgtasks1-1
2580       iprev=irecv
2581       inext=fg_rank1+1
2582       if (inext.ge.nfgtasks1) inext=0
2583       do i=1,nfgtasks1-1
2584 c        write (iout,*) "isend",isend," irecv",irecv
2585 c        call flush(iout)
2586         lensend=lentyp(isend)
2587         lenrecv=lentyp(irecv)
2588 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2589 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2590 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2591 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2592 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2593 c        write (iout,*) "Gather ROTAT1"
2594 c        call flush(iout)
2595 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2596 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2597 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2598 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2599 c        write (iout,*) "Gather ROTAT2"
2600 c        call flush(iout)
2601         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2602      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2603      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2604      &   iprev,4400+irecv,FG_COMM,status,IERR)
2605 c        write (iout,*) "Gather ROTAT_OLD"
2606 c        call flush(iout)
2607         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2608      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2609      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2610      &   iprev,5500+irecv,FG_COMM,status,IERR)
2611 c        write (iout,*) "Gather PRECOMP11"
2612 c        call flush(iout)
2613         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2614      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2615      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2616      &   iprev,6600+irecv,FG_COMM,status,IERR)
2617 c        write (iout,*) "Gather PRECOMP12"
2618 c        call flush(iout)
2619         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2620      &  then
2621         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2622      &   MPI_ROTAT2(lensend),inext,7700+isend,
2623      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2624      &   iprev,7700+irecv,FG_COMM,status,IERR)
2625 c        write (iout,*) "Gather PRECOMP21"
2626 c        call flush(iout)
2627         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2628      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2629      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2630      &   iprev,8800+irecv,FG_COMM,status,IERR)
2631 c        write (iout,*) "Gather PRECOMP22"
2632 c        call flush(iout)
2633         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2634      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2635      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2636      &   MPI_PRECOMP23(lenrecv),
2637      &   iprev,9900+irecv,FG_COMM,status,IERR)
2638 c        write (iout,*) "Gather PRECOMP23"
2639 c        call flush(iout)
2640         endif
2641         isend=irecv
2642         irecv=irecv-1
2643         if (irecv.lt.0) irecv=nfgtasks1-1
2644       enddo
2645 #endif
2646         time_gather=time_gather+MPI_Wtime()-time00
2647       endif
2648 #ifdef DEBUG
2649 c      if (fg_rank.eq.0) then
2650         write (iout,*) "Arrays UG and UGDER"
2651         do i=1,nres-1
2652           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2653      &     ((ug(l,k,i),l=1,2),k=1,2),
2654      &     ((ugder(l,k,i),l=1,2),k=1,2)
2655         enddo
2656         write (iout,*) "Arrays UG2 and UG2DER"
2657         do i=1,nres-1
2658           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2659      &     ((ug2(l,k,i),l=1,2),k=1,2),
2660      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2661         enddo
2662         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2663         do i=1,nres-1
2664           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2665      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2666      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2667         enddo
2668         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2669         do i=1,nres-1
2670           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2671      &     costab(i),sintab(i),costab2(i),sintab2(i)
2672         enddo
2673         write (iout,*) "Array MUDER"
2674         do i=1,nres-1
2675           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2676         enddo
2677 c      endif
2678 #endif
2679 #endif
2680 cd      do i=1,nres
2681 cd        iti = itortyp(itype(i))
2682 cd        write (iout,*) i
2683 cd        do j=1,2
2684 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2685 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2686 cd        enddo
2687 cd      enddo
2688       return
2689       end
2690 C--------------------------------------------------------------------------
2691       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2692 C
2693 C This subroutine calculates the average interaction energy and its gradient
2694 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2695 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2696 C The potential depends both on the distance of peptide-group centers and on
2697 C the orientation of the CA-CA virtual bonds.
2698 C
2699       implicit real*8 (a-h,o-z)
2700 #ifdef MPI
2701       include 'mpif.h'
2702 #endif
2703       include 'DIMENSIONS'
2704       include 'COMMON.CONTROL'
2705       include 'COMMON.SETUP'
2706       include 'COMMON.IOUNITS'
2707       include 'COMMON.GEO'
2708       include 'COMMON.VAR'
2709       include 'COMMON.LOCAL'
2710       include 'COMMON.CHAIN'
2711       include 'COMMON.DERIV'
2712       include 'COMMON.INTERACT'
2713       include 'COMMON.CONTACTS'
2714       include 'COMMON.TORSION'
2715       include 'COMMON.VECTORS'
2716       include 'COMMON.FFIELD'
2717       include 'COMMON.TIME1'
2718       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2719      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2720       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2721      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2722       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2723      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2724      &    num_conti,j1,j2
2725 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2726 #ifdef MOMENT
2727       double precision scal_el /1.0d0/
2728 #else
2729       double precision scal_el /0.5d0/
2730 #endif
2731 C 12/13/98
2732 C 13-go grudnia roku pamietnego...
2733       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2734      &                   0.0d0,1.0d0,0.0d0,
2735      &                   0.0d0,0.0d0,1.0d0/
2736 cd      write(iout,*) 'In EELEC'
2737 cd      do i=1,nloctyp
2738 cd        write(iout,*) 'Type',i
2739 cd        write(iout,*) 'B1',B1(:,i)
2740 cd        write(iout,*) 'B2',B2(:,i)
2741 cd        write(iout,*) 'CC',CC(:,:,i)
2742 cd        write(iout,*) 'DD',DD(:,:,i)
2743 cd        write(iout,*) 'EE',EE(:,:,i)
2744 cd      enddo
2745 cd      call check_vecgrad
2746 cd      stop
2747       if (icheckgrad.eq.1) then
2748         do i=1,nres-1
2749           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2750           do k=1,3
2751             dc_norm(k,i)=dc(k,i)*fac
2752           enddo
2753 c          write (iout,*) 'i',i,' fac',fac
2754         enddo
2755       endif
2756       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2757      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2758      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2759 c        call vec_and_deriv
2760 #ifdef TIMING
2761         time01=MPI_Wtime()
2762 #endif
2763         call set_matrices
2764 #ifdef TIMING
2765         time_mat=time_mat+MPI_Wtime()-time01
2766 #endif
2767       endif
2768 cd      do i=1,nres-1
2769 cd        write (iout,*) 'i=',i
2770 cd        do k=1,3
2771 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2772 cd        enddo
2773 cd        do k=1,3
2774 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2775 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2776 cd        enddo
2777 cd      enddo
2778       t_eelecij=0.0d0
2779       ees=0.0D0
2780       evdw1=0.0D0
2781       eel_loc=0.0d0
2782       eello_turn3=0.0d0
2783       eello_turn4=0.0d0
2784       ind=0
2785       do i=1,nres
2786         num_cont_hb(i)=0
2787       enddo
2788 cd      print '(a)','Enter EELEC'
2789 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2790       do i=1,nres
2791         gel_loc_loc(i)=0.0d0
2792         gcorr_loc(i)=0.0d0
2793       enddo
2794 c
2795 c
2796 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2797 C
2798 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2799 C
2800       do i=iturn3_start,iturn3_end
2801         if (itype(i).eq.21 .or. itype(i+1).eq.21
2802      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2803         dxi=dc(1,i)
2804         dyi=dc(2,i)
2805         dzi=dc(3,i)
2806         dx_normi=dc_norm(1,i)
2807         dy_normi=dc_norm(2,i)
2808         dz_normi=dc_norm(3,i)
2809         xmedi=c(1,i)+0.5d0*dxi
2810         ymedi=c(2,i)+0.5d0*dyi
2811         zmedi=c(3,i)+0.5d0*dzi
2812         num_conti=0
2813         call eelecij(i,i+2,ees,evdw1,eel_loc)
2814         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2815         num_cont_hb(i)=num_conti
2816       enddo
2817       do i=iturn4_start,iturn4_end
2818         if (itype(i).eq.21 .or. itype(i+1).eq.21
2819      &    .or. itype(i+3).eq.21
2820      &    .or. itype(i+4).eq.21) cycle
2821         dxi=dc(1,i)
2822         dyi=dc(2,i)
2823         dzi=dc(3,i)
2824         dx_normi=dc_norm(1,i)
2825         dy_normi=dc_norm(2,i)
2826         dz_normi=dc_norm(3,i)
2827         xmedi=c(1,i)+0.5d0*dxi
2828         ymedi=c(2,i)+0.5d0*dyi
2829         zmedi=c(3,i)+0.5d0*dzi
2830         num_conti=num_cont_hb(i)
2831         call eelecij(i,i+3,ees,evdw1,eel_loc)
2832         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2833      &   call eturn4(i,eello_turn4)
2834         num_cont_hb(i)=num_conti
2835       enddo   ! i
2836 c
2837 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2838 c
2839       do i=iatel_s,iatel_e
2840         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2841         dxi=dc(1,i)
2842         dyi=dc(2,i)
2843         dzi=dc(3,i)
2844         dx_normi=dc_norm(1,i)
2845         dy_normi=dc_norm(2,i)
2846         dz_normi=dc_norm(3,i)
2847         xmedi=c(1,i)+0.5d0*dxi
2848         ymedi=c(2,i)+0.5d0*dyi
2849         zmedi=c(3,i)+0.5d0*dzi
2850 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2851         num_conti=num_cont_hb(i)
2852         do j=ielstart(i),ielend(i)
2853 c          write (iout,*) i,j,itype(i),itype(j)
2854           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2855           call eelecij(i,j,ees,evdw1,eel_loc)
2856         enddo ! j
2857         num_cont_hb(i)=num_conti
2858       enddo   ! i
2859 c      write (iout,*) "Number of loop steps in EELEC:",ind
2860 cd      do i=1,nres
2861 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2862 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2863 cd      enddo
2864 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2865 ccc      eel_loc=eel_loc+eello_turn3
2866 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2867       return
2868       end
2869 C-------------------------------------------------------------------------------
2870       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2871       implicit real*8 (a-h,o-z)
2872       include 'DIMENSIONS'
2873 #ifdef MPI
2874       include "mpif.h"
2875 #endif
2876       include 'COMMON.CONTROL'
2877       include 'COMMON.IOUNITS'
2878       include 'COMMON.GEO'
2879       include 'COMMON.VAR'
2880       include 'COMMON.LOCAL'
2881       include 'COMMON.CHAIN'
2882       include 'COMMON.DERIV'
2883       include 'COMMON.INTERACT'
2884       include 'COMMON.CONTACTS'
2885       include 'COMMON.TORSION'
2886       include 'COMMON.VECTORS'
2887       include 'COMMON.FFIELD'
2888       include 'COMMON.TIME1'
2889       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2890      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2891       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2892      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2893       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2894      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2895      &    num_conti,j1,j2
2896 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2897 #ifdef MOMENT
2898       double precision scal_el /1.0d0/
2899 #else
2900       double precision scal_el /0.5d0/
2901 #endif
2902 C 12/13/98
2903 C 13-go grudnia roku pamietnego...
2904       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2905      &                   0.0d0,1.0d0,0.0d0,
2906      &                   0.0d0,0.0d0,1.0d0/
2907 c          time00=MPI_Wtime()
2908 cd      write (iout,*) "eelecij",i,j
2909 c          ind=ind+1
2910           iteli=itel(i)
2911           itelj=itel(j)
2912           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2913           aaa=app(iteli,itelj)
2914           bbb=bpp(iteli,itelj)
2915           ael6i=ael6(iteli,itelj)
2916           ael3i=ael3(iteli,itelj)
2917           dxj=dc(1,j)
2918           dyj=dc(2,j)
2919           dzj=dc(3,j)
2920           dx_normj=dc_norm(1,j)
2921           dy_normj=dc_norm(2,j)
2922           dz_normj=dc_norm(3,j)
2923           xj=c(1,j)+0.5D0*dxj-xmedi
2924           yj=c(2,j)+0.5D0*dyj-ymedi
2925           zj=c(3,j)+0.5D0*dzj-zmedi
2926           rij=xj*xj+yj*yj+zj*zj
2927           rrmij=1.0D0/rij
2928           rij=dsqrt(rij)
2929           rmij=1.0D0/rij
2930           r3ij=rrmij*rmij
2931           r6ij=r3ij*r3ij
2932           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2933           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2934           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2935           fac=cosa-3.0D0*cosb*cosg
2936           ev1=aaa*r6ij*r6ij
2937 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2938           if (j.eq.i+2) ev1=scal_el*ev1
2939           ev2=bbb*r6ij
2940           fac3=ael6i*r6ij
2941           fac4=ael3i*r3ij
2942           evdwij=ev1+ev2
2943           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2944           el2=fac4*fac
2945           eesij=el1+el2
2946 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2947           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2948           ees=ees+eesij
2949           evdw1=evdw1+evdwij
2950 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2951 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2952 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2953 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2954
2955           if (energy_dec) then
2956               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2957               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2958           endif
2959
2960 C
2961 C Calculate contributions to the Cartesian gradient.
2962 C
2963 #ifdef SPLITELE
2964           facvdw=-6*rrmij*(ev1+evdwij)
2965           facel=-3*rrmij*(el1+eesij)
2966           fac1=fac
2967           erij(1)=xj*rmij
2968           erij(2)=yj*rmij
2969           erij(3)=zj*rmij
2970 *
2971 * Radial derivatives. First process both termini of the fragment (i,j)
2972 *
2973           ggg(1)=facel*xj
2974           ggg(2)=facel*yj
2975           ggg(3)=facel*zj
2976 c          do k=1,3
2977 c            ghalf=0.5D0*ggg(k)
2978 c            gelc(k,i)=gelc(k,i)+ghalf
2979 c            gelc(k,j)=gelc(k,j)+ghalf
2980 c          enddo
2981 c 9/28/08 AL Gradient compotents will be summed only at the end
2982           do k=1,3
2983             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2984             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2985           enddo
2986 *
2987 * Loop over residues i+1 thru j-1.
2988 *
2989 cgrad          do k=i+1,j-1
2990 cgrad            do l=1,3
2991 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2992 cgrad            enddo
2993 cgrad          enddo
2994           ggg(1)=facvdw*xj
2995           ggg(2)=facvdw*yj
2996           ggg(3)=facvdw*zj
2997 c          do k=1,3
2998 c            ghalf=0.5D0*ggg(k)
2999 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3000 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3001 c          enddo
3002 c 9/28/08 AL Gradient compotents will be summed only at the end
3003           do k=1,3
3004             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3005             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3006           enddo
3007 *
3008 * Loop over residues i+1 thru j-1.
3009 *
3010 cgrad          do k=i+1,j-1
3011 cgrad            do l=1,3
3012 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3013 cgrad            enddo
3014 cgrad          enddo
3015 #else
3016           facvdw=ev1+evdwij
3017           facel=el1+eesij
3018           fac1=fac
3019           fac=-3*rrmij*(facvdw+facvdw+facel)
3020           erij(1)=xj*rmij
3021           erij(2)=yj*rmij
3022           erij(3)=zj*rmij
3023 *
3024 * Radial derivatives. First process both termini of the fragment (i,j)
3025 *
3026           ggg(1)=fac*xj
3027           ggg(2)=fac*yj
3028           ggg(3)=fac*zj
3029 c          do k=1,3
3030 c            ghalf=0.5D0*ggg(k)
3031 c            gelc(k,i)=gelc(k,i)+ghalf
3032 c            gelc(k,j)=gelc(k,j)+ghalf
3033 c          enddo
3034 c 9/28/08 AL Gradient compotents will be summed only at the end
3035           do k=1,3
3036             gelc_long(k,j)=gelc(k,j)+ggg(k)
3037             gelc_long(k,i)=gelc(k,i)-ggg(k)
3038           enddo
3039 *
3040 * Loop over residues i+1 thru j-1.
3041 *
3042 cgrad          do k=i+1,j-1
3043 cgrad            do l=1,3
3044 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3045 cgrad            enddo
3046 cgrad          enddo
3047 c 9/28/08 AL Gradient compotents will be summed only at the end
3048           ggg(1)=facvdw*xj
3049           ggg(2)=facvdw*yj
3050           ggg(3)=facvdw*zj
3051           do k=1,3
3052             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3053             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3054           enddo
3055 #endif
3056 *
3057 * Angular part
3058 *
3059           ecosa=2.0D0*fac3*fac1+fac4
3060           fac4=-3.0D0*fac4
3061           fac3=-6.0D0*fac3
3062           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3063           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3064           do k=1,3
3065             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3066             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3067           enddo
3068 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3069 cd   &          (dcosg(k),k=1,3)
3070           do k=1,3
3071             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3072           enddo
3073 c          do k=1,3
3074 c            ghalf=0.5D0*ggg(k)
3075 c            gelc(k,i)=gelc(k,i)+ghalf
3076 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3077 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3078 c            gelc(k,j)=gelc(k,j)+ghalf
3079 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3080 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3081 c          enddo
3082 cgrad          do k=i+1,j-1
3083 cgrad            do l=1,3
3084 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3085 cgrad            enddo
3086 cgrad          enddo
3087           do k=1,3
3088             gelc(k,i)=gelc(k,i)
3089      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3090      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3091             gelc(k,j)=gelc(k,j)
3092      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3093      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3094             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3095             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3096           enddo
3097           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3098      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3099      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3100 C
3101 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3102 C   energy of a peptide unit is assumed in the form of a second-order
3103 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3104 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3105 C   are computed for EVERY pair of non-contiguous peptide groups.
3106 C
3107           if (j.lt.nres-1) then
3108             j1=j+1
3109             j2=j-1
3110           else
3111             j1=j-1
3112             j2=j-2
3113           endif
3114           kkk=0
3115           do k=1,2
3116             do l=1,2
3117               kkk=kkk+1
3118               muij(kkk)=mu(k,i)*mu(l,j)
3119             enddo
3120           enddo
3121 cd         write (iout,*) 'EELEC: i',i,' j',j
3122 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3123 cd          write(iout,*) 'muij',muij
3124           ury=scalar(uy(1,i),erij)
3125           urz=scalar(uz(1,i),erij)
3126           vry=scalar(uy(1,j),erij)
3127           vrz=scalar(uz(1,j),erij)
3128           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3129           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3130           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3131           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3132           fac=dsqrt(-ael6i)*r3ij
3133           a22=a22*fac
3134           a23=a23*fac
3135           a32=a32*fac
3136           a33=a33*fac
3137 cd          write (iout,'(4i5,4f10.5)')
3138 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3139 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3140 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3141 cd     &      uy(:,j),uz(:,j)
3142 cd          write (iout,'(4f10.5)')
3143 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3144 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3145 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3146 cd           write (iout,'(9f10.5/)')
3147 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3148 C Derivatives of the elements of A in virtual-bond vectors
3149           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3150           do k=1,3
3151             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3152             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3153             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3154             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3155             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3156             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3157             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3158             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3159             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3160             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3161             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3162             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3163           enddo
3164 C Compute radial contributions to the gradient
3165           facr=-3.0d0*rrmij
3166           a22der=a22*facr
3167           a23der=a23*facr
3168           a32der=a32*facr
3169           a33der=a33*facr
3170           agg(1,1)=a22der*xj
3171           agg(2,1)=a22der*yj
3172           agg(3,1)=a22der*zj
3173           agg(1,2)=a23der*xj
3174           agg(2,2)=a23der*yj
3175           agg(3,2)=a23der*zj
3176           agg(1,3)=a32der*xj
3177           agg(2,3)=a32der*yj
3178           agg(3,3)=a32der*zj
3179           agg(1,4)=a33der*xj
3180           agg(2,4)=a33der*yj
3181           agg(3,4)=a33der*zj
3182 C Add the contributions coming from er
3183           fac3=-3.0d0*fac
3184           do k=1,3
3185             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3186             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3187             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3188             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3189           enddo
3190           do k=1,3
3191 C Derivatives in DC(i)
3192 cgrad            ghalf1=0.5d0*agg(k,1)
3193 cgrad            ghalf2=0.5d0*agg(k,2)
3194 cgrad            ghalf3=0.5d0*agg(k,3)
3195 cgrad            ghalf4=0.5d0*agg(k,4)
3196             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3197      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3198             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3199      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3200             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3201      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3202             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3203      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3204 C Derivatives in DC(i+1)
3205             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3206      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3207             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3208      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3209             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3210      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3211             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3212      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3213 C Derivatives in DC(j)
3214             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3215      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3216             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3217      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3218             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3219      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3220             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3221      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3222 C Derivatives in DC(j+1) or DC(nres-1)
3223             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3224      &      -3.0d0*vryg(k,3)*ury)
3225             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3226      &      -3.0d0*vrzg(k,3)*ury)
3227             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3228      &      -3.0d0*vryg(k,3)*urz)
3229             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3230      &      -3.0d0*vrzg(k,3)*urz)
3231 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3232 cgrad              do l=1,4
3233 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3234 cgrad              enddo
3235 cgrad            endif
3236           enddo
3237           acipa(1,1)=a22
3238           acipa(1,2)=a23
3239           acipa(2,1)=a32
3240           acipa(2,2)=a33
3241           a22=-a22
3242           a23=-a23
3243           do l=1,2
3244             do k=1,3
3245               agg(k,l)=-agg(k,l)
3246               aggi(k,l)=-aggi(k,l)
3247               aggi1(k,l)=-aggi1(k,l)
3248               aggj(k,l)=-aggj(k,l)
3249               aggj1(k,l)=-aggj1(k,l)
3250             enddo
3251           enddo
3252           if (j.lt.nres-1) then
3253             a22=-a22
3254             a32=-a32
3255             do l=1,3,2
3256               do k=1,3
3257                 agg(k,l)=-agg(k,l)
3258                 aggi(k,l)=-aggi(k,l)
3259                 aggi1(k,l)=-aggi1(k,l)
3260                 aggj(k,l)=-aggj(k,l)
3261                 aggj1(k,l)=-aggj1(k,l)
3262               enddo
3263             enddo
3264           else
3265             a22=-a22
3266             a23=-a23
3267             a32=-a32
3268             a33=-a33
3269             do l=1,4
3270               do k=1,3
3271                 agg(k,l)=-agg(k,l)
3272                 aggi(k,l)=-aggi(k,l)
3273                 aggi1(k,l)=-aggi1(k,l)
3274                 aggj(k,l)=-aggj(k,l)
3275                 aggj1(k,l)=-aggj1(k,l)
3276               enddo
3277             enddo
3278           endif
3279           ENDIF ! WCORR
3280           IF (wel_loc.gt.0.0d0) THEN
3281 C Contribution to the local-electrostatic energy coming from the i-j pair
3282           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3283      &     +a33*muij(4)
3284 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3285
3286           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3287      &            'eelloc',i,j,eel_loc_ij
3288
3289           eel_loc=eel_loc+eel_loc_ij
3290 C Partial derivatives in virtual-bond dihedral angles gamma
3291           if (i.gt.1)
3292      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3293      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3294      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3295           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3296      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3297      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3298 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3299           do l=1,3
3300             ggg(l)=agg(l,1)*muij(1)+
3301      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3302             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3303             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3304 cgrad            ghalf=0.5d0*ggg(l)
3305 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3306 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3307           enddo
3308 cgrad          do k=i+1,j2
3309 cgrad            do l=1,3
3310 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3311 cgrad            enddo
3312 cgrad          enddo
3313 C Remaining derivatives of eello
3314           do l=1,3
3315             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3316      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3317             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3318      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3319             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3320      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3321             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3322      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3323           enddo
3324           ENDIF
3325 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3326 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3327           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3328      &       .and. num_conti.le.maxconts) then
3329 c            write (iout,*) i,j," entered corr"
3330 C
3331 C Calculate the contact function. The ith column of the array JCONT will
3332 C contain the numbers of atoms that make contacts with the atom I (of numbers
3333 C greater than I). The arrays FACONT and GACONT will contain the values of
3334 C the contact function and its derivative.
3335 c           r0ij=1.02D0*rpp(iteli,itelj)
3336 c           r0ij=1.11D0*rpp(iteli,itelj)
3337             r0ij=2.20D0*rpp(iteli,itelj)
3338 c           r0ij=1.55D0*rpp(iteli,itelj)
3339             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3340             if (fcont.gt.0.0D0) then
3341               num_conti=num_conti+1
3342               if (num_conti.gt.maxconts) then
3343                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3344      &                         ' will skip next contacts for this conf.'
3345               else
3346                 jcont_hb(num_conti,i)=j
3347 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3348 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3349                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3350      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3351 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3352 C  terms.
3353                 d_cont(num_conti,i)=rij
3354 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3355 C     --- Electrostatic-interaction matrix ---
3356                 a_chuj(1,1,num_conti,i)=a22
3357                 a_chuj(1,2,num_conti,i)=a23
3358                 a_chuj(2,1,num_conti,i)=a32
3359                 a_chuj(2,2,num_conti,i)=a33
3360 C     --- Gradient of rij
3361                 do kkk=1,3
3362                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3363                 enddo
3364                 kkll=0
3365                 do k=1,2
3366                   do l=1,2
3367                     kkll=kkll+1
3368                     do m=1,3
3369                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3370                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3371                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3372                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3373                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3374                     enddo
3375                   enddo
3376                 enddo
3377                 ENDIF
3378                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3379 C Calculate contact energies
3380                 cosa4=4.0D0*cosa
3381                 wij=cosa-3.0D0*cosb*cosg
3382                 cosbg1=cosb+cosg
3383                 cosbg2=cosb-cosg
3384 c               fac3=dsqrt(-ael6i)/r0ij**3
3385                 fac3=dsqrt(-ael6i)*r3ij
3386 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3387                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3388                 if (ees0tmp.gt.0) then
3389                   ees0pij=dsqrt(ees0tmp)
3390                 else
3391                   ees0pij=0
3392                 endif
3393 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3394                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3395                 if (ees0tmp.gt.0) then
3396                   ees0mij=dsqrt(ees0tmp)
3397                 else
3398                   ees0mij=0
3399                 endif
3400 c               ees0mij=0.0D0
3401                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3402                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3403 C Diagnostics. Comment out or remove after debugging!
3404 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3405 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3406 c               ees0m(num_conti,i)=0.0D0
3407 C End diagnostics.
3408 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3409 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3410 C Angular derivatives of the contact function
3411                 ees0pij1=fac3/ees0pij
3412                 ees0mij1=fac3/ees0mij
3413                 fac3p=-3.0D0*fac3*rrmij
3414                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3415                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3416 c               ees0mij1=0.0D0
3417                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3418                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3419                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3420                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3421                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3422                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3423                 ecosap=ecosa1+ecosa2
3424                 ecosbp=ecosb1+ecosb2
3425                 ecosgp=ecosg1+ecosg2
3426                 ecosam=ecosa1-ecosa2
3427                 ecosbm=ecosb1-ecosb2
3428                 ecosgm=ecosg1-ecosg2
3429 C Diagnostics
3430 c               ecosap=ecosa1
3431 c               ecosbp=ecosb1
3432 c               ecosgp=ecosg1
3433 c               ecosam=0.0D0
3434 c               ecosbm=0.0D0
3435 c               ecosgm=0.0D0
3436 C End diagnostics
3437                 facont_hb(num_conti,i)=fcont
3438                 fprimcont=fprimcont/rij
3439 cd              facont_hb(num_conti,i)=1.0D0
3440 C Following line is for diagnostics.
3441 cd              fprimcont=0.0D0
3442                 do k=1,3
3443                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3444                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3445                 enddo
3446                 do k=1,3
3447                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3448                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3449                 enddo
3450                 gggp(1)=gggp(1)+ees0pijp*xj
3451                 gggp(2)=gggp(2)+ees0pijp*yj
3452                 gggp(3)=gggp(3)+ees0pijp*zj
3453                 gggm(1)=gggm(1)+ees0mijp*xj
3454                 gggm(2)=gggm(2)+ees0mijp*yj
3455                 gggm(3)=gggm(3)+ees0mijp*zj
3456 C Derivatives due to the contact function
3457                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3458                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3459                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3460                 do k=1,3
3461 c
3462 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3463 c          following the change of gradient-summation algorithm.
3464 c
3465 cgrad                  ghalfp=0.5D0*gggp(k)
3466 cgrad                  ghalfm=0.5D0*gggm(k)
3467                   gacontp_hb1(k,num_conti,i)=!ghalfp
3468      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3469      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3470                   gacontp_hb2(k,num_conti,i)=!ghalfp
3471      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3472      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3473                   gacontp_hb3(k,num_conti,i)=gggp(k)
3474                   gacontm_hb1(k,num_conti,i)=!ghalfm
3475      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3476      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3477                   gacontm_hb2(k,num_conti,i)=!ghalfm
3478      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3479      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3480                   gacontm_hb3(k,num_conti,i)=gggm(k)
3481                 enddo
3482 C Diagnostics. Comment out or remove after debugging!
3483 cdiag           do k=1,3
3484 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3485 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3486 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3487 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3488 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3489 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3490 cdiag           enddo
3491               ENDIF ! wcorr
3492               endif  ! num_conti.le.maxconts
3493             endif  ! fcont.gt.0
3494           endif    ! j.gt.i+1
3495           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3496             do k=1,4
3497               do l=1,3
3498                 ghalf=0.5d0*agg(l,k)
3499                 aggi(l,k)=aggi(l,k)+ghalf
3500                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3501                 aggj(l,k)=aggj(l,k)+ghalf
3502               enddo
3503             enddo
3504             if (j.eq.nres-1 .and. i.lt.j-2) then
3505               do k=1,4
3506                 do l=1,3
3507                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3508                 enddo
3509               enddo
3510             endif
3511           endif
3512 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3513       return
3514       end
3515 C-----------------------------------------------------------------------------
3516       subroutine eturn3(i,eello_turn3)
3517 C Third- and fourth-order contributions from turns
3518       implicit real*8 (a-h,o-z)
3519       include 'DIMENSIONS'
3520       include 'COMMON.IOUNITS'
3521       include 'COMMON.GEO'
3522       include 'COMMON.VAR'
3523       include 'COMMON.LOCAL'
3524       include 'COMMON.CHAIN'
3525       include 'COMMON.DERIV'
3526       include 'COMMON.INTERACT'
3527       include 'COMMON.CONTACTS'
3528       include 'COMMON.TORSION'
3529       include 'COMMON.VECTORS'
3530       include 'COMMON.FFIELD'
3531       include 'COMMON.CONTROL'
3532       dimension ggg(3)
3533       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3534      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3535      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3536       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3537      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3538       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3539      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3540      &    num_conti,j1,j2
3541       j=i+2
3542 c      write (iout,*) "eturn3",i,j,j1,j2
3543       a_temp(1,1)=a22
3544       a_temp(1,2)=a23
3545       a_temp(2,1)=a32
3546       a_temp(2,2)=a33
3547 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3548 C
3549 C               Third-order contributions
3550 C
3551 C                 (i+2)o----(i+3)
3552 C                      | |
3553 C                      | |
3554 C                 (i+1)o----i
3555 C
3556 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3557 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3558         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3559         call transpose2(auxmat(1,1),auxmat1(1,1))
3560         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3561         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3562         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3563      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3564 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3565 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3566 cd     &    ' eello_turn3_num',4*eello_turn3_num
3567 C Derivatives in gamma(i)
3568         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3569         call transpose2(auxmat2(1,1),auxmat3(1,1))
3570         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3571         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3572 C Derivatives in gamma(i+1)
3573         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3574         call transpose2(auxmat2(1,1),auxmat3(1,1))
3575         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3576         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3577      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3578 C Cartesian derivatives
3579         do l=1,3
3580 c            ghalf1=0.5d0*agg(l,1)
3581 c            ghalf2=0.5d0*agg(l,2)
3582 c            ghalf3=0.5d0*agg(l,3)
3583 c            ghalf4=0.5d0*agg(l,4)
3584           a_temp(1,1)=aggi(l,1)!+ghalf1
3585           a_temp(1,2)=aggi(l,2)!+ghalf2
3586           a_temp(2,1)=aggi(l,3)!+ghalf3
3587           a_temp(2,2)=aggi(l,4)!+ghalf4
3588           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3589           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3590      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3591           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3592           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3593           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3594           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3595           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3596           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3597      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3598           a_temp(1,1)=aggj(l,1)!+ghalf1
3599           a_temp(1,2)=aggj(l,2)!+ghalf2
3600           a_temp(2,1)=aggj(l,3)!+ghalf3
3601           a_temp(2,2)=aggj(l,4)!+ghalf4
3602           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3603           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3604      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3605           a_temp(1,1)=aggj1(l,1)
3606           a_temp(1,2)=aggj1(l,2)
3607           a_temp(2,1)=aggj1(l,3)
3608           a_temp(2,2)=aggj1(l,4)
3609           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3610           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3611      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3612         enddo
3613       return
3614       end
3615 C-------------------------------------------------------------------------------
3616       subroutine eturn4(i,eello_turn4)
3617 C Third- and fourth-order contributions from turns
3618       implicit real*8 (a-h,o-z)
3619       include 'DIMENSIONS'
3620       include 'COMMON.IOUNITS'
3621       include 'COMMON.GEO'
3622       include 'COMMON.VAR'
3623       include 'COMMON.LOCAL'
3624       include 'COMMON.CHAIN'
3625       include 'COMMON.DERIV'
3626       include 'COMMON.INTERACT'
3627       include 'COMMON.CONTACTS'
3628       include 'COMMON.TORSION'
3629       include 'COMMON.VECTORS'
3630       include 'COMMON.FFIELD'
3631       include 'COMMON.CONTROL'
3632       dimension ggg(3)
3633       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3634      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3635      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3636       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3637      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3638       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3639      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3640      &    num_conti,j1,j2
3641       j=i+3
3642 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3643 C
3644 C               Fourth-order contributions
3645 C
3646 C                 (i+3)o----(i+4)
3647 C                     /  |
3648 C               (i+2)o   |
3649 C                     \  |
3650 C                 (i+1)o----i
3651 C
3652 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3653 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3654 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3655         a_temp(1,1)=a22
3656         a_temp(1,2)=a23
3657         a_temp(2,1)=a32
3658         a_temp(2,2)=a33
3659         iti1=itortyp(itype(i+1))
3660         iti2=itortyp(itype(i+2))
3661         iti3=itortyp(itype(i+3))
3662 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3663         call transpose2(EUg(1,1,i+1),e1t(1,1))
3664         call transpose2(Eug(1,1,i+2),e2t(1,1))
3665         call transpose2(Eug(1,1,i+3),e3t(1,1))
3666         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3667         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3668         s1=scalar2(b1(1,iti2),auxvec(1))
3669         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3670         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3671         s2=scalar2(b1(1,iti1),auxvec(1))
3672         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3673         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3674         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3675         eello_turn4=eello_turn4-(s1+s2+s3)
3676         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3677      &      'eturn4',i,j,-(s1+s2+s3)
3678 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3679 cd     &    ' eello_turn4_num',8*eello_turn4_num
3680 C Derivatives in gamma(i)
3681         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3682         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3683         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3684         s1=scalar2(b1(1,iti2),auxvec(1))
3685         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3686         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3687         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3688 C Derivatives in gamma(i+1)
3689         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3690         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3691         s2=scalar2(b1(1,iti1),auxvec(1))
3692         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3693         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3694         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3695         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3696 C Derivatives in gamma(i+2)
3697         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3698         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3699         s1=scalar2(b1(1,iti2),auxvec(1))
3700         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3701         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3702         s2=scalar2(b1(1,iti1),auxvec(1))
3703         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3704         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3705         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3706         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3707 C Cartesian derivatives
3708 C Derivatives of this turn contributions in DC(i+2)
3709         if (j.lt.nres-1) then
3710           do l=1,3
3711             a_temp(1,1)=agg(l,1)
3712             a_temp(1,2)=agg(l,2)
3713             a_temp(2,1)=agg(l,3)
3714             a_temp(2,2)=agg(l,4)
3715             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3716             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3717             s1=scalar2(b1(1,iti2),auxvec(1))
3718             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3719             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3720             s2=scalar2(b1(1,iti1),auxvec(1))
3721             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3722             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3723             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3724             ggg(l)=-(s1+s2+s3)
3725             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3726           enddo
3727         endif
3728 C Remaining derivatives of this turn contribution
3729         do l=1,3
3730           a_temp(1,1)=aggi(l,1)
3731           a_temp(1,2)=aggi(l,2)
3732           a_temp(2,1)=aggi(l,3)
3733           a_temp(2,2)=aggi(l,4)
3734           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3735           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3736           s1=scalar2(b1(1,iti2),auxvec(1))
3737           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3738           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3739           s2=scalar2(b1(1,iti1),auxvec(1))
3740           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3741           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3742           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3743           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3744           a_temp(1,1)=aggi1(l,1)
3745           a_temp(1,2)=aggi1(l,2)
3746           a_temp(2,1)=aggi1(l,3)
3747           a_temp(2,2)=aggi1(l,4)
3748           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3749           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3750           s1=scalar2(b1(1,iti2),auxvec(1))
3751           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3752           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3753           s2=scalar2(b1(1,iti1),auxvec(1))
3754           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3755           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3756           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3757           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3758           a_temp(1,1)=aggj(l,1)
3759           a_temp(1,2)=aggj(l,2)
3760           a_temp(2,1)=aggj(l,3)
3761           a_temp(2,2)=aggj(l,4)
3762           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3763           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3764           s1=scalar2(b1(1,iti2),auxvec(1))
3765           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3766           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3767           s2=scalar2(b1(1,iti1),auxvec(1))
3768           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3769           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3770           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3771           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3772           a_temp(1,1)=aggj1(l,1)
3773           a_temp(1,2)=aggj1(l,2)
3774           a_temp(2,1)=aggj1(l,3)
3775           a_temp(2,2)=aggj1(l,4)
3776           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3777           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3778           s1=scalar2(b1(1,iti2),auxvec(1))
3779           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3780           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3781           s2=scalar2(b1(1,iti1),auxvec(1))
3782           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3783           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3784           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3785 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3786           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3787         enddo
3788       return
3789       end
3790 C-----------------------------------------------------------------------------
3791       subroutine vecpr(u,v,w)
3792       implicit real*8(a-h,o-z)
3793       dimension u(3),v(3),w(3)
3794       w(1)=u(2)*v(3)-u(3)*v(2)
3795       w(2)=-u(1)*v(3)+u(3)*v(1)
3796       w(3)=u(1)*v(2)-u(2)*v(1)
3797       return
3798       end
3799 C-----------------------------------------------------------------------------
3800       subroutine unormderiv(u,ugrad,unorm,ungrad)
3801 C This subroutine computes the derivatives of a normalized vector u, given
3802 C the derivatives computed without normalization conditions, ugrad. Returns
3803 C ungrad.
3804       implicit none
3805       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3806       double precision vec(3)
3807       double precision scalar
3808       integer i,j
3809 c      write (2,*) 'ugrad',ugrad
3810 c      write (2,*) 'u',u
3811       do i=1,3
3812         vec(i)=scalar(ugrad(1,i),u(1))
3813       enddo
3814 c      write (2,*) 'vec',vec
3815       do i=1,3
3816         do j=1,3
3817           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3818         enddo
3819       enddo
3820 c      write (2,*) 'ungrad',ungrad
3821       return
3822       end
3823 C-----------------------------------------------------------------------------
3824       subroutine escp_soft_sphere(evdw2,evdw2_14)
3825 C
3826 C This subroutine calculates the excluded-volume interaction energy between
3827 C peptide-group centers and side chains and its gradient in virtual-bond and
3828 C side-chain vectors.
3829 C
3830       implicit real*8 (a-h,o-z)
3831       include 'DIMENSIONS'
3832       include 'COMMON.GEO'
3833       include 'COMMON.VAR'
3834       include 'COMMON.LOCAL'
3835       include 'COMMON.CHAIN'
3836       include 'COMMON.DERIV'
3837       include 'COMMON.INTERACT'
3838       include 'COMMON.FFIELD'
3839       include 'COMMON.IOUNITS'
3840       include 'COMMON.CONTROL'
3841       dimension ggg(3)
3842       evdw2=0.0D0
3843       evdw2_14=0.0d0
3844       r0_scp=4.5d0
3845 cd    print '(a)','Enter ESCP'
3846 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3847       do i=iatscp_s,iatscp_e
3848         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3849         iteli=itel(i)
3850         xi=0.5D0*(c(1,i)+c(1,i+1))
3851         yi=0.5D0*(c(2,i)+c(2,i+1))
3852         zi=0.5D0*(c(3,i)+c(3,i+1))
3853
3854         do iint=1,nscp_gr(i)
3855
3856         do j=iscpstart(i,iint),iscpend(i,iint)
3857           if (itype(j).eq.21) cycle
3858           itypj=itype(j)
3859 C Uncomment following three lines for SC-p interactions
3860 c         xj=c(1,nres+j)-xi
3861 c         yj=c(2,nres+j)-yi
3862 c         zj=c(3,nres+j)-zi
3863 C Uncomment following three lines for Ca-p interactions
3864           xj=c(1,j)-xi
3865           yj=c(2,j)-yi
3866           zj=c(3,j)-zi
3867           rij=xj*xj+yj*yj+zj*zj
3868           r0ij=r0_scp
3869           r0ijsq=r0ij*r0ij
3870           if (rij.lt.r0ijsq) then
3871             evdwij=0.25d0*(rij-r0ijsq)**2
3872             fac=rij-r0ijsq
3873           else
3874             evdwij=0.0d0
3875             fac=0.0d0
3876           endif
3877           evdw2=evdw2+evdwij
3878 C
3879 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3880 C
3881           ggg(1)=xj*fac
3882           ggg(2)=yj*fac
3883           ggg(3)=zj*fac
3884 cgrad          if (j.lt.i) then
3885 cd          write (iout,*) 'j<i'
3886 C Uncomment following three lines for SC-p interactions
3887 c           do k=1,3
3888 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3889 c           enddo
3890 cgrad          else
3891 cd          write (iout,*) 'j>i'
3892 cgrad            do k=1,3
3893 cgrad              ggg(k)=-ggg(k)
3894 C Uncomment following line for SC-p interactions
3895 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3896 cgrad            enddo
3897 cgrad          endif
3898 cgrad          do k=1,3
3899 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3900 cgrad          enddo
3901 cgrad          kstart=min0(i+1,j)
3902 cgrad          kend=max0(i-1,j-1)
3903 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3904 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3905 cgrad          do k=kstart,kend
3906 cgrad            do l=1,3
3907 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3908 cgrad            enddo
3909 cgrad          enddo
3910           do k=1,3
3911             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3912             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3913           enddo
3914         enddo
3915
3916         enddo ! iint
3917       enddo ! i
3918       return
3919       end
3920 C-----------------------------------------------------------------------------
3921       subroutine escp(evdw2,evdw2_14)
3922 C
3923 C This subroutine calculates the excluded-volume interaction energy between
3924 C peptide-group centers and side chains and its gradient in virtual-bond and
3925 C side-chain vectors.
3926 C
3927       implicit real*8 (a-h,o-z)
3928       include 'DIMENSIONS'
3929       include 'COMMON.GEO'
3930       include 'COMMON.VAR'
3931       include 'COMMON.LOCAL'
3932       include 'COMMON.CHAIN'
3933       include 'COMMON.DERIV'
3934       include 'COMMON.INTERACT'
3935       include 'COMMON.FFIELD'
3936       include 'COMMON.IOUNITS'
3937       include 'COMMON.CONTROL'
3938       dimension ggg(3)
3939       evdw2=0.0D0
3940       evdw2_14=0.0d0
3941 cd    print '(a)','Enter ESCP'
3942 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3943       do i=iatscp_s,iatscp_e
3944         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3945         iteli=itel(i)
3946         xi=0.5D0*(c(1,i)+c(1,i+1))
3947         yi=0.5D0*(c(2,i)+c(2,i+1))
3948         zi=0.5D0*(c(3,i)+c(3,i+1))
3949
3950         do iint=1,nscp_gr(i)
3951
3952         do j=iscpstart(i,iint),iscpend(i,iint)
3953           itypj=itype(j)
3954           if (itypj.eq.21) cycle
3955 C Uncomment following three lines for SC-p interactions
3956 c         xj=c(1,nres+j)-xi
3957 c         yj=c(2,nres+j)-yi
3958 c         zj=c(3,nres+j)-zi
3959 C Uncomment following three lines for Ca-p interactions
3960           xj=c(1,j)-xi
3961           yj=c(2,j)-yi
3962           zj=c(3,j)-zi
3963           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3964           fac=rrij**expon2
3965           e1=fac*fac*aad(itypj,iteli)
3966           e2=fac*bad(itypj,iteli)
3967           if (iabs(j-i) .le. 2) then
3968             e1=scal14*e1
3969             e2=scal14*e2
3970             evdw2_14=evdw2_14+e1+e2
3971           endif
3972           evdwij=e1+e2
3973           evdw2=evdw2+evdwij
3974           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3975      &        'evdw2',i,j,evdwij
3976 C
3977 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3978 C
3979           fac=-(evdwij+e1)*rrij
3980           ggg(1)=xj*fac
3981           ggg(2)=yj*fac
3982           ggg(3)=zj*fac
3983 cgrad          if (j.lt.i) then
3984 cd          write (iout,*) 'j<i'
3985 C Uncomment following three lines for SC-p interactions
3986 c           do k=1,3
3987 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3988 c           enddo
3989 cgrad          else
3990 cd          write (iout,*) 'j>i'
3991 cgrad            do k=1,3
3992 cgrad              ggg(k)=-ggg(k)
3993 C Uncomment following line for SC-p interactions
3994 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3995 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3996 cgrad            enddo
3997 cgrad          endif
3998 cgrad          do k=1,3
3999 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4000 cgrad          enddo
4001 cgrad          kstart=min0(i+1,j)
4002 cgrad          kend=max0(i-1,j-1)
4003 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4004 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4005 cgrad          do k=kstart,kend
4006 cgrad            do l=1,3
4007 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4008 cgrad            enddo
4009 cgrad          enddo
4010           do k=1,3
4011             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4012             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4013           enddo
4014         enddo
4015
4016         enddo ! iint
4017       enddo ! i
4018       do i=1,nct
4019         do j=1,3
4020           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4021           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4022           gradx_scp(j,i)=expon*gradx_scp(j,i)
4023         enddo
4024       enddo
4025 C******************************************************************************
4026 C
4027 C                              N O T E !!!
4028 C
4029 C To save time the factor EXPON has been extracted from ALL components
4030 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4031 C use!
4032 C
4033 C******************************************************************************
4034       return
4035       end
4036 C--------------------------------------------------------------------------
4037       subroutine edis(ehpb)
4038 C
4039 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4040 C
4041       implicit real*8 (a-h,o-z)
4042       include 'DIMENSIONS'
4043       include 'COMMON.SBRIDGE'
4044       include 'COMMON.CHAIN'
4045       include 'COMMON.DERIV'
4046       include 'COMMON.VAR'
4047       include 'COMMON.INTERACT'
4048       include 'COMMON.IOUNITS'
4049       dimension ggg(3)
4050       ehpb=0.0D0
4051 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4052 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4053       if (link_end.eq.0) return
4054       do i=link_start,link_end
4055 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4056 C CA-CA distance used in regularization of structure.
4057         ii=ihpb(i)
4058         jj=jhpb(i)
4059 C iii and jjj point to the residues for which the distance is assigned.
4060         if (ii.gt.nres) then
4061           iii=ii-nres
4062           jjj=jj-nres
4063         else
4064           iii=ii
4065           jjj=jj
4066         endif
4067 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4068 c     &    dhpb(i),dhpb1(i),forcon(i)
4069 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4070 C    distance and angle dependent SS bond potential.
4071 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4072 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4073         if (.not.dyn_ss .and. i.le.nss) then
4074 C 15/02/13 CC dynamic SSbond - additional check
4075          if (ii.gt.nres
4076      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4077           call ssbond_ene(iii,jjj,eij)
4078           ehpb=ehpb+2*eij
4079          endif
4080 cd          write (iout,*) "eij",eij
4081         else
4082 C Calculate the distance between the two points and its difference from the
4083 C target distance.
4084           dd=dist(ii,jj)
4085             rdis=dd-dhpb(i)
4086 C Get the force constant corresponding to this distance.
4087             waga=forcon(i)
4088 C Calculate the contribution to energy.
4089             ehpb=ehpb+waga*rdis*rdis
4090 C
4091 C Evaluate gradient.
4092 C
4093             fac=waga*rdis/dd
4094 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4095 cd   &   ' waga=',waga,' fac=',fac
4096             do j=1,3
4097               ggg(j)=fac*(c(j,jj)-c(j,ii))
4098             enddo
4099 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4100 C If this is a SC-SC distance, we need to calculate the contributions to the
4101 C Cartesian gradient in the SC vectors (ghpbx).
4102           if (iii.lt.ii) then
4103           do j=1,3
4104             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4105             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4106           enddo
4107           endif
4108 cgrad        do j=iii,jjj-1
4109 cgrad          do k=1,3
4110 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4111 cgrad          enddo
4112 cgrad        enddo
4113           do k=1,3
4114             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4115             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4116           enddo
4117         endif
4118       enddo
4119       ehpb=0.5D0*ehpb
4120       return
4121       end
4122 C--------------------------------------------------------------------------
4123       subroutine ssbond_ene(i,j,eij)
4124 C
4125 C Calculate the distance and angle dependent SS-bond potential energy
4126 C using a free-energy function derived based on RHF/6-31G** ab initio
4127 C calculations of diethyl disulfide.
4128 C
4129 C A. Liwo and U. Kozlowska, 11/24/03
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.SBRIDGE'
4134       include 'COMMON.CHAIN'
4135       include 'COMMON.DERIV'
4136       include 'COMMON.LOCAL'
4137       include 'COMMON.INTERACT'
4138       include 'COMMON.VAR'
4139       include 'COMMON.IOUNITS'
4140       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4141       itypi=itype(i)
4142       xi=c(1,nres+i)
4143       yi=c(2,nres+i)
4144       zi=c(3,nres+i)
4145       dxi=dc_norm(1,nres+i)
4146       dyi=dc_norm(2,nres+i)
4147       dzi=dc_norm(3,nres+i)
4148 c      dsci_inv=dsc_inv(itypi)
4149       dsci_inv=vbld_inv(nres+i)
4150       itypj=itype(j)
4151 c      dscj_inv=dsc_inv(itypj)
4152       dscj_inv=vbld_inv(nres+j)
4153       xj=c(1,nres+j)-xi
4154       yj=c(2,nres+j)-yi
4155       zj=c(3,nres+j)-zi
4156       dxj=dc_norm(1,nres+j)
4157       dyj=dc_norm(2,nres+j)
4158       dzj=dc_norm(3,nres+j)
4159       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4160       rij=dsqrt(rrij)
4161       erij(1)=xj*rij
4162       erij(2)=yj*rij
4163       erij(3)=zj*rij
4164       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4165       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4166       om12=dxi*dxj+dyi*dyj+dzi*dzj
4167       do k=1,3
4168         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4169         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4170       enddo
4171       rij=1.0d0/rij
4172       deltad=rij-d0cm
4173       deltat1=1.0d0-om1
4174       deltat2=1.0d0+om2
4175       deltat12=om2-om1+2.0d0
4176       cosphi=om12-om1*om2
4177       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4178      &  +akct*deltad*deltat12
4179      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4180 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4181 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4182 c     &  " deltat12",deltat12," eij",eij
4183       ed=2*akcm*deltad+akct*deltat12
4184       pom1=akct*deltad
4185       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4186       eom1=-2*akth*deltat1-pom1-om2*pom2
4187       eom2= 2*akth*deltat2+pom1-om1*pom2
4188       eom12=pom2
4189       do k=1,3
4190         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4191         ghpbx(k,i)=ghpbx(k,i)-ggk
4192      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4193      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4194         ghpbx(k,j)=ghpbx(k,j)+ggk
4195      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4196      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4197         ghpbc(k,i)=ghpbc(k,i)-ggk
4198         ghpbc(k,j)=ghpbc(k,j)+ggk
4199       enddo
4200 C
4201 C Calculate the components of the gradient in DC and X
4202 C
4203 cgrad      do k=i,j-1
4204 cgrad        do l=1,3
4205 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4206 cgrad        enddo
4207 cgrad      enddo
4208       return
4209       end
4210 C--------------------------------------------------------------------------
4211       subroutine ebond(estr)
4212 c
4213 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4214 c
4215       implicit real*8 (a-h,o-z)
4216       include 'DIMENSIONS'
4217       include 'COMMON.LOCAL'
4218       include 'COMMON.GEO'
4219       include 'COMMON.INTERACT'
4220       include 'COMMON.DERIV'
4221       include 'COMMON.VAR'
4222       include 'COMMON.CHAIN'
4223       include 'COMMON.IOUNITS'
4224       include 'COMMON.NAMES'
4225       include 'COMMON.FFIELD'
4226       include 'COMMON.CONTROL'
4227       include 'COMMON.SETUP'
4228       double precision u(3),ud(3)
4229       estr=0.0d0
4230       estr1=0.0d0
4231       do i=ibondp_start,ibondp_end
4232         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4233           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4234           do j=1,3
4235           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4236      &      *dc(j,i-1)/vbld(i)
4237           enddo
4238           if (energy_dec) write(iout,*)
4239      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4240         else
4241         diff = vbld(i)-vbldp0
4242         if (energy_dec) write (iout,*)
4243      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4244         estr=estr+diff*diff
4245         do j=1,3
4246           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4247         enddo
4248 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4249         endif
4250       enddo
4251       estr=0.5d0*AKP*estr+estr1
4252 c
4253 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4254 c
4255       do i=ibond_start,ibond_end
4256         iti=itype(i)
4257         if (iti.ne.10 .and. iti.ne.21) then
4258           nbi=nbondterm(iti)
4259           if (nbi.eq.1) then
4260             diff=vbld(i+nres)-vbldsc0(1,iti)
4261             if (energy_dec) write (iout,*)
4262      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4263      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4264             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4265             do j=1,3
4266               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4267             enddo
4268           else
4269             do j=1,nbi
4270               diff=vbld(i+nres)-vbldsc0(j,iti)
4271               ud(j)=aksc(j,iti)*diff
4272               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4273             enddo
4274             uprod=u(1)
4275             do j=2,nbi
4276               uprod=uprod*u(j)
4277             enddo
4278             usum=0.0d0
4279             usumsqder=0.0d0
4280             do j=1,nbi
4281               uprod1=1.0d0
4282               uprod2=1.0d0
4283               do k=1,nbi
4284                 if (k.ne.j) then
4285                   uprod1=uprod1*u(k)
4286                   uprod2=uprod2*u(k)*u(k)
4287                 endif
4288               enddo
4289               usum=usum+uprod1
4290               usumsqder=usumsqder+ud(j)*uprod2
4291             enddo
4292             estr=estr+uprod/usum
4293             do j=1,3
4294              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4295             enddo
4296           endif
4297         endif
4298       enddo
4299       return
4300       end
4301 #ifdef CRYST_THETA
4302 C--------------------------------------------------------------------------
4303       subroutine ebend(etheta)
4304 C
4305 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4306 C angles gamma and its derivatives in consecutive thetas and gammas.
4307 C
4308       implicit real*8 (a-h,o-z)
4309       include 'DIMENSIONS'
4310       include 'COMMON.LOCAL'
4311       include 'COMMON.GEO'
4312       include 'COMMON.INTERACT'
4313       include 'COMMON.DERIV'
4314       include 'COMMON.VAR'
4315       include 'COMMON.CHAIN'
4316       include 'COMMON.IOUNITS'
4317       include 'COMMON.NAMES'
4318       include 'COMMON.FFIELD'
4319       include 'COMMON.CONTROL'
4320       common /calcthet/ term1,term2,termm,diffak,ratak,
4321      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4322      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4323       double precision y(2),z(2)
4324       delta=0.02d0*pi
4325 c      time11=dexp(-2*time)
4326 c      time12=1.0d0
4327       etheta=0.0D0
4328 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4329       do i=ithet_start,ithet_end
4330         if (itype(i-1).eq.21) cycle
4331 C Zero the energy function and its derivative at 0 or pi.
4332         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4333         it=itype(i-1)
4334         if (i.gt.3 .and. itype(i-2).ne.21) 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.21) 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)
4368           bthetk=bthet(k,it)
4369           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4370         enddo
4371         dthett=thet_pred_mean*ssd
4372         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4373 C Derivatives of the "mean" values in gamma1 and gamma2.
4374         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4375         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4376         if (theta(i).gt.pi-delta) then
4377           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4378      &         E_tc0)
4379           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4380           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4381           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4382      &        E_theta)
4383           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4384      &        E_tc)
4385         else if (theta(i).lt.delta) then
4386           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4387           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4388           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4389      &        E_theta)
4390           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4391           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4392      &        E_tc)
4393         else
4394           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4395      &        E_theta,E_tc)
4396         endif
4397         etheta=etheta+ethetai
4398         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4399      &      'ebend',i,ethetai
4400         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4401         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4402         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4403       enddo
4404 C Ufff.... We've done all this!!!
4405       return
4406       end
4407 C---------------------------------------------------------------------------
4408       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4409      &     E_tc)
4410       implicit real*8 (a-h,o-z)
4411       include 'DIMENSIONS'
4412       include 'COMMON.LOCAL'
4413       include 'COMMON.IOUNITS'
4414       common /calcthet/ term1,term2,termm,diffak,ratak,
4415      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4416      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4417 C Calculate the contributions to both Gaussian lobes.
4418 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4419 C The "polynomial part" of the "standard deviation" of this part of
4420 C the distribution.
4421         sig=polthet(3,it)
4422         do j=2,0,-1
4423           sig=sig*thet_pred_mean+polthet(j,it)
4424         enddo
4425 C Derivative of the "interior part" of the "standard deviation of the"
4426 C gamma-dependent Gaussian lobe in t_c.
4427         sigtc=3*polthet(3,it)
4428         do j=2,1,-1
4429           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4430         enddo
4431         sigtc=sig*sigtc
4432 C Set the parameters of both Gaussian lobes of the distribution.
4433 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4434         fac=sig*sig+sigc0(it)
4435         sigcsq=fac+fac
4436         sigc=1.0D0/sigcsq
4437 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4438         sigsqtc=-4.0D0*sigcsq*sigtc
4439 c       print *,i,sig,sigtc,sigsqtc
4440 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4441         sigtc=-sigtc/(fac*fac)
4442 C Following variable is sigma(t_c)**(-2)
4443         sigcsq=sigcsq*sigcsq
4444         sig0i=sig0(it)
4445         sig0inv=1.0D0/sig0i**2
4446         delthec=thetai-thet_pred_mean
4447         delthe0=thetai-theta0i
4448         term1=-0.5D0*sigcsq*delthec*delthec
4449         term2=-0.5D0*sig0inv*delthe0*delthe0
4450 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4451 C NaNs in taking the logarithm. We extract the largest exponent which is added
4452 C to the energy (this being the log of the distribution) at the end of energy
4453 C term evaluation for this virtual-bond angle.
4454         if (term1.gt.term2) then
4455           termm=term1
4456           term2=dexp(term2-termm)
4457           term1=1.0d0
4458         else
4459           termm=term2
4460           term1=dexp(term1-termm)
4461           term2=1.0d0
4462         endif
4463 C The ratio between the gamma-independent and gamma-dependent lobes of
4464 C the distribution is a Gaussian function of thet_pred_mean too.
4465         diffak=gthet(2,it)-thet_pred_mean
4466         ratak=diffak/gthet(3,it)**2
4467         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4468 C Let's differentiate it in thet_pred_mean NOW.
4469         aktc=ak*ratak
4470 C Now put together the distribution terms to make complete distribution.
4471         termexp=term1+ak*term2
4472         termpre=sigc+ak*sig0i
4473 C Contribution of the bending energy from this theta is just the -log of
4474 C the sum of the contributions from the two lobes and the pre-exponential
4475 C factor. Simple enough, isn't it?
4476         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4477 C NOW the derivatives!!!
4478 C 6/6/97 Take into account the deformation.
4479         E_theta=(delthec*sigcsq*term1
4480      &       +ak*delthe0*sig0inv*term2)/termexp
4481         E_tc=((sigtc+aktc*sig0i)/termpre
4482      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4483      &       aktc*term2)/termexp)
4484       return
4485       end
4486 c-----------------------------------------------------------------------------
4487       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4488       implicit real*8 (a-h,o-z)
4489       include 'DIMENSIONS'
4490       include 'COMMON.LOCAL'
4491       include 'COMMON.IOUNITS'
4492       common /calcthet/ term1,term2,termm,diffak,ratak,
4493      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4494      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4495       delthec=thetai-thet_pred_mean
4496       delthe0=thetai-theta0i
4497 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4498       t3 = thetai-thet_pred_mean
4499       t6 = t3**2
4500       t9 = term1
4501       t12 = t3*sigcsq
4502       t14 = t12+t6*sigsqtc
4503       t16 = 1.0d0
4504       t21 = thetai-theta0i
4505       t23 = t21**2
4506       t26 = term2
4507       t27 = t21*t26
4508       t32 = termexp
4509       t40 = t32**2
4510       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4511      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4512      & *(-t12*t9-ak*sig0inv*t27)
4513       return
4514       end
4515 #else
4516 C--------------------------------------------------------------------------
4517       subroutine ebend(etheta)
4518 C
4519 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4520 C angles gamma and its derivatives in consecutive thetas and gammas.
4521 C ab initio-derived potentials from
4522 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4523 C
4524       implicit real*8 (a-h,o-z)
4525       include 'DIMENSIONS'
4526       include 'COMMON.LOCAL'
4527       include 'COMMON.GEO'
4528       include 'COMMON.INTERACT'
4529       include 'COMMON.DERIV'
4530       include 'COMMON.VAR'
4531       include 'COMMON.CHAIN'
4532       include 'COMMON.IOUNITS'
4533       include 'COMMON.NAMES'
4534       include 'COMMON.FFIELD'
4535       include 'COMMON.CONTROL'
4536       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4537      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4538      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4539      & sinph1ph2(maxdouble,maxdouble)
4540       logical lprn /.false./, lprn1 /.false./
4541       etheta=0.0D0
4542       do i=ithet_start,ithet_end
4543         if (itype(i-1).eq.21) cycle
4544         dethetai=0.0d0
4545         dephii=0.0d0
4546         dephii1=0.0d0
4547         theti2=0.5d0*theta(i)
4548         ityp2=ithetyp(itype(i-1))
4549         do k=1,nntheterm
4550           coskt(k)=dcos(k*theti2)
4551           sinkt(k)=dsin(k*theti2)
4552         enddo
4553         if (i.gt.3 .and. itype(i-2).ne.21) then
4554 #ifdef OSF
4555           phii=phi(i)
4556           if (phii.ne.phii) phii=150.0
4557 #else
4558           phii=phi(i)
4559 #endif
4560           ityp1=ithetyp(itype(i-2))
4561           do k=1,nsingle
4562             cosph1(k)=dcos(k*phii)
4563             sinph1(k)=dsin(k*phii)
4564           enddo
4565         else
4566           phii=0.0d0
4567           ityp1=nthetyp+1
4568           do k=1,nsingle
4569             cosph1(k)=0.0d0
4570             sinph1(k)=0.0d0
4571           enddo
4572         endif
4573         if (i.lt.nres .and. itype(i).ne.21) then
4574 #ifdef OSF
4575           phii1=phi(i+1)
4576           if (phii1.ne.phii1) phii1=150.0
4577           phii1=pinorm(phii1)
4578 #else
4579           phii1=phi(i+1)
4580 #endif
4581           ityp3=ithetyp(itype(i))
4582           do k=1,nsingle
4583             cosph2(k)=dcos(k*phii1)
4584             sinph2(k)=dsin(k*phii1)
4585           enddo
4586         else
4587           phii1=0.0d0
4588           ityp3=nthetyp+1
4589           do k=1,nsingle
4590             cosph2(k)=0.0d0
4591             sinph2(k)=0.0d0
4592           enddo
4593         endif
4594         ethetai=aa0thet(ityp1,ityp2,ityp3)
4595         do k=1,ndouble
4596           do l=1,k-1
4597             ccl=cosph1(l)*cosph2(k-l)
4598             ssl=sinph1(l)*sinph2(k-l)
4599             scl=sinph1(l)*cosph2(k-l)
4600             csl=cosph1(l)*sinph2(k-l)
4601             cosph1ph2(l,k)=ccl-ssl
4602             cosph1ph2(k,l)=ccl+ssl
4603             sinph1ph2(l,k)=scl+csl
4604             sinph1ph2(k,l)=scl-csl
4605           enddo
4606         enddo
4607         if (lprn) then
4608         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4609      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4610         write (iout,*) "coskt and sinkt"
4611         do k=1,nntheterm
4612           write (iout,*) k,coskt(k),sinkt(k)
4613         enddo
4614         endif
4615         do k=1,ntheterm
4616           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4617           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4618      &      *coskt(k)
4619           if (lprn)
4620      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4621      &     " ethetai",ethetai
4622         enddo
4623         if (lprn) then
4624         write (iout,*) "cosph and sinph"
4625         do k=1,nsingle
4626           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4627         enddo
4628         write (iout,*) "cosph1ph2 and sinph2ph2"
4629         do k=2,ndouble
4630           do l=1,k-1
4631             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4632      &         sinph1ph2(l,k),sinph1ph2(k,l)
4633           enddo
4634         enddo
4635         write(iout,*) "ethetai",ethetai
4636         endif
4637         do m=1,ntheterm2
4638           do k=1,nsingle
4639             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4640      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4641      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4642      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4643             ethetai=ethetai+sinkt(m)*aux
4644             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4645             dephii=dephii+k*sinkt(m)*(
4646      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4647      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4648             dephii1=dephii1+k*sinkt(m)*(
4649      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4650      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4651             if (lprn)
4652      &      write (iout,*) "m",m," k",k," bbthet",
4653      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4654      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4655      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4656      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4657           enddo
4658         enddo
4659         if (lprn)
4660      &  write(iout,*) "ethetai",ethetai
4661         do m=1,ntheterm3
4662           do k=2,ndouble
4663             do l=1,k-1
4664               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4665      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4666      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4667      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4668               ethetai=ethetai+sinkt(m)*aux
4669               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4670               dephii=dephii+l*sinkt(m)*(
4671      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4672      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4673      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4674      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4675               dephii1=dephii1+(k-l)*sinkt(m)*(
4676      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4677      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4678      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4679      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4680               if (lprn) then
4681               write (iout,*) "m",m," k",k," l",l," ffthet",
4682      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4683      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4684      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4685      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4686               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4687      &            cosph1ph2(k,l)*sinkt(m),
4688      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4689               endif
4690             enddo
4691           enddo
4692         enddo
4693 10      continue
4694         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4695      &   i,theta(i)*rad2deg,phii*rad2deg,
4696      &   phii1*rad2deg,ethetai
4697         etheta=etheta+ethetai
4698         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4699         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4700         gloc(nphi+i-2,icg)=wang*dethetai
4701       enddo
4702       return
4703       end
4704 #endif
4705 #ifdef CRYST_SC
4706 c-----------------------------------------------------------------------------
4707       subroutine esc(escloc)
4708 C Calculate the local energy of a side chain and its derivatives in the
4709 C corresponding virtual-bond valence angles THETA and the spherical angles
4710 C ALPHA and OMEGA.
4711       implicit real*8 (a-h,o-z)
4712       include 'DIMENSIONS'
4713       include 'COMMON.GEO'
4714       include 'COMMON.LOCAL'
4715       include 'COMMON.VAR'
4716       include 'COMMON.INTERACT'
4717       include 'COMMON.DERIV'
4718       include 'COMMON.CHAIN'
4719       include 'COMMON.IOUNITS'
4720       include 'COMMON.NAMES'
4721       include 'COMMON.FFIELD'
4722       include 'COMMON.CONTROL'
4723       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4724      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4725       common /sccalc/ time11,time12,time112,theti,it,nlobit
4726       delta=0.02d0*pi
4727       escloc=0.0D0
4728 c     write (iout,'(a)') 'ESC'
4729       do i=loc_start,loc_end
4730         it=itype(i)
4731         if (it.eq.21) cycle
4732         if (it.eq.10) goto 1
4733         nlobit=nlob(it)
4734 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4735 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4736         theti=theta(i+1)-pipol
4737         x(1)=dtan(theti)
4738         x(2)=alph(i)
4739         x(3)=omeg(i)
4740
4741         if (x(2).gt.pi-delta) then
4742           xtemp(1)=x(1)
4743           xtemp(2)=pi-delta
4744           xtemp(3)=x(3)
4745           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4746           xtemp(2)=pi
4747           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4748           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4749      &        escloci,dersc(2))
4750           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4751      &        ddersc0(1),dersc(1))
4752           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4753      &        ddersc0(3),dersc(3))
4754           xtemp(2)=pi-delta
4755           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4756           xtemp(2)=pi
4757           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4758           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4759      &            dersc0(2),esclocbi,dersc02)
4760           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4761      &            dersc12,dersc01)
4762           call splinthet(x(2),0.5d0*delta,ss,ssd)
4763           dersc0(1)=dersc01
4764           dersc0(2)=dersc02
4765           dersc0(3)=0.0d0
4766           do k=1,3
4767             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4768           enddo
4769           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4770 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4771 c    &             esclocbi,ss,ssd
4772           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4773 c         escloci=esclocbi
4774 c         write (iout,*) escloci
4775         else if (x(2).lt.delta) then
4776           xtemp(1)=x(1)
4777           xtemp(2)=delta
4778           xtemp(3)=x(3)
4779           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4780           xtemp(2)=0.0d0
4781           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4782           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4783      &        escloci,dersc(2))
4784           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4785      &        ddersc0(1),dersc(1))
4786           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4787      &        ddersc0(3),dersc(3))
4788           xtemp(2)=delta
4789           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4790           xtemp(2)=0.0d0
4791           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4792           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4793      &            dersc0(2),esclocbi,dersc02)
4794           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4795      &            dersc12,dersc01)
4796           dersc0(1)=dersc01
4797           dersc0(2)=dersc02
4798           dersc0(3)=0.0d0
4799           call splinthet(x(2),0.5d0*delta,ss,ssd)
4800           do k=1,3
4801             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4802           enddo
4803           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4804 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4805 c    &             esclocbi,ss,ssd
4806           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4807 c         write (iout,*) escloci
4808         else
4809           call enesc(x,escloci,dersc,ddummy,.false.)
4810         endif
4811
4812         escloc=escloc+escloci
4813         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4814      &     'escloc',i,escloci
4815 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4816
4817         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4818      &   wscloc*dersc(1)
4819         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4820         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4821     1   continue
4822       enddo
4823       return
4824       end
4825 C---------------------------------------------------------------------------
4826       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4827       implicit real*8 (a-h,o-z)
4828       include 'DIMENSIONS'
4829       include 'COMMON.GEO'
4830       include 'COMMON.LOCAL'
4831       include 'COMMON.IOUNITS'
4832       common /sccalc/ time11,time12,time112,theti,it,nlobit
4833       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4834       double precision contr(maxlob,-1:1)
4835       logical mixed
4836 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4837         escloc_i=0.0D0
4838         do j=1,3
4839           dersc(j)=0.0D0
4840           if (mixed) ddersc(j)=0.0d0
4841         enddo
4842         x3=x(3)
4843
4844 C Because of periodicity of the dependence of the SC energy in omega we have
4845 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4846 C To avoid underflows, first compute & store the exponents.
4847
4848         do iii=-1,1
4849
4850           x(3)=x3+iii*dwapi
4851
4852           do j=1,nlobit
4853             do k=1,3
4854               z(k)=x(k)-censc(k,j,it)
4855             enddo
4856             do k=1,3
4857               Axk=0.0D0
4858               do l=1,3
4859                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4860               enddo
4861               Ax(k,j,iii)=Axk
4862             enddo
4863             expfac=0.0D0
4864             do k=1,3
4865               expfac=expfac+Ax(k,j,iii)*z(k)
4866             enddo
4867             contr(j,iii)=expfac
4868           enddo ! j
4869
4870         enddo ! iii
4871
4872         x(3)=x3
4873 C As in the case of ebend, we want to avoid underflows in exponentiation and
4874 C subsequent NaNs and INFs in energy calculation.
4875 C Find the largest exponent
4876         emin=contr(1,-1)
4877         do iii=-1,1
4878           do j=1,nlobit
4879             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4880           enddo
4881         enddo
4882         emin=0.5D0*emin
4883 cd      print *,'it=',it,' emin=',emin
4884
4885 C Compute the contribution to SC energy and derivatives
4886         do iii=-1,1
4887
4888           do j=1,nlobit
4889 #ifdef OSF
4890             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4891             if(adexp.ne.adexp) adexp=1.0
4892             expfac=dexp(adexp)
4893 #else
4894             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4895 #endif
4896 cd          print *,'j=',j,' expfac=',expfac
4897             escloc_i=escloc_i+expfac
4898             do k=1,3
4899               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4900             enddo
4901             if (mixed) then
4902               do k=1,3,2
4903                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4904      &            +gaussc(k,2,j,it))*expfac
4905               enddo
4906             endif
4907           enddo
4908
4909         enddo ! iii
4910
4911         dersc(1)=dersc(1)/cos(theti)**2
4912         ddersc(1)=ddersc(1)/cos(theti)**2
4913         ddersc(3)=ddersc(3)
4914
4915         escloci=-(dlog(escloc_i)-emin)
4916         do j=1,3
4917           dersc(j)=dersc(j)/escloc_i
4918         enddo
4919         if (mixed) then
4920           do j=1,3,2
4921             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4922           enddo
4923         endif
4924       return
4925       end
4926 C------------------------------------------------------------------------------
4927       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4928       implicit real*8 (a-h,o-z)
4929       include 'DIMENSIONS'
4930       include 'COMMON.GEO'
4931       include 'COMMON.LOCAL'
4932       include 'COMMON.IOUNITS'
4933       common /sccalc/ time11,time12,time112,theti,it,nlobit
4934       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4935       double precision contr(maxlob)
4936       logical mixed
4937
4938       escloc_i=0.0D0
4939
4940       do j=1,3
4941         dersc(j)=0.0D0
4942       enddo
4943
4944       do j=1,nlobit
4945         do k=1,2
4946           z(k)=x(k)-censc(k,j,it)
4947         enddo
4948         z(3)=dwapi
4949         do k=1,3
4950           Axk=0.0D0
4951           do l=1,3
4952             Axk=Axk+gaussc(l,k,j,it)*z(l)
4953           enddo
4954           Ax(k,j)=Axk
4955         enddo
4956         expfac=0.0D0
4957         do k=1,3
4958           expfac=expfac+Ax(k,j)*z(k)
4959         enddo
4960         contr(j)=expfac
4961       enddo ! j
4962
4963 C As in the case of ebend, we want to avoid underflows in exponentiation and
4964 C subsequent NaNs and INFs in energy calculation.
4965 C Find the largest exponent
4966       emin=contr(1)
4967       do j=1,nlobit
4968         if (emin.gt.contr(j)) emin=contr(j)
4969       enddo
4970       emin=0.5D0*emin
4971
4972 C Compute the contribution to SC energy and derivatives
4973
4974       dersc12=0.0d0
4975       do j=1,nlobit
4976         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4977         escloc_i=escloc_i+expfac
4978         do k=1,2
4979           dersc(k)=dersc(k)+Ax(k,j)*expfac
4980         enddo
4981         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4982      &            +gaussc(1,2,j,it))*expfac
4983         dersc(3)=0.0d0
4984       enddo
4985
4986       dersc(1)=dersc(1)/cos(theti)**2
4987       dersc12=dersc12/cos(theti)**2
4988       escloci=-(dlog(escloc_i)-emin)
4989       do j=1,2
4990         dersc(j)=dersc(j)/escloc_i
4991       enddo
4992       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4993       return
4994       end
4995 #else
4996 c----------------------------------------------------------------------------------
4997       subroutine esc(escloc)
4998 C Calculate the local energy of a side chain and its derivatives in the
4999 C corresponding virtual-bond valence angles THETA and the spherical angles
5000 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5001 C added by Urszula Kozlowska. 07/11/2007
5002 C
5003       implicit real*8 (a-h,o-z)
5004       include 'DIMENSIONS'
5005       include 'COMMON.GEO'
5006       include 'COMMON.LOCAL'
5007       include 'COMMON.VAR'
5008       include 'COMMON.SCROT'
5009       include 'COMMON.INTERACT'
5010       include 'COMMON.DERIV'
5011       include 'COMMON.CHAIN'
5012       include 'COMMON.IOUNITS'
5013       include 'COMMON.NAMES'
5014       include 'COMMON.FFIELD'
5015       include 'COMMON.CONTROL'
5016       include 'COMMON.VECTORS'
5017       double precision x_prime(3),y_prime(3),z_prime(3)
5018      &    , sumene,dsc_i,dp2_i,x(65),
5019      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5020      &    de_dxx,de_dyy,de_dzz,de_dt
5021       double precision s1_t,s1_6_t,s2_t,s2_6_t
5022       double precision
5023      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5024      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5025      & dt_dCi(3),dt_dCi1(3)
5026       common /sccalc/ time11,time12,time112,theti,it,nlobit
5027       delta=0.02d0*pi
5028       escloc=0.0D0
5029       do i=loc_start,loc_end
5030         if (itype(i).eq.21) cycle
5031         costtab(i+1) =dcos(theta(i+1))
5032         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5033         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5034         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5035         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5036         cosfac=dsqrt(cosfac2)
5037         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5038         sinfac=dsqrt(sinfac2)
5039         it=itype(i)
5040         if (it.eq.10) goto 1
5041 c
5042 C  Compute the axes of tghe local cartesian coordinates system; store in
5043 c   x_prime, y_prime and z_prime
5044 c
5045         do j=1,3
5046           x_prime(j) = 0.00
5047           y_prime(j) = 0.00
5048           z_prime(j) = 0.00
5049         enddo
5050 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5051 C     &   dc_norm(3,i+nres)
5052         do j = 1,3
5053           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5054           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5055         enddo
5056         do j = 1,3
5057           z_prime(j) = -uz(j,i-1)
5058         enddo
5059 c       write (2,*) "i",i
5060 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5061 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5062 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5063 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5064 c      & " xy",scalar(x_prime(1),y_prime(1)),
5065 c      & " xz",scalar(x_prime(1),z_prime(1)),
5066 c      & " yy",scalar(y_prime(1),y_prime(1)),
5067 c      & " yz",scalar(y_prime(1),z_prime(1)),
5068 c      & " zz",scalar(z_prime(1),z_prime(1))
5069 c
5070 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5071 C to local coordinate system. Store in xx, yy, zz.
5072 c
5073         xx=0.0d0
5074         yy=0.0d0
5075         zz=0.0d0
5076         do j = 1,3
5077           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5078           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5079           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5080         enddo
5081
5082         xxtab(i)=xx
5083         yytab(i)=yy
5084         zztab(i)=zz
5085 C
5086 C Compute the energy of the ith side cbain
5087 C
5088 c        write (2,*) "xx",xx," yy",yy," zz",zz
5089         it=itype(i)
5090         do j = 1,65
5091           x(j) = sc_parmin(j,it)
5092         enddo
5093 #ifdef CHECK_COORD
5094 Cc diagnostics - remove later
5095         xx1 = dcos(alph(2))
5096         yy1 = dsin(alph(2))*dcos(omeg(2))
5097         zz1 = -dsin(alph(2))*dsin(omeg(2))
5098         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5099      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5100      &    xx1,yy1,zz1
5101 C,"  --- ", xx_w,yy_w,zz_w
5102 c end diagnostics
5103 #endif
5104         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5105      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5106      &   + x(10)*yy*zz
5107         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5108      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5109      & + x(20)*yy*zz
5110         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5111      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5112      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5113      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5114      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5115      &  +x(40)*xx*yy*zz
5116         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5117      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5118      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5119      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5120      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5121      &  +x(60)*xx*yy*zz
5122         dsc_i   = 0.743d0+x(61)
5123         dp2_i   = 1.9d0+x(62)
5124         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5125      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5126         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5127      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5128         s1=(1+x(63))/(0.1d0 + dscp1)
5129         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5130         s2=(1+x(65))/(0.1d0 + dscp2)
5131         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5132         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5133      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5134 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5135 c     &   sumene4,
5136 c     &   dscp1,dscp2,sumene
5137 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5138         escloc = escloc + sumene
5139 c        write (2,*) "i",i," escloc",sumene,escloc
5140 #ifdef DEBUG
5141 C
5142 C This section to check the numerical derivatives of the energy of ith side
5143 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5144 C #define DEBUG in the code to turn it on.
5145 C
5146         write (2,*) "sumene               =",sumene
5147         aincr=1.0d-7
5148         xxsave=xx
5149         xx=xx+aincr
5150         write (2,*) xx,yy,zz
5151         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5152         de_dxx_num=(sumenep-sumene)/aincr
5153         xx=xxsave
5154         write (2,*) "xx+ sumene from enesc=",sumenep
5155         yysave=yy
5156         yy=yy+aincr
5157         write (2,*) xx,yy,zz
5158         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5159         de_dyy_num=(sumenep-sumene)/aincr
5160         yy=yysave
5161         write (2,*) "yy+ sumene from enesc=",sumenep
5162         zzsave=zz
5163         zz=zz+aincr
5164         write (2,*) xx,yy,zz
5165         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5166         de_dzz_num=(sumenep-sumene)/aincr
5167         zz=zzsave
5168         write (2,*) "zz+ sumene from enesc=",sumenep
5169         costsave=cost2tab(i+1)
5170         sintsave=sint2tab(i+1)
5171         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5172         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5173         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5174         de_dt_num=(sumenep-sumene)/aincr
5175         write (2,*) " t+ sumene from enesc=",sumenep
5176         cost2tab(i+1)=costsave
5177         sint2tab(i+1)=sintsave
5178 C End of diagnostics section.
5179 #endif
5180 C
5181 C Compute the gradient of esc
5182 C
5183         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5184         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5185         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5186         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5187         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5188         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5189         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5190         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5191         pom1=(sumene3*sint2tab(i+1)+sumene1)
5192      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5193         pom2=(sumene4*cost2tab(i+1)+sumene2)
5194      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5195         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5196         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5197      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5198      &  +x(40)*yy*zz
5199         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5200         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5201      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5202      &  +x(60)*yy*zz
5203         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5204      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5205      &        +(pom1+pom2)*pom_dx
5206 #ifdef DEBUG
5207         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5208 #endif
5209 C
5210         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5211         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5212      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5213      &  +x(40)*xx*zz
5214         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5215         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5216      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5217      &  +x(59)*zz**2 +x(60)*xx*zz
5218         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5219      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5220      &        +(pom1-pom2)*pom_dy
5221 #ifdef DEBUG
5222         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5223 #endif
5224 C
5225         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5226      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5227      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5228      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5229      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5230      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5231      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5232      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5233 #ifdef DEBUG
5234         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5235 #endif
5236 C
5237         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5238      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5239      &  +pom1*pom_dt1+pom2*pom_dt2
5240 #ifdef DEBUG
5241         write(2,*), "de_dt = ", de_dt,de_dt_num
5242 #endif
5243 c
5244 C
5245        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5246        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5247        cosfac2xx=cosfac2*xx
5248        sinfac2yy=sinfac2*yy
5249        do k = 1,3
5250          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5251      &      vbld_inv(i+1)
5252          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5253      &      vbld_inv(i)
5254          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5255          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5256 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5257 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5258 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5259 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5260          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5261          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5262          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5263          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5264          dZZ_Ci1(k)=0.0d0
5265          dZZ_Ci(k)=0.0d0
5266          do j=1,3
5267            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5268            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5269          enddo
5270
5271          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5272          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5273          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5274 c
5275          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5276          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5277        enddo
5278
5279        do k=1,3
5280          dXX_Ctab(k,i)=dXX_Ci(k)
5281          dXX_C1tab(k,i)=dXX_Ci1(k)
5282          dYY_Ctab(k,i)=dYY_Ci(k)
5283          dYY_C1tab(k,i)=dYY_Ci1(k)
5284          dZZ_Ctab(k,i)=dZZ_Ci(k)
5285          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5286          dXX_XYZtab(k,i)=dXX_XYZ(k)
5287          dYY_XYZtab(k,i)=dYY_XYZ(k)
5288          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5289        enddo
5290
5291        do k = 1,3
5292 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5293 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5294 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5295 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5296 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5297 c     &    dt_dci(k)
5298 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5299 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5300          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5301      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5302          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5303      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5304          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5305      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5306        enddo
5307 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5308 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5309
5310 C to check gradient call subroutine check_grad
5311
5312     1 continue
5313       enddo
5314       return
5315       end
5316 c------------------------------------------------------------------------------
5317       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5318       implicit none
5319       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5320      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5321       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5322      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5323      &   + x(10)*yy*zz
5324       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5325      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5326      & + x(20)*yy*zz
5327       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5328      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5329      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5330      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5331      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5332      &  +x(40)*xx*yy*zz
5333       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5334      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5335      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5336      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5337      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5338      &  +x(60)*xx*yy*zz
5339       dsc_i   = 0.743d0+x(61)
5340       dp2_i   = 1.9d0+x(62)
5341       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5342      &          *(xx*cost2+yy*sint2))
5343       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5344      &          *(xx*cost2-yy*sint2))
5345       s1=(1+x(63))/(0.1d0 + dscp1)
5346       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5347       s2=(1+x(65))/(0.1d0 + dscp2)
5348       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5349       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5350      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5351       enesc=sumene
5352       return
5353       end
5354 #endif
5355 c------------------------------------------------------------------------------
5356       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5357 C
5358 C This procedure calculates two-body contact function g(rij) and its derivative:
5359 C
5360 C           eps0ij                                     !       x < -1
5361 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5362 C            0                                         !       x > 1
5363 C
5364 C where x=(rij-r0ij)/delta
5365 C
5366 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5367 C
5368       implicit none
5369       double precision rij,r0ij,eps0ij,fcont,fprimcont
5370       double precision x,x2,x4,delta
5371 c     delta=0.02D0*r0ij
5372 c      delta=0.2D0*r0ij
5373       x=(rij-r0ij)/delta
5374       if (x.lt.-1.0D0) then
5375         fcont=eps0ij
5376         fprimcont=0.0D0
5377       else if (x.le.1.0D0) then
5378         x2=x*x
5379         x4=x2*x2
5380         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5381         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5382       else
5383         fcont=0.0D0
5384         fprimcont=0.0D0
5385       endif
5386       return
5387       end
5388 c------------------------------------------------------------------------------
5389       subroutine splinthet(theti,delta,ss,ssder)
5390       implicit real*8 (a-h,o-z)
5391       include 'DIMENSIONS'
5392       include 'COMMON.VAR'
5393       include 'COMMON.GEO'
5394       thetup=pi-delta
5395       thetlow=delta
5396       if (theti.gt.pipol) then
5397         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5398       else
5399         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5400         ssder=-ssder
5401       endif
5402       return
5403       end
5404 c------------------------------------------------------------------------------
5405       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5406       implicit none
5407       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5408       double precision ksi,ksi2,ksi3,a1,a2,a3
5409       a1=fprim0*delta/(f1-f0)
5410       a2=3.0d0-2.0d0*a1
5411       a3=a1-2.0d0
5412       ksi=(x-x0)/delta
5413       ksi2=ksi*ksi
5414       ksi3=ksi2*ksi
5415       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5416       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5417       return
5418       end
5419 c------------------------------------------------------------------------------
5420       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5421       implicit none
5422       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5423       double precision ksi,ksi2,ksi3,a1,a2,a3
5424       ksi=(x-x0)/delta
5425       ksi2=ksi*ksi
5426       ksi3=ksi2*ksi
5427       a1=fprim0x*delta
5428       a2=3*(f1x-f0x)-2*fprim0x*delta
5429       a3=fprim0x*delta-2*(f1x-f0x)
5430       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5431       return
5432       end
5433 C-----------------------------------------------------------------------------
5434 #ifdef CRYST_TOR
5435 C-----------------------------------------------------------------------------
5436       subroutine etor(etors,edihcnstr)
5437       implicit real*8 (a-h,o-z)
5438       include 'DIMENSIONS'
5439       include 'COMMON.VAR'
5440       include 'COMMON.GEO'
5441       include 'COMMON.LOCAL'
5442       include 'COMMON.TORSION'
5443       include 'COMMON.INTERACT'
5444       include 'COMMON.DERIV'
5445       include 'COMMON.CHAIN'
5446       include 'COMMON.NAMES'
5447       include 'COMMON.IOUNITS'
5448       include 'COMMON.FFIELD'
5449       include 'COMMON.TORCNSTR'
5450       include 'COMMON.CONTROL'
5451       logical lprn
5452 C Set lprn=.true. for debugging
5453       lprn=.false.
5454 c      lprn=.true.
5455       etors=0.0D0
5456       do i=iphi_start,iphi_end
5457       etors_ii=0.0D0
5458         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5459      &      .or. itype(i).eq.21) cycle
5460         itori=itortyp(itype(i-2))
5461         itori1=itortyp(itype(i-1))
5462         phii=phi(i)
5463         gloci=0.0D0
5464 C Proline-Proline pair is a special case...
5465         if (itori.eq.3 .and. itori1.eq.3) then
5466           if (phii.gt.-dwapi3) then
5467             cosphi=dcos(3*phii)
5468             fac=1.0D0/(1.0D0-cosphi)
5469             etorsi=v1(1,3,3)*fac
5470             etorsi=etorsi+etorsi
5471             etors=etors+etorsi-v1(1,3,3)
5472             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5473             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5474           endif
5475           do j=1,3
5476             v1ij=v1(j+1,itori,itori1)
5477             v2ij=v2(j+1,itori,itori1)
5478             cosphi=dcos(j*phii)
5479             sinphi=dsin(j*phii)
5480             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5481             if (energy_dec) etors_ii=etors_ii+
5482      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5483             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5484           enddo
5485         else
5486           do j=1,nterm_old
5487             v1ij=v1(j,itori,itori1)
5488             v2ij=v2(j,itori,itori1)
5489             cosphi=dcos(j*phii)
5490             sinphi=dsin(j*phii)
5491             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5492             if (energy_dec) etors_ii=etors_ii+
5493      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5494             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5495           enddo
5496         endif
5497         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5498              'etor',i,etors_ii
5499         if (lprn)
5500      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5501      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5502      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5503         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5504 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5505       enddo
5506 ! 6/20/98 - dihedral angle constraints
5507       edihcnstr=0.0d0
5508       do i=1,ndih_constr
5509         itori=idih_constr(i)
5510         phii=phi(itori)
5511         difi=phii-phi0(i)
5512         if (difi.gt.drange(i)) then
5513           difi=difi-drange(i)
5514           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5515           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5516         else if (difi.lt.-drange(i)) then
5517           difi=difi+drange(i)
5518           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5519           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5520         endif
5521 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5522 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5523       enddo
5524 !      write (iout,*) 'edihcnstr',edihcnstr
5525       return
5526       end
5527 c------------------------------------------------------------------------------
5528       subroutine etor_d(etors_d)
5529       etors_d=0.0d0
5530       return
5531       end
5532 c----------------------------------------------------------------------------
5533 #else
5534       subroutine etor(etors,edihcnstr)
5535       implicit real*8 (a-h,o-z)
5536       include 'DIMENSIONS'
5537       include 'COMMON.VAR'
5538       include 'COMMON.GEO'
5539       include 'COMMON.LOCAL'
5540       include 'COMMON.TORSION'
5541       include 'COMMON.INTERACT'
5542       include 'COMMON.DERIV'
5543       include 'COMMON.CHAIN'
5544       include 'COMMON.NAMES'
5545       include 'COMMON.IOUNITS'
5546       include 'COMMON.FFIELD'
5547       include 'COMMON.TORCNSTR'
5548       include 'COMMON.CONTROL'
5549       logical lprn
5550 C Set lprn=.true. for debugging
5551       lprn=.false.
5552 c     lprn=.true.
5553       etors=0.0D0
5554       do i=iphi_start,iphi_end
5555         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5556      &       .or. itype(i).eq.21) cycle
5557       etors_ii=0.0D0
5558         itori=itortyp(itype(i-2))
5559         itori1=itortyp(itype(i-1))
5560         phii=phi(i)
5561         gloci=0.0D0
5562 C Regular cosine and sine terms
5563         do j=1,nterm(itori,itori1)
5564           v1ij=v1(j,itori,itori1)
5565           v2ij=v2(j,itori,itori1)
5566           cosphi=dcos(j*phii)
5567           sinphi=dsin(j*phii)
5568           etors=etors+v1ij*cosphi+v2ij*sinphi
5569           if (energy_dec) etors_ii=etors_ii+
5570      &                v1ij*cosphi+v2ij*sinphi
5571           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5572         enddo
5573 C Lorentz terms
5574 C                         v1
5575 C  E = SUM ----------------------------------- - v1
5576 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5577 C
5578         cosphi=dcos(0.5d0*phii)
5579         sinphi=dsin(0.5d0*phii)
5580         do j=1,nlor(itori,itori1)
5581           vl1ij=vlor1(j,itori,itori1)
5582           vl2ij=vlor2(j,itori,itori1)
5583           vl3ij=vlor3(j,itori,itori1)
5584           pom=vl2ij*cosphi+vl3ij*sinphi
5585           pom1=1.0d0/(pom*pom+1.0d0)
5586           etors=etors+vl1ij*pom1
5587           if (energy_dec) etors_ii=etors_ii+
5588      &                vl1ij*pom1
5589           pom=-pom*pom1*pom1
5590           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5591         enddo
5592 C Subtract the constant term
5593         etors=etors-v0(itori,itori1)
5594           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5595      &         'etor',i,etors_ii-v0(itori,itori1)
5596         if (lprn)
5597      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5598      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5599      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5600         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5601 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5602       enddo
5603 ! 6/20/98 - dihedral angle constraints
5604       edihcnstr=0.0d0
5605 c      do i=1,ndih_constr
5606       do i=idihconstr_start,idihconstr_end
5607         itori=idih_constr(i)
5608         phii=phi(itori)
5609         difi=pinorm(phii-phi0(i))
5610         if (difi.gt.drange(i)) then
5611           difi=difi-drange(i)
5612           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5613           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5614         else if (difi.lt.-drange(i)) then
5615           difi=difi+drange(i)
5616           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5617           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5618         else
5619           difi=0.0
5620         endif
5621 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5622 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5623 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5624       enddo
5625 cd       write (iout,*) 'edihcnstr',edihcnstr
5626       return
5627       end
5628 c----------------------------------------------------------------------------
5629       subroutine etor_d(etors_d)
5630 C 6/23/01 Compute double torsional energy
5631       implicit real*8 (a-h,o-z)
5632       include 'DIMENSIONS'
5633       include 'COMMON.VAR'
5634       include 'COMMON.GEO'
5635       include 'COMMON.LOCAL'
5636       include 'COMMON.TORSION'
5637       include 'COMMON.INTERACT'
5638       include 'COMMON.DERIV'
5639       include 'COMMON.CHAIN'
5640       include 'COMMON.NAMES'
5641       include 'COMMON.IOUNITS'
5642       include 'COMMON.FFIELD'
5643       include 'COMMON.TORCNSTR'
5644       logical lprn
5645 C Set lprn=.true. for debugging
5646       lprn=.false.
5647 c     lprn=.true.
5648       etors_d=0.0D0
5649 c      write(iout,*) "a tu??"
5650       do i=iphid_start,iphid_end
5651         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5652      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
5653         itori=itortyp(itype(i-2))
5654         itori1=itortyp(itype(i-1))
5655         itori2=itortyp(itype(i))
5656         phii=phi(i)
5657         phii1=phi(i+1)
5658         gloci1=0.0D0
5659         gloci2=0.0D0
5660 C Regular cosine and sine terms
5661         do j=1,ntermd_1(itori,itori1,itori2)
5662           v1cij=v1c(1,j,itori,itori1,itori2)
5663           v1sij=v1s(1,j,itori,itori1,itori2)
5664           v2cij=v1c(2,j,itori,itori1,itori2)
5665           v2sij=v1s(2,j,itori,itori1,itori2)
5666           cosphi1=dcos(j*phii)
5667           sinphi1=dsin(j*phii)
5668           cosphi2=dcos(j*phii1)
5669           sinphi2=dsin(j*phii1)
5670           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5671      &     v2cij*cosphi2+v2sij*sinphi2
5672           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5673           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5674         enddo
5675         do k=2,ntermd_2(itori,itori1,itori2)
5676           do l=1,k-1
5677             v1cdij = v2c(k,l,itori,itori1,itori2)
5678             v2cdij = v2c(l,k,itori,itori1,itori2)
5679             v1sdij = v2s(k,l,itori,itori1,itori2)
5680             v2sdij = v2s(l,k,itori,itori1,itori2)
5681             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5682             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5683             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5684             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5685             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5686      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5687             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5688      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5689             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5690      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5691           enddo
5692         enddo
5693         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5694         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5695       enddo
5696       return
5697       end
5698 #endif
5699 c------------------------------------------------------------------------------
5700       subroutine eback_sc_corr(esccor)
5701 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5702 c        conformational states; temporarily implemented as differences
5703 c        between UNRES torsional potentials (dependent on three types of
5704 c        residues) and the torsional potentials dependent on all 20 types
5705 c        of residues computed from AM1  energy surfaces of terminally-blocked
5706 c        amino-acid residues.
5707       implicit real*8 (a-h,o-z)
5708       include 'DIMENSIONS'
5709       include 'COMMON.VAR'
5710       include 'COMMON.GEO'
5711       include 'COMMON.LOCAL'
5712       include 'COMMON.TORSION'
5713       include 'COMMON.SCCOR'
5714       include 'COMMON.INTERACT'
5715       include 'COMMON.DERIV'
5716       include 'COMMON.CHAIN'
5717       include 'COMMON.NAMES'
5718       include 'COMMON.IOUNITS'
5719       include 'COMMON.FFIELD'
5720       include 'COMMON.CONTROL'
5721       logical lprn
5722 C Set lprn=.true. for debugging
5723       lprn=.false.
5724 c      lprn=.true.
5725 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5726       esccor=0.0D0
5727       do i=itau_start,itau_end
5728         esccor_ii=0.0D0
5729         isccori=isccortyp(itype(i-2))
5730         isccori1=isccortyp(itype(i-1))
5731 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5732         phii=phi(i)
5733         do intertyp=1,3 !intertyp
5734 cc Added 09 May 2012 (Adasko)
5735 cc  Intertyp means interaction type of backbone mainchain correlation:
5736 c   1 = SC...Ca...Ca...Ca
5737 c   2 = Ca...Ca...Ca...SC
5738 c   3 = SC...Ca...Ca...SCi
5739         gloci=0.0D0
5740         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5741      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5742      &      (itype(i-1).eq.ntyp1)))
5743      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5744      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5745      &     .or.(itype(i).eq.ntyp1)))
5746      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5747      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5748      &      (itype(i-3).eq.ntyp1)))) cycle
5749         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5750         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5751      & cycle
5752        do j=1,nterm_sccor(isccori,isccori1)
5753           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5754           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5755           cosphi=dcos(j*tauangle(intertyp,i))
5756           sinphi=dsin(j*tauangle(intertyp,i))
5757           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5758           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5759         enddo
5760 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5761         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5762         if (lprn)
5763      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5764      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5765      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5766      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5767         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5768        enddo !intertyp
5769       enddo
5770
5771       return
5772       end
5773 c----------------------------------------------------------------------------
5774       subroutine multibody(ecorr)
5775 C This subroutine calculates multi-body contributions to energy following
5776 C the idea of Skolnick et al. If side chains I and J make a contact and
5777 C at the same time side chains I+1 and J+1 make a contact, an extra
5778 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5779       implicit real*8 (a-h,o-z)
5780       include 'DIMENSIONS'
5781       include 'COMMON.IOUNITS'
5782       include 'COMMON.DERIV'
5783       include 'COMMON.INTERACT'
5784       include 'COMMON.CONTACTS'
5785       double precision gx(3),gx1(3)
5786       logical lprn
5787
5788 C Set lprn=.true. for debugging
5789       lprn=.false.
5790
5791       if (lprn) then
5792         write (iout,'(a)') 'Contact function values:'
5793         do i=nnt,nct-2
5794           write (iout,'(i2,20(1x,i2,f10.5))')
5795      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5796         enddo
5797       endif
5798       ecorr=0.0D0
5799       do i=nnt,nct
5800         do j=1,3
5801           gradcorr(j,i)=0.0D0
5802           gradxorr(j,i)=0.0D0
5803         enddo
5804       enddo
5805       do i=nnt,nct-2
5806
5807         DO ISHIFT = 3,4
5808
5809         i1=i+ishift
5810         num_conti=num_cont(i)
5811         num_conti1=num_cont(i1)
5812         do jj=1,num_conti
5813           j=jcont(jj,i)
5814           do kk=1,num_conti1
5815             j1=jcont(kk,i1)
5816             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5817 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5818 cd   &                   ' ishift=',ishift
5819 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5820 C The system gains extra energy.
5821               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5822             endif   ! j1==j+-ishift
5823           enddo     ! kk
5824         enddo       ! jj
5825
5826         ENDDO ! ISHIFT
5827
5828       enddo         ! i
5829       return
5830       end
5831 c------------------------------------------------------------------------------
5832       double precision function esccorr(i,j,k,l,jj,kk)
5833       implicit real*8 (a-h,o-z)
5834       include 'DIMENSIONS'
5835       include 'COMMON.IOUNITS'
5836       include 'COMMON.DERIV'
5837       include 'COMMON.INTERACT'
5838       include 'COMMON.CONTACTS'
5839       double precision gx(3),gx1(3)
5840       logical lprn
5841       lprn=.false.
5842       eij=facont(jj,i)
5843       ekl=facont(kk,k)
5844 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5845 C Calculate the multi-body contribution to energy.
5846 C Calculate multi-body contributions to the gradient.
5847 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5848 cd   & k,l,(gacont(m,kk,k),m=1,3)
5849       do m=1,3
5850         gx(m) =ekl*gacont(m,jj,i)
5851         gx1(m)=eij*gacont(m,kk,k)
5852         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5853         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5854         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5855         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5856       enddo
5857       do m=i,j-1
5858         do ll=1,3
5859           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5860         enddo
5861       enddo
5862       do m=k,l-1
5863         do ll=1,3
5864           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5865         enddo
5866       enddo
5867       esccorr=-eij*ekl
5868       return
5869       end
5870 c------------------------------------------------------------------------------
5871       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5872 C This subroutine calculates multi-body contributions to hydrogen-bonding
5873       implicit real*8 (a-h,o-z)
5874       include 'DIMENSIONS'
5875       include 'COMMON.IOUNITS'
5876 #ifdef MPI
5877       include "mpif.h"
5878       parameter (max_cont=maxconts)
5879       parameter (max_dim=26)
5880       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5881       double precision zapas(max_dim,maxconts,max_fg_procs),
5882      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5883       common /przechowalnia/ zapas
5884       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5885      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5886 #endif
5887       include 'COMMON.SETUP'
5888       include 'COMMON.FFIELD'
5889       include 'COMMON.DERIV'
5890       include 'COMMON.INTERACT'
5891       include 'COMMON.CONTACTS'
5892       include 'COMMON.CONTROL'
5893       include 'COMMON.LOCAL'
5894       double precision gx(3),gx1(3),time00
5895       logical lprn,ldone
5896
5897 C Set lprn=.true. for debugging
5898       lprn=.false.
5899 #ifdef MPI
5900       n_corr=0
5901       n_corr1=0
5902       if (nfgtasks.le.1) goto 30
5903       if (lprn) then
5904         write (iout,'(a)') 'Contact function values before RECEIVE:'
5905         do i=nnt,nct-2
5906           write (iout,'(2i3,50(1x,i2,f5.2))')
5907      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5908      &    j=1,num_cont_hb(i))
5909         enddo
5910       endif
5911       call flush(iout)
5912       do i=1,ntask_cont_from
5913         ncont_recv(i)=0
5914       enddo
5915       do i=1,ntask_cont_to
5916         ncont_sent(i)=0
5917       enddo
5918 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5919 c     & ntask_cont_to
5920 C Make the list of contacts to send to send to other procesors
5921 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5922 c      call flush(iout)
5923       do i=iturn3_start,iturn3_end
5924 c        write (iout,*) "make contact list turn3",i," num_cont",
5925 c     &    num_cont_hb(i)
5926         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5927       enddo
5928       do i=iturn4_start,iturn4_end
5929 c        write (iout,*) "make contact list turn4",i," num_cont",
5930 c     &   num_cont_hb(i)
5931         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5932       enddo
5933       do ii=1,nat_sent
5934         i=iat_sent(ii)
5935 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5936 c     &    num_cont_hb(i)
5937         do j=1,num_cont_hb(i)
5938         do k=1,4
5939           jjc=jcont_hb(j,i)
5940           iproc=iint_sent_local(k,jjc,ii)
5941 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5942           if (iproc.gt.0) then
5943             ncont_sent(iproc)=ncont_sent(iproc)+1
5944             nn=ncont_sent(iproc)
5945             zapas(1,nn,iproc)=i
5946             zapas(2,nn,iproc)=jjc
5947             zapas(3,nn,iproc)=facont_hb(j,i)
5948             zapas(4,nn,iproc)=ees0p(j,i)
5949             zapas(5,nn,iproc)=ees0m(j,i)
5950             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5951             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5952             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5953             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5954             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5955             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5956             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5957             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5958             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5959             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5960             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5961             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5962             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5963             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5964             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5965             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5966             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5967             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5968             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5969             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5970             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5971           endif
5972         enddo
5973         enddo
5974       enddo
5975       if (lprn) then
5976       write (iout,*)
5977      &  "Numbers of contacts to be sent to other processors",
5978      &  (ncont_sent(i),i=1,ntask_cont_to)
5979       write (iout,*) "Contacts sent"
5980       do ii=1,ntask_cont_to
5981         nn=ncont_sent(ii)
5982         iproc=itask_cont_to(ii)
5983         write (iout,*) nn," contacts to processor",iproc,
5984      &   " of CONT_TO_COMM group"
5985         do i=1,nn
5986           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5987         enddo
5988       enddo
5989       call flush(iout)
5990       endif
5991       CorrelType=477
5992       CorrelID=fg_rank+1
5993       CorrelType1=478
5994       CorrelID1=nfgtasks+fg_rank+1
5995       ireq=0
5996 C Receive the numbers of needed contacts from other processors
5997       do ii=1,ntask_cont_from
5998         iproc=itask_cont_from(ii)
5999         ireq=ireq+1
6000         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6001      &    FG_COMM,req(ireq),IERR)
6002       enddo
6003 c      write (iout,*) "IRECV ended"
6004 c      call flush(iout)
6005 C Send the number of contacts needed by other processors
6006       do ii=1,ntask_cont_to
6007         iproc=itask_cont_to(ii)
6008         ireq=ireq+1
6009         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6010      &    FG_COMM,req(ireq),IERR)
6011       enddo
6012 c      write (iout,*) "ISEND ended"
6013 c      write (iout,*) "number of requests (nn)",ireq
6014       call flush(iout)
6015       if (ireq.gt.0)
6016      &  call MPI_Waitall(ireq,req,status_array,ierr)
6017 c      write (iout,*)
6018 c     &  "Numbers of contacts to be received from other processors",
6019 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6020 c      call flush(iout)
6021 C Receive contacts
6022       ireq=0
6023       do ii=1,ntask_cont_from
6024         iproc=itask_cont_from(ii)
6025         nn=ncont_recv(ii)
6026 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6027 c     &   " of CONT_TO_COMM group"
6028         call flush(iout)
6029         if (nn.gt.0) then
6030           ireq=ireq+1
6031           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6032      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6033 c          write (iout,*) "ireq,req",ireq,req(ireq)
6034         endif
6035       enddo
6036 C Send the contacts to processors that need them
6037       do ii=1,ntask_cont_to
6038         iproc=itask_cont_to(ii)
6039         nn=ncont_sent(ii)
6040 c        write (iout,*) nn," contacts to processor",iproc,
6041 c     &   " of CONT_TO_COMM group"
6042         if (nn.gt.0) then
6043           ireq=ireq+1
6044           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6045      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6046 c          write (iout,*) "ireq,req",ireq,req(ireq)
6047 c          do i=1,nn
6048 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6049 c          enddo
6050         endif
6051       enddo
6052 c      write (iout,*) "number of requests (contacts)",ireq
6053 c      write (iout,*) "req",(req(i),i=1,4)
6054 c      call flush(iout)
6055       if (ireq.gt.0)
6056      & call MPI_Waitall(ireq,req,status_array,ierr)
6057       do iii=1,ntask_cont_from
6058         iproc=itask_cont_from(iii)
6059         nn=ncont_recv(iii)
6060         if (lprn) then
6061         write (iout,*) "Received",nn," contacts from processor",iproc,
6062      &   " of CONT_FROM_COMM group"
6063         call flush(iout)
6064         do i=1,nn
6065           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6066         enddo
6067         call flush(iout)
6068         endif
6069         do i=1,nn
6070           ii=zapas_recv(1,i,iii)
6071 c Flag the received contacts to prevent double-counting
6072           jj=-zapas_recv(2,i,iii)
6073 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6074 c          call flush(iout)
6075           nnn=num_cont_hb(ii)+1
6076           num_cont_hb(ii)=nnn
6077           jcont_hb(nnn,ii)=jj
6078           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6079           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6080           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6081           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6082           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6083           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6084           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6085           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6086           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6087           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6088           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6089           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6090           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6091           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6092           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6093           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6094           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6095           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6096           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6097           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6098           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6099           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6100           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6101           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6102         enddo
6103       enddo
6104       call flush(iout)
6105       if (lprn) then
6106         write (iout,'(a)') 'Contact function values after receive:'
6107         do i=nnt,nct-2
6108           write (iout,'(2i3,50(1x,i3,f5.2))')
6109      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6110      &    j=1,num_cont_hb(i))
6111         enddo
6112         call flush(iout)
6113       endif
6114    30 continue
6115 #endif
6116       if (lprn) then
6117         write (iout,'(a)') 'Contact function values:'
6118         do i=nnt,nct-2
6119           write (iout,'(2i3,50(1x,i3,f5.2))')
6120      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6121      &    j=1,num_cont_hb(i))
6122         enddo
6123       endif
6124       ecorr=0.0D0
6125 C Remove the loop below after debugging !!!
6126       do i=nnt,nct
6127         do j=1,3
6128           gradcorr(j,i)=0.0D0
6129           gradxorr(j,i)=0.0D0
6130         enddo
6131       enddo
6132 C Calculate the local-electrostatic correlation terms
6133       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6134         i1=i+1
6135         num_conti=num_cont_hb(i)
6136         num_conti1=num_cont_hb(i+1)
6137         do jj=1,num_conti
6138           j=jcont_hb(jj,i)
6139           jp=iabs(j)
6140           do kk=1,num_conti1
6141             j1=jcont_hb(kk,i1)
6142             jp1=iabs(j1)
6143 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6144 c     &         ' jj=',jj,' kk=',kk
6145             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6146      &          .or. j.lt.0 .and. j1.gt.0) .and.
6147      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6148 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6149 C The system gains extra energy.
6150               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6151               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6152      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6153               n_corr=n_corr+1
6154             else if (j1.eq.j) then
6155 C Contacts I-J and I-(J+1) occur simultaneously.
6156 C The system loses extra energy.
6157 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6158             endif
6159           enddo ! kk
6160           do kk=1,num_conti
6161             j1=jcont_hb(kk,i)
6162 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6163 c    &         ' jj=',jj,' kk=',kk
6164             if (j1.eq.j+1) then
6165 C Contacts I-J and (I+1)-J occur simultaneously.
6166 C The system loses extra energy.
6167 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6168             endif ! j1==j+1
6169           enddo ! kk
6170         enddo ! jj
6171       enddo ! i
6172       return
6173       end
6174 c------------------------------------------------------------------------------
6175       subroutine add_hb_contact(ii,jj,itask)
6176       implicit real*8 (a-h,o-z)
6177       include "DIMENSIONS"
6178       include "COMMON.IOUNITS"
6179       integer max_cont
6180       integer max_dim
6181       parameter (max_cont=maxconts)
6182       parameter (max_dim=26)
6183       include "COMMON.CONTACTS"
6184       double precision zapas(max_dim,maxconts,max_fg_procs),
6185      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6186       common /przechowalnia/ zapas
6187       integer i,j,ii,jj,iproc,itask(4),nn
6188 c      write (iout,*) "itask",itask
6189       do i=1,2
6190         iproc=itask(i)
6191         if (iproc.gt.0) then
6192           do j=1,num_cont_hb(ii)
6193             jjc=jcont_hb(j,ii)
6194 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6195             if (jjc.eq.jj) then
6196               ncont_sent(iproc)=ncont_sent(iproc)+1
6197               nn=ncont_sent(iproc)
6198               zapas(1,nn,iproc)=ii
6199               zapas(2,nn,iproc)=jjc
6200               zapas(3,nn,iproc)=facont_hb(j,ii)
6201               zapas(4,nn,iproc)=ees0p(j,ii)
6202               zapas(5,nn,iproc)=ees0m(j,ii)
6203               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6204               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6205               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6206               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6207               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6208               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6209               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6210               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6211               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6212               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6213               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6214               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6215               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6216               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6217               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6218               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6219               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6220               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6221               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6222               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6223               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6224               exit
6225             endif
6226           enddo
6227         endif
6228       enddo
6229       return
6230       end
6231 c------------------------------------------------------------------------------
6232       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6233      &  n_corr1)
6234 C This subroutine calculates multi-body contributions to hydrogen-bonding
6235       implicit real*8 (a-h,o-z)
6236       include 'DIMENSIONS'
6237       include 'COMMON.IOUNITS'
6238 #ifdef MPI
6239       include "mpif.h"
6240       parameter (max_cont=maxconts)
6241       parameter (max_dim=70)
6242       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6243       double precision zapas(max_dim,maxconts,max_fg_procs),
6244      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6245       common /przechowalnia/ zapas
6246       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6247      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6248 #endif
6249       include 'COMMON.SETUP'
6250       include 'COMMON.FFIELD'
6251       include 'COMMON.DERIV'
6252       include 'COMMON.LOCAL'
6253       include 'COMMON.INTERACT'
6254       include 'COMMON.CONTACTS'
6255       include 'COMMON.CHAIN'
6256       include 'COMMON.CONTROL'
6257       double precision gx(3),gx1(3)
6258       integer num_cont_hb_old(maxres)
6259       logical lprn,ldone
6260       double precision eello4,eello5,eelo6,eello_turn6
6261       external eello4,eello5,eello6,eello_turn6
6262 C Set lprn=.true. for debugging
6263       lprn=.false.
6264       eturn6=0.0d0
6265 #ifdef MPI
6266       do i=1,nres
6267         num_cont_hb_old(i)=num_cont_hb(i)
6268       enddo
6269       n_corr=0
6270       n_corr1=0
6271       if (nfgtasks.le.1) goto 30
6272       if (lprn) then
6273         write (iout,'(a)') 'Contact function values before RECEIVE:'
6274         do i=nnt,nct-2
6275           write (iout,'(2i3,50(1x,i2,f5.2))')
6276      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6277      &    j=1,num_cont_hb(i))
6278         enddo
6279       endif
6280       call flush(iout)
6281       do i=1,ntask_cont_from
6282         ncont_recv(i)=0
6283       enddo
6284       do i=1,ntask_cont_to
6285         ncont_sent(i)=0
6286       enddo
6287 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6288 c     & ntask_cont_to
6289 C Make the list of contacts to send to send to other procesors
6290       do i=iturn3_start,iturn3_end
6291 c        write (iout,*) "make contact list turn3",i," num_cont",
6292 c     &    num_cont_hb(i)
6293         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6294       enddo
6295       do i=iturn4_start,iturn4_end
6296 c        write (iout,*) "make contact list turn4",i," num_cont",
6297 c     &   num_cont_hb(i)
6298         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6299       enddo
6300       do ii=1,nat_sent
6301         i=iat_sent(ii)
6302 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6303 c     &    num_cont_hb(i)
6304         do j=1,num_cont_hb(i)
6305         do k=1,4
6306           jjc=jcont_hb(j,i)
6307           iproc=iint_sent_local(k,jjc,ii)
6308 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6309           if (iproc.ne.0) then
6310             ncont_sent(iproc)=ncont_sent(iproc)+1
6311             nn=ncont_sent(iproc)
6312             zapas(1,nn,iproc)=i
6313             zapas(2,nn,iproc)=jjc
6314             zapas(3,nn,iproc)=d_cont(j,i)
6315             ind=3
6316             do kk=1,3
6317               ind=ind+1
6318               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6319             enddo
6320             do kk=1,2
6321               do ll=1,2
6322                 ind=ind+1
6323                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6324               enddo
6325             enddo
6326             do jj=1,5
6327               do kk=1,3
6328                 do ll=1,2
6329                   do mm=1,2
6330                     ind=ind+1
6331                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6332                   enddo
6333                 enddo
6334               enddo
6335             enddo
6336           endif
6337         enddo
6338         enddo
6339       enddo
6340       if (lprn) then
6341       write (iout,*)
6342      &  "Numbers of contacts to be sent to other processors",
6343      &  (ncont_sent(i),i=1,ntask_cont_to)
6344       write (iout,*) "Contacts sent"
6345       do ii=1,ntask_cont_to
6346         nn=ncont_sent(ii)
6347         iproc=itask_cont_to(ii)
6348         write (iout,*) nn," contacts to processor",iproc,
6349      &   " of CONT_TO_COMM group"
6350         do i=1,nn
6351           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6352         enddo
6353       enddo
6354       call flush(iout)
6355       endif
6356       CorrelType=477
6357       CorrelID=fg_rank+1
6358       CorrelType1=478
6359       CorrelID1=nfgtasks+fg_rank+1
6360       ireq=0
6361 C Receive the numbers of needed contacts from other processors
6362       do ii=1,ntask_cont_from
6363         iproc=itask_cont_from(ii)
6364         ireq=ireq+1
6365         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6366      &    FG_COMM,req(ireq),IERR)
6367       enddo
6368 c      write (iout,*) "IRECV ended"
6369 c      call flush(iout)
6370 C Send the number of contacts needed by other processors
6371       do ii=1,ntask_cont_to
6372         iproc=itask_cont_to(ii)
6373         ireq=ireq+1
6374         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6375      &    FG_COMM,req(ireq),IERR)
6376       enddo
6377 c      write (iout,*) "ISEND ended"
6378 c      write (iout,*) "number of requests (nn)",ireq
6379       call flush(iout)
6380       if (ireq.gt.0)
6381      &  call MPI_Waitall(ireq,req,status_array,ierr)
6382 c      write (iout,*)
6383 c     &  "Numbers of contacts to be received from other processors",
6384 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6385 c      call flush(iout)
6386 C Receive contacts
6387       ireq=0
6388       do ii=1,ntask_cont_from
6389         iproc=itask_cont_from(ii)
6390         nn=ncont_recv(ii)
6391 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6392 c     &   " of CONT_TO_COMM group"
6393         call flush(iout)
6394         if (nn.gt.0) then
6395           ireq=ireq+1
6396           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6397      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6398 c          write (iout,*) "ireq,req",ireq,req(ireq)
6399         endif
6400       enddo
6401 C Send the contacts to processors that need them
6402       do ii=1,ntask_cont_to
6403         iproc=itask_cont_to(ii)
6404         nn=ncont_sent(ii)
6405 c        write (iout,*) nn," contacts to processor",iproc,
6406 c     &   " of CONT_TO_COMM group"
6407         if (nn.gt.0) then
6408           ireq=ireq+1
6409           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6410      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6411 c          write (iout,*) "ireq,req",ireq,req(ireq)
6412 c          do i=1,nn
6413 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6414 c          enddo
6415         endif
6416       enddo
6417 c      write (iout,*) "number of requests (contacts)",ireq
6418 c      write (iout,*) "req",(req(i),i=1,4)
6419 c      call flush(iout)
6420       if (ireq.gt.0)
6421      & call MPI_Waitall(ireq,req,status_array,ierr)
6422       do iii=1,ntask_cont_from
6423         iproc=itask_cont_from(iii)
6424         nn=ncont_recv(iii)
6425         if (lprn) then
6426         write (iout,*) "Received",nn," contacts from processor",iproc,
6427      &   " of CONT_FROM_COMM group"
6428         call flush(iout)
6429         do i=1,nn
6430           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6431         enddo
6432         call flush(iout)
6433         endif
6434         do i=1,nn
6435           ii=zapas_recv(1,i,iii)
6436 c Flag the received contacts to prevent double-counting
6437           jj=-zapas_recv(2,i,iii)
6438 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6439 c          call flush(iout)
6440           nnn=num_cont_hb(ii)+1
6441           num_cont_hb(ii)=nnn
6442           jcont_hb(nnn,ii)=jj
6443           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6444           ind=3
6445           do kk=1,3
6446             ind=ind+1
6447             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6448           enddo
6449           do kk=1,2
6450             do ll=1,2
6451               ind=ind+1
6452               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6453             enddo
6454           enddo
6455           do jj=1,5
6456             do kk=1,3
6457               do ll=1,2
6458                 do mm=1,2
6459                   ind=ind+1
6460                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6461                 enddo
6462               enddo
6463             enddo
6464           enddo
6465         enddo
6466       enddo
6467       call flush(iout)
6468       if (lprn) then
6469         write (iout,'(a)') 'Contact function values after receive:'
6470         do i=nnt,nct-2
6471           write (iout,'(2i3,50(1x,i3,5f6.3))')
6472      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6473      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6474         enddo
6475         call flush(iout)
6476       endif
6477    30 continue
6478 #endif
6479       if (lprn) then
6480         write (iout,'(a)') 'Contact function values:'
6481         do i=nnt,nct-2
6482           write (iout,'(2i3,50(1x,i2,5f6.3))')
6483      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6484      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6485         enddo
6486       endif
6487       ecorr=0.0D0
6488       ecorr5=0.0d0
6489       ecorr6=0.0d0
6490 C Remove the loop below after debugging !!!
6491       do i=nnt,nct
6492         do j=1,3
6493           gradcorr(j,i)=0.0D0
6494           gradxorr(j,i)=0.0D0
6495         enddo
6496       enddo
6497 C Calculate the dipole-dipole interaction energies
6498       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6499       do i=iatel_s,iatel_e+1
6500         num_conti=num_cont_hb(i)
6501         do jj=1,num_conti
6502           j=jcont_hb(jj,i)
6503 #ifdef MOMENT
6504           call dipole(i,j,jj)
6505 #endif
6506         enddo
6507       enddo
6508       endif
6509 C Calculate the local-electrostatic correlation terms
6510 c                write (iout,*) "gradcorr5 in eello5 before loop"
6511 c                do iii=1,nres
6512 c                  write (iout,'(i5,3f10.5)')
6513 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6514 c                enddo
6515       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6516 c        write (iout,*) "corr loop i",i
6517         i1=i+1
6518         num_conti=num_cont_hb(i)
6519         num_conti1=num_cont_hb(i+1)
6520         do jj=1,num_conti
6521           j=jcont_hb(jj,i)
6522           jp=iabs(j)
6523           do kk=1,num_conti1
6524             j1=jcont_hb(kk,i1)
6525             jp1=iabs(j1)
6526 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6527 c     &         ' jj=',jj,' kk=',kk
6528 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6529             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6530      &          .or. j.lt.0 .and. j1.gt.0) .and.
6531      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6532 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6533 C The system gains extra energy.
6534               n_corr=n_corr+1
6535               sqd1=dsqrt(d_cont(jj,i))
6536               sqd2=dsqrt(d_cont(kk,i1))
6537               sred_geom = sqd1*sqd2
6538               IF (sred_geom.lt.cutoff_corr) THEN
6539                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6540      &            ekont,fprimcont)
6541 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6542 cd     &         ' jj=',jj,' kk=',kk
6543                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6544                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6545                 do l=1,3
6546                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6547                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6548                 enddo
6549                 n_corr1=n_corr1+1
6550 cd               write (iout,*) 'sred_geom=',sred_geom,
6551 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6552 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6553 cd               write (iout,*) "g_contij",g_contij
6554 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6555 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6556                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6557                 if (wcorr4.gt.0.0d0)
6558      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6559                   if (energy_dec.and.wcorr4.gt.0.0d0)
6560      1                 write (iout,'(a6,4i5,0pf7.3)')
6561      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6562 c                write (iout,*) "gradcorr5 before eello5"
6563 c                do iii=1,nres
6564 c                  write (iout,'(i5,3f10.5)')
6565 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6566 c                enddo
6567                 if (wcorr5.gt.0.0d0)
6568      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6569 c                write (iout,*) "gradcorr5 after eello5"
6570 c                do iii=1,nres
6571 c                  write (iout,'(i5,3f10.5)')
6572 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6573 c                enddo
6574                   if (energy_dec.and.wcorr5.gt.0.0d0)
6575      1                 write (iout,'(a6,4i5,0pf7.3)')
6576      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6577 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6578 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6579                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6580      &               .or. wturn6.eq.0.0d0))then
6581 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6582                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6583                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6584      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6585 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6586 cd     &            'ecorr6=',ecorr6
6587 cd                write (iout,'(4e15.5)') sred_geom,
6588 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6589 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6590 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6591                 else if (wturn6.gt.0.0d0
6592      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6593 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6594                   eturn6=eturn6+eello_turn6(i,jj,kk)
6595                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6596      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6597 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6598                 endif
6599               ENDIF
6600 1111          continue
6601             endif
6602           enddo ! kk
6603         enddo ! jj
6604       enddo ! i
6605       do i=1,nres
6606         num_cont_hb(i)=num_cont_hb_old(i)
6607       enddo
6608 c                write (iout,*) "gradcorr5 in eello5"
6609 c                do iii=1,nres
6610 c                  write (iout,'(i5,3f10.5)')
6611 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6612 c                enddo
6613       return
6614       end
6615 c------------------------------------------------------------------------------
6616       subroutine add_hb_contact_eello(ii,jj,itask)
6617       implicit real*8 (a-h,o-z)
6618       include "DIMENSIONS"
6619       include "COMMON.IOUNITS"
6620       integer max_cont
6621       integer max_dim
6622       parameter (max_cont=maxconts)
6623       parameter (max_dim=70)
6624       include "COMMON.CONTACTS"
6625       double precision zapas(max_dim,maxconts,max_fg_procs),
6626      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6627       common /przechowalnia/ zapas
6628       integer i,j,ii,jj,iproc,itask(4),nn
6629 c      write (iout,*) "itask",itask
6630       do i=1,2
6631         iproc=itask(i)
6632         if (iproc.gt.0) then
6633           do j=1,num_cont_hb(ii)
6634             jjc=jcont_hb(j,ii)
6635 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6636             if (jjc.eq.jj) then
6637               ncont_sent(iproc)=ncont_sent(iproc)+1
6638               nn=ncont_sent(iproc)
6639               zapas(1,nn,iproc)=ii
6640               zapas(2,nn,iproc)=jjc
6641               zapas(3,nn,iproc)=d_cont(j,ii)
6642               ind=3
6643               do kk=1,3
6644                 ind=ind+1
6645                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6646               enddo
6647               do kk=1,2
6648                 do ll=1,2
6649                   ind=ind+1
6650                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6651                 enddo
6652               enddo
6653               do jj=1,5
6654                 do kk=1,3
6655                   do ll=1,2
6656                     do mm=1,2
6657                       ind=ind+1
6658                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6659                     enddo
6660                   enddo
6661                 enddo
6662               enddo
6663               exit
6664             endif
6665           enddo
6666         endif
6667       enddo
6668       return
6669       end
6670 c------------------------------------------------------------------------------
6671       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6672       implicit real*8 (a-h,o-z)
6673       include 'DIMENSIONS'
6674       include 'COMMON.IOUNITS'
6675       include 'COMMON.DERIV'
6676       include 'COMMON.INTERACT'
6677       include 'COMMON.CONTACTS'
6678       double precision gx(3),gx1(3)
6679       logical lprn
6680       lprn=.false.
6681       eij=facont_hb(jj,i)
6682       ekl=facont_hb(kk,k)
6683       ees0pij=ees0p(jj,i)
6684       ees0pkl=ees0p(kk,k)
6685       ees0mij=ees0m(jj,i)
6686       ees0mkl=ees0m(kk,k)
6687       ekont=eij*ekl
6688       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6689 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6690 C Following 4 lines for diagnostics.
6691 cd    ees0pkl=0.0D0
6692 cd    ees0pij=1.0D0
6693 cd    ees0mkl=0.0D0
6694 cd    ees0mij=1.0D0
6695 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6696 c     & 'Contacts ',i,j,
6697 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6698 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6699 c     & 'gradcorr_long'
6700 C Calculate the multi-body contribution to energy.
6701 c      ecorr=ecorr+ekont*ees
6702 C Calculate multi-body contributions to the gradient.
6703       coeffpees0pij=coeffp*ees0pij
6704       coeffmees0mij=coeffm*ees0mij
6705       coeffpees0pkl=coeffp*ees0pkl
6706       coeffmees0mkl=coeffm*ees0mkl
6707       do ll=1,3
6708 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6709         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6710      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6711      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6712         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6713      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6714      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6715 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6716         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6717      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6718      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6719         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6720      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6721      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6722         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6723      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6724      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6725         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6726         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6727         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6728      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6729      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6730         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6731         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6732 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6733       enddo
6734 c      write (iout,*)
6735 cgrad      do m=i+1,j-1
6736 cgrad        do ll=1,3
6737 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6738 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6739 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6740 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6741 cgrad        enddo
6742 cgrad      enddo
6743 cgrad      do m=k+1,l-1
6744 cgrad        do ll=1,3
6745 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6746 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6747 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6748 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6749 cgrad        enddo
6750 cgrad      enddo
6751 c      write (iout,*) "ehbcorr",ekont*ees
6752       ehbcorr=ekont*ees
6753       return
6754       end
6755 #ifdef MOMENT
6756 C---------------------------------------------------------------------------
6757       subroutine dipole(i,j,jj)
6758       implicit real*8 (a-h,o-z)
6759       include 'DIMENSIONS'
6760       include 'COMMON.IOUNITS'
6761       include 'COMMON.CHAIN'
6762       include 'COMMON.FFIELD'
6763       include 'COMMON.DERIV'
6764       include 'COMMON.INTERACT'
6765       include 'COMMON.CONTACTS'
6766       include 'COMMON.TORSION'
6767       include 'COMMON.VAR'
6768       include 'COMMON.GEO'
6769       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6770      &  auxmat(2,2)
6771       iti1 = itortyp(itype(i+1))
6772       if (j.lt.nres-1) then
6773         itj1 = itortyp(itype(j+1))
6774       else
6775         itj1=ntortyp+1
6776       endif
6777       do iii=1,2
6778         dipi(iii,1)=Ub2(iii,i)
6779         dipderi(iii)=Ub2der(iii,i)
6780         dipi(iii,2)=b1(iii,iti1)
6781         dipj(iii,1)=Ub2(iii,j)
6782         dipderj(iii)=Ub2der(iii,j)
6783         dipj(iii,2)=b1(iii,itj1)
6784       enddo
6785       kkk=0
6786       do iii=1,2
6787         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6788         do jjj=1,2
6789           kkk=kkk+1
6790           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6791         enddo
6792       enddo
6793       do kkk=1,5
6794         do lll=1,3
6795           mmm=0
6796           do iii=1,2
6797             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6798      &        auxvec(1))
6799             do jjj=1,2
6800               mmm=mmm+1
6801               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6802             enddo
6803           enddo
6804         enddo
6805       enddo
6806       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6807       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6808       do iii=1,2
6809         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6810       enddo
6811       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6812       do iii=1,2
6813         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6814       enddo
6815       return
6816       end
6817 #endif
6818 C---------------------------------------------------------------------------
6819       subroutine calc_eello(i,j,k,l,jj,kk)
6820 C
6821 C This subroutine computes matrices and vectors needed to calculate
6822 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6823 C
6824       implicit real*8 (a-h,o-z)
6825       include 'DIMENSIONS'
6826       include 'COMMON.IOUNITS'
6827       include 'COMMON.CHAIN'
6828       include 'COMMON.DERIV'
6829       include 'COMMON.INTERACT'
6830       include 'COMMON.CONTACTS'
6831       include 'COMMON.TORSION'
6832       include 'COMMON.VAR'
6833       include 'COMMON.GEO'
6834       include 'COMMON.FFIELD'
6835       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6836      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6837       logical lprn
6838       common /kutas/ lprn
6839 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6840 cd     & ' jj=',jj,' kk=',kk
6841 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6842 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6843 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6844       do iii=1,2
6845         do jjj=1,2
6846           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6847           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6848         enddo
6849       enddo
6850       call transpose2(aa1(1,1),aa1t(1,1))
6851       call transpose2(aa2(1,1),aa2t(1,1))
6852       do kkk=1,5
6853         do lll=1,3
6854           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6855      &      aa1tder(1,1,lll,kkk))
6856           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6857      &      aa2tder(1,1,lll,kkk))
6858         enddo
6859       enddo
6860       if (l.eq.j+1) then
6861 C parallel orientation of the two CA-CA-CA frames.
6862         if (i.gt.1) then
6863           iti=itortyp(itype(i))
6864         else
6865           iti=ntortyp+1
6866         endif
6867         itk1=itortyp(itype(k+1))
6868         itj=itortyp(itype(j))
6869         if (l.lt.nres-1) then
6870           itl1=itortyp(itype(l+1))
6871         else
6872           itl1=ntortyp+1
6873         endif
6874 C A1 kernel(j+1) A2T
6875 cd        do iii=1,2
6876 cd          write (iout,'(3f10.5,5x,3f10.5)')
6877 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6878 cd        enddo
6879         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6880      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6881      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6882 C Following matrices are needed only for 6-th order cumulants
6883         IF (wcorr6.gt.0.0d0) THEN
6884         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6885      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6886      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6887         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6888      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6889      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6890      &   ADtEAderx(1,1,1,1,1,1))
6891         lprn=.false.
6892         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6893      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6894      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6895      &   ADtEA1derx(1,1,1,1,1,1))
6896         ENDIF
6897 C End 6-th order cumulants
6898 cd        lprn=.false.
6899 cd        if (lprn) then
6900 cd        write (2,*) 'In calc_eello6'
6901 cd        do iii=1,2
6902 cd          write (2,*) 'iii=',iii
6903 cd          do kkk=1,5
6904 cd            write (2,*) 'kkk=',kkk
6905 cd            do jjj=1,2
6906 cd              write (2,'(3(2f10.5),5x)')
6907 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6908 cd            enddo
6909 cd          enddo
6910 cd        enddo
6911 cd        endif
6912         call transpose2(EUgder(1,1,k),auxmat(1,1))
6913         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6914         call transpose2(EUg(1,1,k),auxmat(1,1))
6915         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6916         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6917         do iii=1,2
6918           do kkk=1,5
6919             do lll=1,3
6920               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6921      &          EAEAderx(1,1,lll,kkk,iii,1))
6922             enddo
6923           enddo
6924         enddo
6925 C A1T kernel(i+1) A2
6926         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6927      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6928      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6929 C Following matrices are needed only for 6-th order cumulants
6930         IF (wcorr6.gt.0.0d0) THEN
6931         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6932      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6933      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6934         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6935      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6936      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6937      &   ADtEAderx(1,1,1,1,1,2))
6938         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6939      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6940      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6941      &   ADtEA1derx(1,1,1,1,1,2))
6942         ENDIF
6943 C End 6-th order cumulants
6944         call transpose2(EUgder(1,1,l),auxmat(1,1))
6945         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6946         call transpose2(EUg(1,1,l),auxmat(1,1))
6947         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6948         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6949         do iii=1,2
6950           do kkk=1,5
6951             do lll=1,3
6952               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6953      &          EAEAderx(1,1,lll,kkk,iii,2))
6954             enddo
6955           enddo
6956         enddo
6957 C AEAb1 and AEAb2
6958 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6959 C They are needed only when the fifth- or the sixth-order cumulants are
6960 C indluded.
6961         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6962         call transpose2(AEA(1,1,1),auxmat(1,1))
6963         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6964         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6965         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6966         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6967         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6968         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6969         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6970         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6971         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6972         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6973         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6974         call transpose2(AEA(1,1,2),auxmat(1,1))
6975         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6976         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6977         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6978         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6979         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6980         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6981         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6982         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6983         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6984         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6985         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6986 C Calculate the Cartesian derivatives of the vectors.
6987         do iii=1,2
6988           do kkk=1,5
6989             do lll=1,3
6990               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6991               call matvec2(auxmat(1,1),b1(1,iti),
6992      &          AEAb1derx(1,lll,kkk,iii,1,1))
6993               call matvec2(auxmat(1,1),Ub2(1,i),
6994      &          AEAb2derx(1,lll,kkk,iii,1,1))
6995               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6996      &          AEAb1derx(1,lll,kkk,iii,2,1))
6997               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6998      &          AEAb2derx(1,lll,kkk,iii,2,1))
6999               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7000               call matvec2(auxmat(1,1),b1(1,itj),
7001      &          AEAb1derx(1,lll,kkk,iii,1,2))
7002               call matvec2(auxmat(1,1),Ub2(1,j),
7003      &          AEAb2derx(1,lll,kkk,iii,1,2))
7004               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7005      &          AEAb1derx(1,lll,kkk,iii,2,2))
7006               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7007      &          AEAb2derx(1,lll,kkk,iii,2,2))
7008             enddo
7009           enddo
7010         enddo
7011         ENDIF
7012 C End vectors
7013       else
7014 C Antiparallel orientation of the two CA-CA-CA frames.
7015         if (i.gt.1) then
7016           iti=itortyp(itype(i))
7017         else
7018           iti=ntortyp+1
7019         endif
7020         itk1=itortyp(itype(k+1))
7021         itl=itortyp(itype(l))
7022         itj=itortyp(itype(j))
7023         if (j.lt.nres-1) then
7024           itj1=itortyp(itype(j+1))
7025         else
7026           itj1=ntortyp+1
7027         endif
7028 C A2 kernel(j-1)T A1T
7029         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7030      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7031      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7032 C Following matrices are needed only for 6-th order cumulants
7033         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7034      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7035         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7036      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7037      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7038         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7039      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7040      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7041      &   ADtEAderx(1,1,1,1,1,1))
7042         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7043      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7044      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7045      &   ADtEA1derx(1,1,1,1,1,1))
7046         ENDIF
7047 C End 6-th order cumulants
7048         call transpose2(EUgder(1,1,k),auxmat(1,1))
7049         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7050         call transpose2(EUg(1,1,k),auxmat(1,1))
7051         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7052         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7053         do iii=1,2
7054           do kkk=1,5
7055             do lll=1,3
7056               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7057      &          EAEAderx(1,1,lll,kkk,iii,1))
7058             enddo
7059           enddo
7060         enddo
7061 C A2T kernel(i+1)T A1
7062         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7063      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7064      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7065 C Following matrices are needed only for 6-th order cumulants
7066         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7067      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7068         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7069      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7070      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7071         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7072      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7073      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7074      &   ADtEAderx(1,1,1,1,1,2))
7075         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7076      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7077      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7078      &   ADtEA1derx(1,1,1,1,1,2))
7079         ENDIF
7080 C End 6-th order cumulants
7081         call transpose2(EUgder(1,1,j),auxmat(1,1))
7082         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7083         call transpose2(EUg(1,1,j),auxmat(1,1))
7084         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7085         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7086         do iii=1,2
7087           do kkk=1,5
7088             do lll=1,3
7089               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7090      &          EAEAderx(1,1,lll,kkk,iii,2))
7091             enddo
7092           enddo
7093         enddo
7094 C AEAb1 and AEAb2
7095 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7096 C They are needed only when the fifth- or the sixth-order cumulants are
7097 C indluded.
7098         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7099      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7100         call transpose2(AEA(1,1,1),auxmat(1,1))
7101         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7102         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7103         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7104         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7105         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7106         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7107         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7108         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7109         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7110         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7111         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7112         call transpose2(AEA(1,1,2),auxmat(1,1))
7113         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7114         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7115         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7116         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7117         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7118         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7119         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7120         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7121         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7122         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7123         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7124 C Calculate the Cartesian derivatives of the vectors.
7125         do iii=1,2
7126           do kkk=1,5
7127             do lll=1,3
7128               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7129               call matvec2(auxmat(1,1),b1(1,iti),
7130      &          AEAb1derx(1,lll,kkk,iii,1,1))
7131               call matvec2(auxmat(1,1),Ub2(1,i),
7132      &          AEAb2derx(1,lll,kkk,iii,1,1))
7133               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7134      &          AEAb1derx(1,lll,kkk,iii,2,1))
7135               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7136      &          AEAb2derx(1,lll,kkk,iii,2,1))
7137               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7138               call matvec2(auxmat(1,1),b1(1,itl),
7139      &          AEAb1derx(1,lll,kkk,iii,1,2))
7140               call matvec2(auxmat(1,1),Ub2(1,l),
7141      &          AEAb2derx(1,lll,kkk,iii,1,2))
7142               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7143      &          AEAb1derx(1,lll,kkk,iii,2,2))
7144               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7145      &          AEAb2derx(1,lll,kkk,iii,2,2))
7146             enddo
7147           enddo
7148         enddo
7149         ENDIF
7150 C End vectors
7151       endif
7152       return
7153       end
7154 C---------------------------------------------------------------------------
7155       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7156      &  KK,KKderg,AKA,AKAderg,AKAderx)
7157       implicit none
7158       integer nderg
7159       logical transp
7160       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7161      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7162      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7163       integer iii,kkk,lll
7164       integer jjj,mmm
7165       logical lprn
7166       common /kutas/ lprn
7167       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7168       do iii=1,nderg
7169         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7170      &    AKAderg(1,1,iii))
7171       enddo
7172 cd      if (lprn) write (2,*) 'In kernel'
7173       do kkk=1,5
7174 cd        if (lprn) write (2,*) 'kkk=',kkk
7175         do lll=1,3
7176           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7177      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7178 cd          if (lprn) then
7179 cd            write (2,*) 'lll=',lll
7180 cd            write (2,*) 'iii=1'
7181 cd            do jjj=1,2
7182 cd              write (2,'(3(2f10.5),5x)')
7183 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7184 cd            enddo
7185 cd          endif
7186           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7187      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7188 cd          if (lprn) then
7189 cd            write (2,*) 'lll=',lll
7190 cd            write (2,*) 'iii=2'
7191 cd            do jjj=1,2
7192 cd              write (2,'(3(2f10.5),5x)')
7193 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7194 cd            enddo
7195 cd          endif
7196         enddo
7197       enddo
7198       return
7199       end
7200 C---------------------------------------------------------------------------
7201       double precision function eello4(i,j,k,l,jj,kk)
7202       implicit real*8 (a-h,o-z)
7203       include 'DIMENSIONS'
7204       include 'COMMON.IOUNITS'
7205       include 'COMMON.CHAIN'
7206       include 'COMMON.DERIV'
7207       include 'COMMON.INTERACT'
7208       include 'COMMON.CONTACTS'
7209       include 'COMMON.TORSION'
7210       include 'COMMON.VAR'
7211       include 'COMMON.GEO'
7212       double precision pizda(2,2),ggg1(3),ggg2(3)
7213 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7214 cd        eello4=0.0d0
7215 cd        return
7216 cd      endif
7217 cd      print *,'eello4:',i,j,k,l,jj,kk
7218 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7219 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7220 cold      eij=facont_hb(jj,i)
7221 cold      ekl=facont_hb(kk,k)
7222 cold      ekont=eij*ekl
7223       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7224 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7225       gcorr_loc(k-1)=gcorr_loc(k-1)
7226      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7227       if (l.eq.j+1) then
7228         gcorr_loc(l-1)=gcorr_loc(l-1)
7229      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7230       else
7231         gcorr_loc(j-1)=gcorr_loc(j-1)
7232      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7233       endif
7234       do iii=1,2
7235         do kkk=1,5
7236           do lll=1,3
7237             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7238      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7239 cd            derx(lll,kkk,iii)=0.0d0
7240           enddo
7241         enddo
7242       enddo
7243 cd      gcorr_loc(l-1)=0.0d0
7244 cd      gcorr_loc(j-1)=0.0d0
7245 cd      gcorr_loc(k-1)=0.0d0
7246 cd      eel4=1.0d0
7247 cd      write (iout,*)'Contacts have occurred for peptide groups',
7248 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7249 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7250       if (j.lt.nres-1) then
7251         j1=j+1
7252         j2=j-1
7253       else
7254         j1=j-1
7255         j2=j-2
7256       endif
7257       if (l.lt.nres-1) then
7258         l1=l+1
7259         l2=l-1
7260       else
7261         l1=l-1
7262         l2=l-2
7263       endif
7264       do ll=1,3
7265 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7266 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7267         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7268         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7269 cgrad        ghalf=0.5d0*ggg1(ll)
7270         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7271         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7272         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7273         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7274         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7275         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7276 cgrad        ghalf=0.5d0*ggg2(ll)
7277         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7278         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7279         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7280         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7281         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7282         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7283       enddo
7284 cgrad      do m=i+1,j-1
7285 cgrad        do ll=1,3
7286 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7287 cgrad        enddo
7288 cgrad      enddo
7289 cgrad      do m=k+1,l-1
7290 cgrad        do ll=1,3
7291 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7292 cgrad        enddo
7293 cgrad      enddo
7294 cgrad      do m=i+2,j2
7295 cgrad        do ll=1,3
7296 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7297 cgrad        enddo
7298 cgrad      enddo
7299 cgrad      do m=k+2,l2
7300 cgrad        do ll=1,3
7301 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7302 cgrad        enddo
7303 cgrad      enddo
7304 cd      do iii=1,nres-3
7305 cd        write (2,*) iii,gcorr_loc(iii)
7306 cd      enddo
7307       eello4=ekont*eel4
7308 cd      write (2,*) 'ekont',ekont
7309 cd      write (iout,*) 'eello4',ekont*eel4
7310       return
7311       end
7312 C---------------------------------------------------------------------------
7313       double precision function eello5(i,j,k,l,jj,kk)
7314       implicit real*8 (a-h,o-z)
7315       include 'DIMENSIONS'
7316       include 'COMMON.IOUNITS'
7317       include 'COMMON.CHAIN'
7318       include 'COMMON.DERIV'
7319       include 'COMMON.INTERACT'
7320       include 'COMMON.CONTACTS'
7321       include 'COMMON.TORSION'
7322       include 'COMMON.VAR'
7323       include 'COMMON.GEO'
7324       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7325       double precision ggg1(3),ggg2(3)
7326 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7327 C                                                                              C
7328 C                            Parallel chains                                   C
7329 C                                                                              C
7330 C          o             o                   o             o                   C
7331 C         /l\           / \             \   / \           / \   /              C
7332 C        /   \         /   \             \ /   \         /   \ /               C
7333 C       j| o |l1       | o |              o| o |         | o |o                C
7334 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7335 C      \i/   \         /   \ /             /   \         /   \                 C
7336 C       o    k1             o                                                  C
7337 C         (I)          (II)                (III)          (IV)                 C
7338 C                                                                              C
7339 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7340 C                                                                              C
7341 C                            Antiparallel chains                               C
7342 C                                                                              C
7343 C          o             o                   o             o                   C
7344 C         /j\           / \             \   / \           / \   /              C
7345 C        /   \         /   \             \ /   \         /   \ /               C
7346 C      j1| o |l        | o |              o| o |         | o |o                C
7347 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7348 C      \i/   \         /   \ /             /   \         /   \                 C
7349 C       o     k1            o                                                  C
7350 C         (I)          (II)                (III)          (IV)                 C
7351 C                                                                              C
7352 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7353 C                                                                              C
7354 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7355 C                                                                              C
7356 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7357 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7358 cd        eello5=0.0d0
7359 cd        return
7360 cd      endif
7361 cd      write (iout,*)
7362 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7363 cd     &   ' and',k,l
7364       itk=itortyp(itype(k))
7365       itl=itortyp(itype(l))
7366       itj=itortyp(itype(j))
7367       eello5_1=0.0d0
7368       eello5_2=0.0d0
7369       eello5_3=0.0d0
7370       eello5_4=0.0d0
7371 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7372 cd     &   eel5_3_num,eel5_4_num)
7373       do iii=1,2
7374         do kkk=1,5
7375           do lll=1,3
7376             derx(lll,kkk,iii)=0.0d0
7377           enddo
7378         enddo
7379       enddo
7380 cd      eij=facont_hb(jj,i)
7381 cd      ekl=facont_hb(kk,k)
7382 cd      ekont=eij*ekl
7383 cd      write (iout,*)'Contacts have occurred for peptide groups',
7384 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7385 cd      goto 1111
7386 C Contribution from the graph I.
7387 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7388 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7389       call transpose2(EUg(1,1,k),auxmat(1,1))
7390       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7391       vv(1)=pizda(1,1)-pizda(2,2)
7392       vv(2)=pizda(1,2)+pizda(2,1)
7393       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7394      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7395 C Explicit gradient in virtual-dihedral angles.
7396       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7397      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7398      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7399       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7400       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7401       vv(1)=pizda(1,1)-pizda(2,2)
7402       vv(2)=pizda(1,2)+pizda(2,1)
7403       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7404      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7405      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7406       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7407       vv(1)=pizda(1,1)-pizda(2,2)
7408       vv(2)=pizda(1,2)+pizda(2,1)
7409       if (l.eq.j+1) then
7410         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7411      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7412      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7413       else
7414         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7415      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7416      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7417       endif
7418 C Cartesian gradient
7419       do iii=1,2
7420         do kkk=1,5
7421           do lll=1,3
7422             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7423      &        pizda(1,1))
7424             vv(1)=pizda(1,1)-pizda(2,2)
7425             vv(2)=pizda(1,2)+pizda(2,1)
7426             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7427      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7428      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7429           enddo
7430         enddo
7431       enddo
7432 c      goto 1112
7433 c1111  continue
7434 C Contribution from graph II
7435       call transpose2(EE(1,1,itk),auxmat(1,1))
7436       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7437       vv(1)=pizda(1,1)+pizda(2,2)
7438       vv(2)=pizda(2,1)-pizda(1,2)
7439       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7440      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7441 C Explicit gradient in virtual-dihedral angles.
7442       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7443      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7444       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7445       vv(1)=pizda(1,1)+pizda(2,2)
7446       vv(2)=pizda(2,1)-pizda(1,2)
7447       if (l.eq.j+1) then
7448         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7449      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7450      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7451       else
7452         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7453      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7454      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7455       endif
7456 C Cartesian gradient
7457       do iii=1,2
7458         do kkk=1,5
7459           do lll=1,3
7460             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7461      &        pizda(1,1))
7462             vv(1)=pizda(1,1)+pizda(2,2)
7463             vv(2)=pizda(2,1)-pizda(1,2)
7464             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7465      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7466      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7467           enddo
7468         enddo
7469       enddo
7470 cd      goto 1112
7471 cd1111  continue
7472       if (l.eq.j+1) then
7473 cd        goto 1110
7474 C Parallel orientation
7475 C Contribution from graph III
7476         call transpose2(EUg(1,1,l),auxmat(1,1))
7477         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7478         vv(1)=pizda(1,1)-pizda(2,2)
7479         vv(2)=pizda(1,2)+pizda(2,1)
7480         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7481      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7482 C Explicit gradient in virtual-dihedral angles.
7483         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7484      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7485      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7486         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7487         vv(1)=pizda(1,1)-pizda(2,2)
7488         vv(2)=pizda(1,2)+pizda(2,1)
7489         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7490      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7491      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7492         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7493         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7494         vv(1)=pizda(1,1)-pizda(2,2)
7495         vv(2)=pizda(1,2)+pizda(2,1)
7496         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7497      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7498      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7499 C Cartesian gradient
7500         do iii=1,2
7501           do kkk=1,5
7502             do lll=1,3
7503               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7504      &          pizda(1,1))
7505               vv(1)=pizda(1,1)-pizda(2,2)
7506               vv(2)=pizda(1,2)+pizda(2,1)
7507               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7508      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7509      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7510             enddo
7511           enddo
7512         enddo
7513 cd        goto 1112
7514 C Contribution from graph IV
7515 cd1110    continue
7516         call transpose2(EE(1,1,itl),auxmat(1,1))
7517         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7518         vv(1)=pizda(1,1)+pizda(2,2)
7519         vv(2)=pizda(2,1)-pizda(1,2)
7520         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7521      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7522 C Explicit gradient in virtual-dihedral angles.
7523         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7524      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7525         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7526         vv(1)=pizda(1,1)+pizda(2,2)
7527         vv(2)=pizda(2,1)-pizda(1,2)
7528         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7529      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7530      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7531 C Cartesian gradient
7532         do iii=1,2
7533           do kkk=1,5
7534             do lll=1,3
7535               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7536      &          pizda(1,1))
7537               vv(1)=pizda(1,1)+pizda(2,2)
7538               vv(2)=pizda(2,1)-pizda(1,2)
7539               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7540      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7541      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7542             enddo
7543           enddo
7544         enddo
7545       else
7546 C Antiparallel orientation
7547 C Contribution from graph III
7548 c        goto 1110
7549         call transpose2(EUg(1,1,j),auxmat(1,1))
7550         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7551         vv(1)=pizda(1,1)-pizda(2,2)
7552         vv(2)=pizda(1,2)+pizda(2,1)
7553         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7554      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7555 C Explicit gradient in virtual-dihedral angles.
7556         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7557      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7558      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7559         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7560         vv(1)=pizda(1,1)-pizda(2,2)
7561         vv(2)=pizda(1,2)+pizda(2,1)
7562         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7563      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7564      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7565         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7566         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7567         vv(1)=pizda(1,1)-pizda(2,2)
7568         vv(2)=pizda(1,2)+pizda(2,1)
7569         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7570      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7571      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7572 C Cartesian gradient
7573         do iii=1,2
7574           do kkk=1,5
7575             do lll=1,3
7576               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7577      &          pizda(1,1))
7578               vv(1)=pizda(1,1)-pizda(2,2)
7579               vv(2)=pizda(1,2)+pizda(2,1)
7580               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7581      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7582      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7583             enddo
7584           enddo
7585         enddo
7586 cd        goto 1112
7587 C Contribution from graph IV
7588 1110    continue
7589         call transpose2(EE(1,1,itj),auxmat(1,1))
7590         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7591         vv(1)=pizda(1,1)+pizda(2,2)
7592         vv(2)=pizda(2,1)-pizda(1,2)
7593         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7594      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7595 C Explicit gradient in virtual-dihedral angles.
7596         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7597      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7598         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7599         vv(1)=pizda(1,1)+pizda(2,2)
7600         vv(2)=pizda(2,1)-pizda(1,2)
7601         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7602      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7603      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7604 C Cartesian gradient
7605         do iii=1,2
7606           do kkk=1,5
7607             do lll=1,3
7608               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7609      &          pizda(1,1))
7610               vv(1)=pizda(1,1)+pizda(2,2)
7611               vv(2)=pizda(2,1)-pizda(1,2)
7612               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7613      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7614      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7615             enddo
7616           enddo
7617         enddo
7618       endif
7619 1112  continue
7620       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7621 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7622 cd        write (2,*) 'ijkl',i,j,k,l
7623 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7624 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7625 cd      endif
7626 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7627 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7628 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7629 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7630       if (j.lt.nres-1) then
7631         j1=j+1
7632         j2=j-1
7633       else
7634         j1=j-1
7635         j2=j-2
7636       endif
7637       if (l.lt.nres-1) then
7638         l1=l+1
7639         l2=l-1
7640       else
7641         l1=l-1
7642         l2=l-2
7643       endif
7644 cd      eij=1.0d0
7645 cd      ekl=1.0d0
7646 cd      ekont=1.0d0
7647 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7648 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7649 C        summed up outside the subrouine as for the other subroutines
7650 C        handling long-range interactions. The old code is commented out
7651 C        with "cgrad" to keep track of changes.
7652       do ll=1,3
7653 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7654 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7655         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7656         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7657 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7658 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7659 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7660 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7661 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7662 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7663 c     &   gradcorr5ij,
7664 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7665 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7666 cgrad        ghalf=0.5d0*ggg1(ll)
7667 cd        ghalf=0.0d0
7668         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7669         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7670         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7671         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7672         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7673         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7674 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7675 cgrad        ghalf=0.5d0*ggg2(ll)
7676 cd        ghalf=0.0d0
7677         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7678         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7679         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7680         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7681         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7682         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7683       enddo
7684 cd      goto 1112
7685 cgrad      do m=i+1,j-1
7686 cgrad        do ll=1,3
7687 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7688 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7689 cgrad        enddo
7690 cgrad      enddo
7691 cgrad      do m=k+1,l-1
7692 cgrad        do ll=1,3
7693 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7694 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7695 cgrad        enddo
7696 cgrad      enddo
7697 c1112  continue
7698 cgrad      do m=i+2,j2
7699 cgrad        do ll=1,3
7700 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7701 cgrad        enddo
7702 cgrad      enddo
7703 cgrad      do m=k+2,l2
7704 cgrad        do ll=1,3
7705 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7706 cgrad        enddo
7707 cgrad      enddo
7708 cd      do iii=1,nres-3
7709 cd        write (2,*) iii,g_corr5_loc(iii)
7710 cd      enddo
7711       eello5=ekont*eel5
7712 cd      write (2,*) 'ekont',ekont
7713 cd      write (iout,*) 'eello5',ekont*eel5
7714       return
7715       end
7716 c--------------------------------------------------------------------------
7717       double precision function eello6(i,j,k,l,jj,kk)
7718       implicit real*8 (a-h,o-z)
7719       include 'DIMENSIONS'
7720       include 'COMMON.IOUNITS'
7721       include 'COMMON.CHAIN'
7722       include 'COMMON.DERIV'
7723       include 'COMMON.INTERACT'
7724       include 'COMMON.CONTACTS'
7725       include 'COMMON.TORSION'
7726       include 'COMMON.VAR'
7727       include 'COMMON.GEO'
7728       include 'COMMON.FFIELD'
7729       double precision ggg1(3),ggg2(3)
7730 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7731 cd        eello6=0.0d0
7732 cd        return
7733 cd      endif
7734 cd      write (iout,*)
7735 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7736 cd     &   ' and',k,l
7737       eello6_1=0.0d0
7738       eello6_2=0.0d0
7739       eello6_3=0.0d0
7740       eello6_4=0.0d0
7741       eello6_5=0.0d0
7742       eello6_6=0.0d0
7743 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7744 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7745       do iii=1,2
7746         do kkk=1,5
7747           do lll=1,3
7748             derx(lll,kkk,iii)=0.0d0
7749           enddo
7750         enddo
7751       enddo
7752 cd      eij=facont_hb(jj,i)
7753 cd      ekl=facont_hb(kk,k)
7754 cd      ekont=eij*ekl
7755 cd      eij=1.0d0
7756 cd      ekl=1.0d0
7757 cd      ekont=1.0d0
7758       if (l.eq.j+1) then
7759         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7760         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7761         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7762         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7763         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7764         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7765       else
7766         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7767         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7768         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7769         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7770         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7771           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7772         else
7773           eello6_5=0.0d0
7774         endif
7775         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7776       endif
7777 C If turn contributions are considered, they will be handled separately.
7778       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7779 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7780 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7781 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7782 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7783 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7784 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7785 cd      goto 1112
7786       if (j.lt.nres-1) then
7787         j1=j+1
7788         j2=j-1
7789       else
7790         j1=j-1
7791         j2=j-2
7792       endif
7793       if (l.lt.nres-1) then
7794         l1=l+1
7795         l2=l-1
7796       else
7797         l1=l-1
7798         l2=l-2
7799       endif
7800       do ll=1,3
7801 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7802 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7803 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7804 cgrad        ghalf=0.5d0*ggg1(ll)
7805 cd        ghalf=0.0d0
7806         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7807         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7808         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7809         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7810         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7811         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7812         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7813         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7814 cgrad        ghalf=0.5d0*ggg2(ll)
7815 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7816 cd        ghalf=0.0d0
7817         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7818         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7819         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7820         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7821         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7822         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7823       enddo
7824 cd      goto 1112
7825 cgrad      do m=i+1,j-1
7826 cgrad        do ll=1,3
7827 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7828 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7829 cgrad        enddo
7830 cgrad      enddo
7831 cgrad      do m=k+1,l-1
7832 cgrad        do ll=1,3
7833 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7834 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7835 cgrad        enddo
7836 cgrad      enddo
7837 cgrad1112  continue
7838 cgrad      do m=i+2,j2
7839 cgrad        do ll=1,3
7840 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7841 cgrad        enddo
7842 cgrad      enddo
7843 cgrad      do m=k+2,l2
7844 cgrad        do ll=1,3
7845 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7846 cgrad        enddo
7847 cgrad      enddo
7848 cd      do iii=1,nres-3
7849 cd        write (2,*) iii,g_corr6_loc(iii)
7850 cd      enddo
7851       eello6=ekont*eel6
7852 cd      write (2,*) 'ekont',ekont
7853 cd      write (iout,*) 'eello6',ekont*eel6
7854       return
7855       end
7856 c--------------------------------------------------------------------------
7857       double precision function eello6_graph1(i,j,k,l,imat,swap)
7858       implicit real*8 (a-h,o-z)
7859       include 'DIMENSIONS'
7860       include 'COMMON.IOUNITS'
7861       include 'COMMON.CHAIN'
7862       include 'COMMON.DERIV'
7863       include 'COMMON.INTERACT'
7864       include 'COMMON.CONTACTS'
7865       include 'COMMON.TORSION'
7866       include 'COMMON.VAR'
7867       include 'COMMON.GEO'
7868       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7869       logical swap
7870       logical lprn
7871       common /kutas/ lprn
7872 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7873 C                                                                              C
7874 C      Parallel       Antiparallel                                             C
7875 C                                                                              C
7876 C          o             o                                                     C
7877 C         /l\           /j\                                                    C
7878 C        /   \         /   \                                                   C
7879 C       /| o |         | o |\                                                  C
7880 C     \ j|/k\|  /   \  |/k\|l /                                                C
7881 C      \ /   \ /     \ /   \ /                                                 C
7882 C       o     o       o     o                                                  C
7883 C       i             i                                                        C
7884 C                                                                              C
7885 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7886       itk=itortyp(itype(k))
7887       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7888       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7889       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7890       call transpose2(EUgC(1,1,k),auxmat(1,1))
7891       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7892       vv1(1)=pizda1(1,1)-pizda1(2,2)
7893       vv1(2)=pizda1(1,2)+pizda1(2,1)
7894       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7895       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7896       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7897       s5=scalar2(vv(1),Dtobr2(1,i))
7898 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7899       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7900       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7901      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7902      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7903      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7904      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7905      & +scalar2(vv(1),Dtobr2der(1,i)))
7906       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7907       vv1(1)=pizda1(1,1)-pizda1(2,2)
7908       vv1(2)=pizda1(1,2)+pizda1(2,1)
7909       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7910       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7911       if (l.eq.j+1) then
7912         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7913      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7914      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7915      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7916      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7917       else
7918         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7919      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7920      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7921      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7922      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7923       endif
7924       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7925       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7926       vv1(1)=pizda1(1,1)-pizda1(2,2)
7927       vv1(2)=pizda1(1,2)+pizda1(2,1)
7928       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7929      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7930      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7931      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7932       do iii=1,2
7933         if (swap) then
7934           ind=3-iii
7935         else
7936           ind=iii
7937         endif
7938         do kkk=1,5
7939           do lll=1,3
7940             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7941             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7942             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7943             call transpose2(EUgC(1,1,k),auxmat(1,1))
7944             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7945      &        pizda1(1,1))
7946             vv1(1)=pizda1(1,1)-pizda1(2,2)
7947             vv1(2)=pizda1(1,2)+pizda1(2,1)
7948             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7949             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7950      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7951             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7952      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7953             s5=scalar2(vv(1),Dtobr2(1,i))
7954             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7955           enddo
7956         enddo
7957       enddo
7958       return
7959       end
7960 c----------------------------------------------------------------------------
7961       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7962       implicit real*8 (a-h,o-z)
7963       include 'DIMENSIONS'
7964       include 'COMMON.IOUNITS'
7965       include 'COMMON.CHAIN'
7966       include 'COMMON.DERIV'
7967       include 'COMMON.INTERACT'
7968       include 'COMMON.CONTACTS'
7969       include 'COMMON.TORSION'
7970       include 'COMMON.VAR'
7971       include 'COMMON.GEO'
7972       logical swap
7973       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7974      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7975       logical lprn
7976       common /kutas/ lprn
7977 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7978 C                                                                              C
7979 C      Parallel       Antiparallel                                             C
7980 C                                                                              C
7981 C          o             o                                                     C
7982 C     \   /l\           /j\   /                                                C
7983 C      \ /   \         /   \ /                                                 C
7984 C       o| o |         | o |o                                                  C
7985 C     \ j|/k\|      \  |/k\|l                                                  C
7986 C      \ /   \       \ /   \                                                   C
7987 C       o             o                                                        C
7988 C       i             i                                                        C
7989 C                                                                              C
7990 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7991 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7992 C AL 7/4/01 s1 would occur in the sixth-order moment,
7993 C           but not in a cluster cumulant
7994 #ifdef MOMENT
7995       s1=dip(1,jj,i)*dip(1,kk,k)
7996 #endif
7997       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7998       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7999       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8000       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8001       call transpose2(EUg(1,1,k),auxmat(1,1))
8002       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8003       vv(1)=pizda(1,1)-pizda(2,2)
8004       vv(2)=pizda(1,2)+pizda(2,1)
8005       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8006 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8007 #ifdef MOMENT
8008       eello6_graph2=-(s1+s2+s3+s4)
8009 #else
8010       eello6_graph2=-(s2+s3+s4)
8011 #endif
8012 c      eello6_graph2=-s3
8013 C Derivatives in gamma(i-1)
8014       if (i.gt.1) then
8015 #ifdef MOMENT
8016         s1=dipderg(1,jj,i)*dip(1,kk,k)
8017 #endif
8018         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8019         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8020         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8021         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8022 #ifdef MOMENT
8023         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8024 #else
8025         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8026 #endif
8027 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8028       endif
8029 C Derivatives in gamma(k-1)
8030 #ifdef MOMENT
8031       s1=dip(1,jj,i)*dipderg(1,kk,k)
8032 #endif
8033       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8034       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8035       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8036       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8037       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8038       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8039       vv(1)=pizda(1,1)-pizda(2,2)
8040       vv(2)=pizda(1,2)+pizda(2,1)
8041       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8042 #ifdef MOMENT
8043       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8044 #else
8045       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8046 #endif
8047 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8048 C Derivatives in gamma(j-1) or gamma(l-1)
8049       if (j.gt.1) then
8050 #ifdef MOMENT
8051         s1=dipderg(3,jj,i)*dip(1,kk,k)
8052 #endif
8053         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8054         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8055         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8056         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8057         vv(1)=pizda(1,1)-pizda(2,2)
8058         vv(2)=pizda(1,2)+pizda(2,1)
8059         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8060 #ifdef MOMENT
8061         if (swap) then
8062           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8063         else
8064           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8065         endif
8066 #endif
8067         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8068 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8069       endif
8070 C Derivatives in gamma(l-1) or gamma(j-1)
8071       if (l.gt.1) then
8072 #ifdef MOMENT
8073         s1=dip(1,jj,i)*dipderg(3,kk,k)
8074 #endif
8075         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8076         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8077         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8078         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8079         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8080         vv(1)=pizda(1,1)-pizda(2,2)
8081         vv(2)=pizda(1,2)+pizda(2,1)
8082         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8083 #ifdef MOMENT
8084         if (swap) then
8085           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8086         else
8087           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8088         endif
8089 #endif
8090         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8091 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8092       endif
8093 C Cartesian derivatives.
8094       if (lprn) then
8095         write (2,*) 'In eello6_graph2'
8096         do iii=1,2
8097           write (2,*) 'iii=',iii
8098           do kkk=1,5
8099             write (2,*) 'kkk=',kkk
8100             do jjj=1,2
8101               write (2,'(3(2f10.5),5x)')
8102      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8103             enddo
8104           enddo
8105         enddo
8106       endif
8107       do iii=1,2
8108         do kkk=1,5
8109           do lll=1,3
8110 #ifdef MOMENT
8111             if (iii.eq.1) then
8112               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8113             else
8114               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8115             endif
8116 #endif
8117             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8118      &        auxvec(1))
8119             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8120             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8121      &        auxvec(1))
8122             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8123             call transpose2(EUg(1,1,k),auxmat(1,1))
8124             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8125      &        pizda(1,1))
8126             vv(1)=pizda(1,1)-pizda(2,2)
8127             vv(2)=pizda(1,2)+pizda(2,1)
8128             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8129 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8130 #ifdef MOMENT
8131             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8132 #else
8133             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8134 #endif
8135             if (swap) then
8136               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8137             else
8138               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8139             endif
8140           enddo
8141         enddo
8142       enddo
8143       return
8144       end
8145 c----------------------------------------------------------------------------
8146       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8147       implicit real*8 (a-h,o-z)
8148       include 'DIMENSIONS'
8149       include 'COMMON.IOUNITS'
8150       include 'COMMON.CHAIN'
8151       include 'COMMON.DERIV'
8152       include 'COMMON.INTERACT'
8153       include 'COMMON.CONTACTS'
8154       include 'COMMON.TORSION'
8155       include 'COMMON.VAR'
8156       include 'COMMON.GEO'
8157       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8158       logical swap
8159 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8160 C                                                                              C
8161 C      Parallel       Antiparallel                                             C
8162 C                                                                              C
8163 C          o             o                                                     C
8164 C         /l\   /   \   /j\                                                    C
8165 C        /   \ /     \ /   \                                                   C
8166 C       /| o |o       o| o |\                                                  C
8167 C       j|/k\|  /      |/k\|l /                                                C
8168 C        /   \ /       /   \ /                                                 C
8169 C       /     o       /     o                                                  C
8170 C       i             i                                                        C
8171 C                                                                              C
8172 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8173 C
8174 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8175 C           energy moment and not to the cluster cumulant.
8176       iti=itortyp(itype(i))
8177       if (j.lt.nres-1) then
8178         itj1=itortyp(itype(j+1))
8179       else
8180         itj1=ntortyp+1
8181       endif
8182       itk=itortyp(itype(k))
8183       itk1=itortyp(itype(k+1))
8184       if (l.lt.nres-1) then
8185         itl1=itortyp(itype(l+1))
8186       else
8187         itl1=ntortyp+1
8188       endif
8189 #ifdef MOMENT
8190       s1=dip(4,jj,i)*dip(4,kk,k)
8191 #endif
8192       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8193       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8194       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8195       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8196       call transpose2(EE(1,1,itk),auxmat(1,1))
8197       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8198       vv(1)=pizda(1,1)+pizda(2,2)
8199       vv(2)=pizda(2,1)-pizda(1,2)
8200       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8201 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8202 cd     & "sum",-(s2+s3+s4)
8203 #ifdef MOMENT
8204       eello6_graph3=-(s1+s2+s3+s4)
8205 #else
8206       eello6_graph3=-(s2+s3+s4)
8207 #endif
8208 c      eello6_graph3=-s4
8209 C Derivatives in gamma(k-1)
8210       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8211       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8212       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8213       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8214 C Derivatives in gamma(l-1)
8215       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8216       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8217       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8218       vv(1)=pizda(1,1)+pizda(2,2)
8219       vv(2)=pizda(2,1)-pizda(1,2)
8220       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8221       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8222 C Cartesian derivatives.
8223       do iii=1,2
8224         do kkk=1,5
8225           do lll=1,3
8226 #ifdef MOMENT
8227             if (iii.eq.1) then
8228               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8229             else
8230               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8231             endif
8232 #endif
8233             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8234      &        auxvec(1))
8235             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8236             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8237      &        auxvec(1))
8238             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8239             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8240      &        pizda(1,1))
8241             vv(1)=pizda(1,1)+pizda(2,2)
8242             vv(2)=pizda(2,1)-pizda(1,2)
8243             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8244 #ifdef MOMENT
8245             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8246 #else
8247             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8248 #endif
8249             if (swap) then
8250               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8251             else
8252               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8253             endif
8254 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8255           enddo
8256         enddo
8257       enddo
8258       return
8259       end
8260 c----------------------------------------------------------------------------
8261       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8262       implicit real*8 (a-h,o-z)
8263       include 'DIMENSIONS'
8264       include 'COMMON.IOUNITS'
8265       include 'COMMON.CHAIN'
8266       include 'COMMON.DERIV'
8267       include 'COMMON.INTERACT'
8268       include 'COMMON.CONTACTS'
8269       include 'COMMON.TORSION'
8270       include 'COMMON.VAR'
8271       include 'COMMON.GEO'
8272       include 'COMMON.FFIELD'
8273       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8274      & auxvec1(2),auxmat1(2,2)
8275       logical swap
8276 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8277 C                                                                              C
8278 C      Parallel       Antiparallel                                             C
8279 C                                                                              C
8280 C          o             o                                                     C
8281 C         /l\   /   \   /j\                                                    C
8282 C        /   \ /     \ /   \                                                   C
8283 C       /| o |o       o| o |\                                                  C
8284 C     \ j|/k\|      \  |/k\|l                                                  C
8285 C      \ /   \       \ /   \                                                   C
8286 C       o     \       o     \                                                  C
8287 C       i             i                                                        C
8288 C                                                                              C
8289 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8290 C
8291 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8292 C           energy moment and not to the cluster cumulant.
8293 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8294       iti=itortyp(itype(i))
8295       itj=itortyp(itype(j))
8296       if (j.lt.nres-1) then
8297         itj1=itortyp(itype(j+1))
8298       else
8299         itj1=ntortyp+1
8300       endif
8301       itk=itortyp(itype(k))
8302       if (k.lt.nres-1) then
8303         itk1=itortyp(itype(k+1))
8304       else
8305         itk1=ntortyp+1
8306       endif
8307       itl=itortyp(itype(l))
8308       if (l.lt.nres-1) then
8309         itl1=itortyp(itype(l+1))
8310       else
8311         itl1=ntortyp+1
8312       endif
8313 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8314 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8315 cd     & ' itl',itl,' itl1',itl1
8316 #ifdef MOMENT
8317       if (imat.eq.1) then
8318         s1=dip(3,jj,i)*dip(3,kk,k)
8319       else
8320         s1=dip(2,jj,j)*dip(2,kk,l)
8321       endif
8322 #endif
8323       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8324       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8325       if (j.eq.l+1) then
8326         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8327         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8328       else
8329         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8330         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8331       endif
8332       call transpose2(EUg(1,1,k),auxmat(1,1))
8333       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8334       vv(1)=pizda(1,1)-pizda(2,2)
8335       vv(2)=pizda(2,1)+pizda(1,2)
8336       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8337 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8338 #ifdef MOMENT
8339       eello6_graph4=-(s1+s2+s3+s4)
8340 #else
8341       eello6_graph4=-(s2+s3+s4)
8342 #endif
8343 C Derivatives in gamma(i-1)
8344       if (i.gt.1) then
8345 #ifdef MOMENT
8346         if (imat.eq.1) then
8347           s1=dipderg(2,jj,i)*dip(3,kk,k)
8348         else
8349           s1=dipderg(4,jj,j)*dip(2,kk,l)
8350         endif
8351 #endif
8352         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8353         if (j.eq.l+1) then
8354           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8355           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8356         else
8357           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8358           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8359         endif
8360         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8361         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8362 cd          write (2,*) 'turn6 derivatives'
8363 #ifdef MOMENT
8364           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8365 #else
8366           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8367 #endif
8368         else
8369 #ifdef MOMENT
8370           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8371 #else
8372           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8373 #endif
8374         endif
8375       endif
8376 C Derivatives in gamma(k-1)
8377 #ifdef MOMENT
8378       if (imat.eq.1) then
8379         s1=dip(3,jj,i)*dipderg(2,kk,k)
8380       else
8381         s1=dip(2,jj,j)*dipderg(4,kk,l)
8382       endif
8383 #endif
8384       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8385       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8386       if (j.eq.l+1) then
8387         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8388         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8389       else
8390         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8391         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8392       endif
8393       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8394       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8395       vv(1)=pizda(1,1)-pizda(2,2)
8396       vv(2)=pizda(2,1)+pizda(1,2)
8397       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8398       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8399 #ifdef MOMENT
8400         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8401 #else
8402         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8403 #endif
8404       else
8405 #ifdef MOMENT
8406         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8407 #else
8408         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8409 #endif
8410       endif
8411 C Derivatives in gamma(j-1) or gamma(l-1)
8412       if (l.eq.j+1 .and. l.gt.1) then
8413         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8414         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8415         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8416         vv(1)=pizda(1,1)-pizda(2,2)
8417         vv(2)=pizda(2,1)+pizda(1,2)
8418         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8419         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8420       else if (j.gt.1) then
8421         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8422         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8423         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8424         vv(1)=pizda(1,1)-pizda(2,2)
8425         vv(2)=pizda(2,1)+pizda(1,2)
8426         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8427         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8428           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8429         else
8430           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8431         endif
8432       endif
8433 C Cartesian derivatives.
8434       do iii=1,2
8435         do kkk=1,5
8436           do lll=1,3
8437 #ifdef MOMENT
8438             if (iii.eq.1) then
8439               if (imat.eq.1) then
8440                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8441               else
8442                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8443               endif
8444             else
8445               if (imat.eq.1) then
8446                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8447               else
8448                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8449               endif
8450             endif
8451 #endif
8452             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8453      &        auxvec(1))
8454             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8455             if (j.eq.l+1) then
8456               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8457      &          b1(1,itj1),auxvec(1))
8458               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8459             else
8460               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8461      &          b1(1,itl1),auxvec(1))
8462               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8463             endif
8464             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8465      &        pizda(1,1))
8466             vv(1)=pizda(1,1)-pizda(2,2)
8467             vv(2)=pizda(2,1)+pizda(1,2)
8468             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8469             if (swap) then
8470               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8471 #ifdef MOMENT
8472                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8473      &             -(s1+s2+s4)
8474 #else
8475                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8476      &             -(s2+s4)
8477 #endif
8478                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8479               else
8480 #ifdef MOMENT
8481                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8482 #else
8483                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8484 #endif
8485                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8486               endif
8487             else
8488 #ifdef MOMENT
8489               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8490 #else
8491               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8492 #endif
8493               if (l.eq.j+1) then
8494                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8495               else
8496                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8497               endif
8498             endif
8499           enddo
8500         enddo
8501       enddo
8502       return
8503       end
8504 c----------------------------------------------------------------------------
8505       double precision function eello_turn6(i,jj,kk)
8506       implicit real*8 (a-h,o-z)
8507       include 'DIMENSIONS'
8508       include 'COMMON.IOUNITS'
8509       include 'COMMON.CHAIN'
8510       include 'COMMON.DERIV'
8511       include 'COMMON.INTERACT'
8512       include 'COMMON.CONTACTS'
8513       include 'COMMON.TORSION'
8514       include 'COMMON.VAR'
8515       include 'COMMON.GEO'
8516       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8517      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8518      &  ggg1(3),ggg2(3)
8519       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8520      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8521 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8522 C           the respective energy moment and not to the cluster cumulant.
8523       s1=0.0d0
8524       s8=0.0d0
8525       s13=0.0d0
8526 c
8527       eello_turn6=0.0d0
8528       j=i+4
8529       k=i+1
8530       l=i+3
8531       iti=itortyp(itype(i))
8532       itk=itortyp(itype(k))
8533       itk1=itortyp(itype(k+1))
8534       itl=itortyp(itype(l))
8535       itj=itortyp(itype(j))
8536 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8537 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8538 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8539 cd        eello6=0.0d0
8540 cd        return
8541 cd      endif
8542 cd      write (iout,*)
8543 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8544 cd     &   ' and',k,l
8545 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8546       do iii=1,2
8547         do kkk=1,5
8548           do lll=1,3
8549             derx_turn(lll,kkk,iii)=0.0d0
8550           enddo
8551         enddo
8552       enddo
8553 cd      eij=1.0d0
8554 cd      ekl=1.0d0
8555 cd      ekont=1.0d0
8556       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8557 cd      eello6_5=0.0d0
8558 cd      write (2,*) 'eello6_5',eello6_5
8559 #ifdef MOMENT
8560       call transpose2(AEA(1,1,1),auxmat(1,1))
8561       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8562       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8563       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8564 #endif
8565       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8566       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8567       s2 = scalar2(b1(1,itk),vtemp1(1))
8568 #ifdef MOMENT
8569       call transpose2(AEA(1,1,2),atemp(1,1))
8570       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8571       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8572       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8573 #endif
8574       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8575       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8576       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8577 #ifdef MOMENT
8578       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8579       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8580       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8581       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8582       ss13 = scalar2(b1(1,itk),vtemp4(1))
8583       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8584 #endif
8585 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8586 c      s1=0.0d0
8587 c      s2=0.0d0
8588 c      s8=0.0d0
8589 c      s12=0.0d0
8590 c      s13=0.0d0
8591       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8592 C Derivatives in gamma(i+2)
8593       s1d =0.0d0
8594       s8d =0.0d0
8595 #ifdef MOMENT
8596       call transpose2(AEA(1,1,1),auxmatd(1,1))
8597       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8598       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8599       call transpose2(AEAderg(1,1,2),atempd(1,1))
8600       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8601       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8602 #endif
8603       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8604       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8605       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8606 c      s1d=0.0d0
8607 c      s2d=0.0d0
8608 c      s8d=0.0d0
8609 c      s12d=0.0d0
8610 c      s13d=0.0d0
8611       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8612 C Derivatives in gamma(i+3)
8613 #ifdef MOMENT
8614       call transpose2(AEA(1,1,1),auxmatd(1,1))
8615       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8616       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8617       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8618 #endif
8619       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8620       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8621       s2d = scalar2(b1(1,itk),vtemp1d(1))
8622 #ifdef MOMENT
8623       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8624       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8625 #endif
8626       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8627 #ifdef MOMENT
8628       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8629       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8630       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8631 #endif
8632 c      s1d=0.0d0
8633 c      s2d=0.0d0
8634 c      s8d=0.0d0
8635 c      s12d=0.0d0
8636 c      s13d=0.0d0
8637 #ifdef MOMENT
8638       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8639      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8640 #else
8641       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8642      &               -0.5d0*ekont*(s2d+s12d)
8643 #endif
8644 C Derivatives in gamma(i+4)
8645       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8646       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8647       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8648 #ifdef MOMENT
8649       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8650       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8651       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8652 #endif
8653 c      s1d=0.0d0
8654 c      s2d=0.0d0
8655 c      s8d=0.0d0
8656 C      s12d=0.0d0
8657 c      s13d=0.0d0
8658 #ifdef MOMENT
8659       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8660 #else
8661       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8662 #endif
8663 C Derivatives in gamma(i+5)
8664 #ifdef MOMENT
8665       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8666       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8667       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8668 #endif
8669       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8670       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8671       s2d = scalar2(b1(1,itk),vtemp1d(1))
8672 #ifdef MOMENT
8673       call transpose2(AEA(1,1,2),atempd(1,1))
8674       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8675       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8676 #endif
8677       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8678       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8679 #ifdef MOMENT
8680       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8681       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8682       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8683 #endif
8684 c      s1d=0.0d0
8685 c      s2d=0.0d0
8686 c      s8d=0.0d0
8687 c      s12d=0.0d0
8688 c      s13d=0.0d0
8689 #ifdef MOMENT
8690       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8691      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8692 #else
8693       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8694      &               -0.5d0*ekont*(s2d+s12d)
8695 #endif
8696 C Cartesian derivatives
8697       do iii=1,2
8698         do kkk=1,5
8699           do lll=1,3
8700 #ifdef MOMENT
8701             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8702             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8703             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8704 #endif
8705             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8706             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8707      &          vtemp1d(1))
8708             s2d = scalar2(b1(1,itk),vtemp1d(1))
8709 #ifdef MOMENT
8710             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8711             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8712             s8d = -(atempd(1,1)+atempd(2,2))*
8713      &           scalar2(cc(1,1,itl),vtemp2(1))
8714 #endif
8715             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8716      &           auxmatd(1,1))
8717             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8718             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8719 c      s1d=0.0d0
8720 c      s2d=0.0d0
8721 c      s8d=0.0d0
8722 c      s12d=0.0d0
8723 c      s13d=0.0d0
8724 #ifdef MOMENT
8725             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8726      &        - 0.5d0*(s1d+s2d)
8727 #else
8728             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8729      &        - 0.5d0*s2d
8730 #endif
8731 #ifdef MOMENT
8732             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8733      &        - 0.5d0*(s8d+s12d)
8734 #else
8735             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8736      &        - 0.5d0*s12d
8737 #endif
8738           enddo
8739         enddo
8740       enddo
8741 #ifdef MOMENT
8742       do kkk=1,5
8743         do lll=1,3
8744           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8745      &      achuj_tempd(1,1))
8746           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8747           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8748           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8749           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8750           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8751      &      vtemp4d(1))
8752           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8753           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8754           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8755         enddo
8756       enddo
8757 #endif
8758 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8759 cd     &  16*eel_turn6_num
8760 cd      goto 1112
8761       if (j.lt.nres-1) then
8762         j1=j+1
8763         j2=j-1
8764       else
8765         j1=j-1
8766         j2=j-2
8767       endif
8768       if (l.lt.nres-1) then
8769         l1=l+1
8770         l2=l-1
8771       else
8772         l1=l-1
8773         l2=l-2
8774       endif
8775       do ll=1,3
8776 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8777 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8778 cgrad        ghalf=0.5d0*ggg1(ll)
8779 cd        ghalf=0.0d0
8780         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8781         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8782         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8783      &    +ekont*derx_turn(ll,2,1)
8784         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8785         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8786      &    +ekont*derx_turn(ll,4,1)
8787         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8788         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8789         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8790 cgrad        ghalf=0.5d0*ggg2(ll)
8791 cd        ghalf=0.0d0
8792         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8793      &    +ekont*derx_turn(ll,2,2)
8794         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8795         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8796      &    +ekont*derx_turn(ll,4,2)
8797         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8798         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8799         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8800       enddo
8801 cd      goto 1112
8802 cgrad      do m=i+1,j-1
8803 cgrad        do ll=1,3
8804 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8805 cgrad        enddo
8806 cgrad      enddo
8807 cgrad      do m=k+1,l-1
8808 cgrad        do ll=1,3
8809 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8810 cgrad        enddo
8811 cgrad      enddo
8812 cgrad1112  continue
8813 cgrad      do m=i+2,j2
8814 cgrad        do ll=1,3
8815 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8816 cgrad        enddo
8817 cgrad      enddo
8818 cgrad      do m=k+2,l2
8819 cgrad        do ll=1,3
8820 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8821 cgrad        enddo
8822 cgrad      enddo
8823 cd      do iii=1,nres-3
8824 cd        write (2,*) iii,g_corr6_loc(iii)
8825 cd      enddo
8826       eello_turn6=ekont*eel_turn6
8827 cd      write (2,*) 'ekont',ekont
8828 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8829       return
8830       end
8831
8832 C-----------------------------------------------------------------------------
8833       double precision function scalar(u,v)
8834 !DIR$ INLINEALWAYS scalar
8835 #ifndef OSF
8836 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8837 #endif
8838       implicit none
8839       double precision u(3),v(3)
8840 cd      double precision sc
8841 cd      integer i
8842 cd      sc=0.0d0
8843 cd      do i=1,3
8844 cd        sc=sc+u(i)*v(i)
8845 cd      enddo
8846 cd      scalar=sc
8847
8848       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8849       return
8850       end
8851 crc-------------------------------------------------
8852       SUBROUTINE MATVEC2(A1,V1,V2)
8853 !DIR$ INLINEALWAYS MATVEC2
8854 #ifndef OSF
8855 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8856 #endif
8857       implicit real*8 (a-h,o-z)
8858       include 'DIMENSIONS'
8859       DIMENSION A1(2,2),V1(2),V2(2)
8860 c      DO 1 I=1,2
8861 c        VI=0.0
8862 c        DO 3 K=1,2
8863 c    3     VI=VI+A1(I,K)*V1(K)
8864 c        Vaux(I)=VI
8865 c    1 CONTINUE
8866
8867       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8868       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8869
8870       v2(1)=vaux1
8871       v2(2)=vaux2
8872       END
8873 C---------------------------------------
8874       SUBROUTINE MATMAT2(A1,A2,A3)
8875 #ifndef OSF
8876 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8877 #endif
8878       implicit real*8 (a-h,o-z)
8879       include 'DIMENSIONS'
8880       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8881 c      DIMENSION AI3(2,2)
8882 c        DO  J=1,2
8883 c          A3IJ=0.0
8884 c          DO K=1,2
8885 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8886 c          enddo
8887 c          A3(I,J)=A3IJ
8888 c       enddo
8889 c      enddo
8890
8891       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8892       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8893       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8894       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8895
8896       A3(1,1)=AI3_11
8897       A3(2,1)=AI3_21
8898       A3(1,2)=AI3_12
8899       A3(2,2)=AI3_22
8900       END
8901
8902 c-------------------------------------------------------------------------
8903       double precision function scalar2(u,v)
8904 !DIR$ INLINEALWAYS scalar2
8905       implicit none
8906       double precision u(2),v(2)
8907       double precision sc
8908       integer i
8909       scalar2=u(1)*v(1)+u(2)*v(2)
8910       return
8911       end
8912
8913 C-----------------------------------------------------------------------------
8914
8915       subroutine transpose2(a,at)
8916 !DIR$ INLINEALWAYS transpose2
8917 #ifndef OSF
8918 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8919 #endif
8920       implicit none
8921       double precision a(2,2),at(2,2)
8922       at(1,1)=a(1,1)
8923       at(1,2)=a(2,1)
8924       at(2,1)=a(1,2)
8925       at(2,2)=a(2,2)
8926       return
8927       end
8928 c--------------------------------------------------------------------------
8929       subroutine transpose(n,a,at)
8930       implicit none
8931       integer n,i,j
8932       double precision a(n,n),at(n,n)
8933       do i=1,n
8934         do j=1,n
8935           at(j,i)=a(i,j)
8936         enddo
8937       enddo
8938       return
8939       end
8940 C---------------------------------------------------------------------------
8941       subroutine prodmat3(a1,a2,kk,transp,prod)
8942 !DIR$ INLINEALWAYS prodmat3
8943 #ifndef OSF
8944 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8945 #endif
8946       implicit none
8947       integer i,j
8948       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8949       logical transp
8950 crc      double precision auxmat(2,2),prod_(2,2)
8951
8952       if (transp) then
8953 crc        call transpose2(kk(1,1),auxmat(1,1))
8954 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8955 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8956
8957            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8958      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8959            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8960      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8961            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8962      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8963            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8964      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8965
8966       else
8967 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8968 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8969
8970            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8971      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8972            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8973      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8974            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8975      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8976            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8977      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8978
8979       endif
8980 c      call transpose2(a2(1,1),a2t(1,1))
8981
8982 crc      print *,transp
8983 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8984 crc      print *,((prod(i,j),i=1,2),j=1,2)
8985
8986       return
8987       end
8988