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    Here are the energies showed per procesor if the are more processors
 305 c    per molecule then we sum it up in sum_energy subroutine
 306 c      print *," Processor",myrank," calls SUM_ENERGY"
 307       call sum_energy(energia,.true.)
 308       if (dyn_ss) call dyn_set_nss
 309 c      print *," Processor",myrank," left SUM_ENERGY"
 310 #ifdef TIMING
 311       time_sumene=time_sumene+MPI_Wtime()-time00
 312 #endif
 313       return
 314       end
 315 c-------------------------------------------------------------------------------
 316       subroutine sum_energy(energia,reduce)
 317       implicit real*8 (a-h,o-z)
 318       include 'DIMENSIONS'
 319 #ifndef ISNAN
 320       external proc_proc
 321 #ifdef WINPGI
 322 cMS$ATTRIBUTES C ::  proc_proc
 323 #endif
 324 #endif
 325 #ifdef MPI
 326       include "mpif.h"
 327 #endif
 328       include 'COMMON.SETUP'
 329       include 'COMMON.IOUNITS'
 330       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 331       include 'COMMON.FFIELD'
 332       include 'COMMON.DERIV'
 333       include 'COMMON.INTERACT'
 334       include 'COMMON.SBRIDGE'
 335       include 'COMMON.CHAIN'
 336       include 'COMMON.VAR'
 337       include 'COMMON.CONTROL'
 338       include 'COMMON.TIME1'
 339       logical reduce
 340 #ifdef MPI
 341       if (nfgtasks.gt.1 .and. reduce) then
 342 #ifdef DEBUG
 343         write (iout,*) "energies before REDUCE"
 344         call enerprint(energia)
 345         call flush(iout)
 346 #endif
 347         do i=0,n_ene
 348           enebuff(i)=energia(i)
 349         enddo
 350         time00=MPI_Wtime()
 351         call MPI_Barrier(FG_COMM,IERR)
 352         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 353         time00=MPI_Wtime()
 354         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 355      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 356 #ifdef DEBUG
 357         write (iout,*) "energies after REDUCE"
 358         call enerprint(energia)
 359         call flush(iout)
 360 #endif
 361         time_Reduce=time_Reduce+MPI_Wtime()-time00
 362       endif
 363       if (fg_rank.eq.0) then
 364 #endif
 365       evdw=energia(1)
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 446 #endif
 447       include 'COMMON.SETUP'
 448       include 'COMMON.IOUNITS'
 449       include 'COMMON.FFIELD'
 450       include 'COMMON.DERIV'
 451       include 'COMMON.INTERACT'
 452       include 'COMMON.SBRIDGE'
 453       include 'COMMON.CHAIN'
 454       include 'COMMON.VAR'
 455       include 'COMMON.CONTROL'
 456       include 'COMMON.TIME1'
 457       include 'COMMON.MAXGRAD'
 458       include 'COMMON.SCCOR'
 459 #ifdef TIMING
 460       time01=MPI_Wtime()
 461 #endif
 462 #ifdef DEBUG
 463       write (iout,*) "sum_gradient gvdwc, gvdwx"
 464       do i=1,nres
 465         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 466      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 467       enddo
 468       call flush(iout)
 469 #endif
 470 #ifdef MPI
 471 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 472         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 473      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 474 #endif
 475 C
 476 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 477 C            in virtual-bond-vector coordinates
 478 C
 479 #ifdef DEBUG
 480 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 481 c      do i=1,nres-1
 482 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 483 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 484 c      enddo
 485 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 486 c      do i=1,nres-1
 487 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 488 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 489 c      enddo
 490       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 491       do i=1,nres
 492         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 493      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 494      &   g_corr5_loc(i)
 495       enddo
 496       call flush(iout)
 497 #endif
 498 #ifdef SPLITELE
 499       do i=1,nct
 500         do j=1,3
 501           gradbufc(j,i)=wsc*gvdwc(j,i)+
 502      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 503      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 504      &                wel_loc*gel_loc_long(j,i)+
 505      &                wcorr*gradcorr_long(j,i)+
 506      &                wcorr5*gradcorr5_long(j,i)+
 507      &                wcorr6*gradcorr6_long(j,i)+
 508      &                wturn6*gcorr6_turn_long(j,i)+
 509      &                wstrain*ghpbc(j,i)
 510         enddo
 511       enddo
 512 #else
 513       do i=1,nct
 514         do j=1,3
 515           gradbufc(j,i)=wsc*gvdwc(j,i)+
 516      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 517      &                welec*gelc_long(j,i)+
 518      &                wbond*gradb(j,i)+
 519      &                wel_loc*gel_loc_long(j,i)+
 520      &                wcorr*gradcorr_long(j,i)+
 521      &                wcorr5*gradcorr5_long(j,i)+
 522      &                wcorr6*gradcorr6_long(j,i)+
 523      &                wturn6*gcorr6_turn_long(j,i)+
 524      &                wstrain*ghpbc(j,i)
 525         enddo
 526       enddo
 527 #endif
 528 #ifdef MPI
 529       if (nfgtasks.gt.1) then
 530       time00=MPI_Wtime()
 531 #ifdef DEBUG
 532       write (iout,*) "gradbufc before allreduce"
 533       do i=1,nres
 534         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 535       enddo
 536       call flush(iout)
 537 #endif
 538       do i=1,nres
 539         do j=1,3
 540           gradbufc_sum(j,i)=gradbufc(j,i)
 541         enddo
 542       enddo
 543 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 544 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 545 c      time_reduce=time_reduce+MPI_Wtime()-time00
 546 #ifdef DEBUG
 547 c      write (iout,*) "gradbufc_sum after allreduce"
 548 c      do i=1,nres
 549 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 550 c      enddo
 551 c      call flush(iout)
 552 #endif
 553 #ifdef TIMING
 554 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 555 #endif
 556       do i=nnt,nres
 557         do k=1,3
 558           gradbufc(k,i)=0.0d0
 559         enddo
 560       enddo
 561 #ifdef DEBUG
 562       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 563       write (iout,*) (i," jgrad_start",jgrad_start(i),
 564      &                  " jgrad_end  ",jgrad_end(i),
 565      &                  i=igrad_start,igrad_end)
 566 #endif
 567 c
 568 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 569 c do not parallelize this part.
 570 c
 571 c      do i=igrad_start,igrad_end
 572 c        do j=jgrad_start(i),jgrad_end(i)
 573 c          do k=1,3
 574 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 575 c          enddo
 576 c        enddo
 577 c      enddo
 578       do j=1,3
 579         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 580       enddo
 581       do i=nres-2,nnt,-1
 582         do j=1,3
 583           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 584         enddo
 585       enddo
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc after summing"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       else
 594 #endif
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       do i=1,nres
 603         do j=1,3
 604           gradbufc_sum(j,i)=gradbufc(j,i)
 605           gradbufc(j,i)=0.0d0
 606         enddo
 607       enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,nnt,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 c      do i=nnt,nres-1
 617 c        do k=1,3
 618 c          gradbufc(k,i)=0.0d0
 619 c        enddo
 620 c        do j=i+1,nres
 621 c          do k=1,3
 622 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 623 c          enddo
 624 c        enddo
 625 c      enddo
 626 #ifdef DEBUG
 627       write (iout,*) "gradbufc after summing"
 628       do i=1,nres
 629         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 630       enddo
 631       call flush(iout)
 632 #endif
 633 #ifdef MPI
 634       endif
 635 #endif
 636       do k=1,3
 637         gradbufc(k,nres)=0.0d0
 638       enddo
 639       do i=1,nct
 640         do j=1,3
 641 #ifdef SPLITELE
 642           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 643      &                wel_loc*gel_loc(j,i)+
 644      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 645      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 646      &                wel_loc*gel_loc_long(j,i)+
 647      &                wcorr*gradcorr_long(j,i)+
 648      &                wcorr5*gradcorr5_long(j,i)+
 649      &                wcorr6*gradcorr6_long(j,i)+
 650      &                wturn6*gcorr6_turn_long(j,i))+
 651      &                wbond*gradb(j,i)+
 652      &                wcorr*gradcorr(j,i)+
 653      &                wturn3*gcorr3_turn(j,i)+
 654      &                wturn4*gcorr4_turn(j,i)+
 655      &                wcorr5*gradcorr5(j,i)+
 656      &                wcorr6*gradcorr6(j,i)+
 657      &                wturn6*gcorr6_turn(j,i)+
 658      &                wsccor*gsccorc(j,i)
 659      &               +wscloc*gscloc(j,i)
 660 #else
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679 #endif
 680           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 681      &                  wbond*gradbx(j,i)+
 682      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 683      &                  wsccor*gsccorx(j,i)
 684      &                 +wscloc*gsclocx(j,i)
 685         enddo
 686       enddo
 687 #ifdef DEBUG
 688       write (iout,*) "gloc before adding corr"
 689       do i=1,4*nres
 690         write (iout,*) i,gloc(i,icg)
 691       enddo
 692 #endif
 693       do i=1,nres-3
 694         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 695      &   +wcorr5*g_corr5_loc(i)
 696      &   +wcorr6*g_corr6_loc(i)
 697      &   +wturn4*gel_loc_turn4(i)
 698      &   +wturn3*gel_loc_turn3(i)
 699      &   +wturn6*gel_loc_turn6(i)
 700      &   +wel_loc*gel_loc_loc(i)
 701       enddo
 702 #ifdef DEBUG
 703       write (iout,*) "gloc after adding corr"
 704       do i=1,4*nres
 705         write (iout,*) i,gloc(i,icg)
 706       enddo
 707 #endif
 708 #ifdef MPI
 709       if (nfgtasks.gt.1) then
 710         do j=1,3
 711           do i=1,nres
 712             gradbufc(j,i)=gradc(j,i,icg)
 713             gradbufx(j,i)=gradx(j,i,icg)
 714           enddo
 715         enddo
 716         do i=1,4*nres
 717           glocbuf(i)=gloc(i,icg)
 718         enddo
 719 c#define DEBUG
 720 #ifdef DEBUG
 721       write (iout,*) "gloc_sc before reduce"
 722       do i=1,nres
 723        do j=1,1
 724         write (iout,*) i,j,gloc_sc(j,i,icg)
 725        enddo
 726       enddo
 727 #endif
 728 c#undef DEBUG
 729         do i=1,nres
 730          do j=1,3
 731           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 732          enddo
 733         enddo
 734         time00=MPI_Wtime()
 735         call MPI_Barrier(FG_COMM,IERR)
 736         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 737         time00=MPI_Wtime()
 738         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 739      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 740         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 743      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 744         time_reduce=time_reduce+MPI_Wtime()-time00
 745         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 746      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 747         time_reduce=time_reduce+MPI_Wtime()-time00
 748 c#define DEBUG
 749 #ifdef DEBUG
 750       write (iout,*) "gloc_sc after reduce"
 751       do i=1,nres
 752        do j=1,1
 753         write (iout,*) i,j,gloc_sc(j,i,icg)
 754        enddo
 755       enddo
 756 #endif
 757 c#undef DEBUG
 758 #ifdef DEBUG
 759       write (iout,*) "gloc after reduce"
 760       do i=1,4*nres
 761         write (iout,*) i,gloc(i,icg)
 762       enddo
 763 #endif
 764       endif
 765 #endif
 766       if (gnorm_check) then
 767 c
 768 c Compute the maximum elements of the gradient
 769 c
 770       gvdwc_max=0.0d0
 771       gvdwc_scp_max=0.0d0
 772       gelc_max=0.0d0
 773       gvdwpp_max=0.0d0
 774       gradb_max=0.0d0
 775       ghpbc_max=0.0d0
 776       gradcorr_max=0.0d0
 777       gel_loc_max=0.0d0
 778       gcorr3_turn_max=0.0d0
 779       gcorr4_turn_max=0.0d0
 780       gradcorr5_max=0.0d0
 781       gradcorr6_max=0.0d0
 782       gcorr6_turn_max=0.0d0
 783       gsccorc_max=0.0d0
 784       gscloc_max=0.0d0
 785       gvdwx_max=0.0d0
 786       gradx_scp_max=0.0d0
 787       ghpbx_max=0.0d0
 788       gradxorr_max=0.0d0
 789       gsccorx_max=0.0d0
 790       gsclocx_max=0.0d0
 791       do i=1,nct
 792         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 793         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 794         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 795         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 796      &   gvdwc_scp_max=gvdwc_scp_norm
 797         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 798         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 799         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 800         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 801         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 802         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 803         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 804         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 805         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 806         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 807         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 808         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 809         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 810      &    gcorr3_turn(1,i)))
 811         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 812      &    gcorr3_turn_max=gcorr3_turn_norm
 813         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 814      &    gcorr4_turn(1,i)))
 815         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 816      &    gcorr4_turn_max=gcorr4_turn_norm
 817         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 818         if (gradcorr5_norm.gt.gradcorr5_max)
 819      &    gradcorr5_max=gradcorr5_norm
 820         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 821         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 822         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 823      &    gcorr6_turn(1,i)))
 824         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 825      &    gcorr6_turn_max=gcorr6_turn_norm
 826         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 827         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 828         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 829         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 830         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 831         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 832         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 833         if (gradx_scp_norm.gt.gradx_scp_max)
 834      &    gradx_scp_max=gradx_scp_norm
 835         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 836         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 837         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 838         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 839         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 840         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 841         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 842         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 843       enddo
 844       if (gradout) then
 845 #ifdef AIX
 846         open(istat,file=statname,position="append")
 847 #else
 848         open(istat,file=statname,access="append")
 849 #endif
 850         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 851      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 852      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 853      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 854      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 855      &     gsccorx_max,gsclocx_max
 856         close(istat)
 857         if (gvdwc_max.gt.1.0d4) then
 858           write (iout,*) "gvdwc gvdwx gradb gradbx"
 859           do i=nnt,nct
 860             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 861      &        gradb(j,i),gradbx(j,i),j=1,3)
 862           enddo
 863           call pdbout(0.0d0,'cipiszcze',iout)
 864           call flush(iout)
 865         endif
 866       endif
 867       endif
 868 #ifdef DEBUG
 869       write (iout,*) "gradc gradx gloc"
 870       do i=1,nres
 871         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 872      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 873       enddo
 874 #endif
 875 #ifdef TIMING
 876       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 877 #endif
 878       return
 879       end
 880 c-------------------------------------------------------------------------------
 881       subroutine rescale_weights(t_bath)
 882       implicit real*8 (a-h,o-z)
 883       include 'DIMENSIONS'
 884       include 'COMMON.IOUNITS'
 885       include 'COMMON.FFIELD'
 886       include 'COMMON.SBRIDGE'
 887       double precision kfac /2.4d0/
 888       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 889 c      facT=temp0/t_bath
 890 c      facT=2*temp0/(t_bath+temp0)
 891       if (rescale_mode.eq.0) then
 892         facT=1.0d0
 893         facT2=1.0d0
 894         facT3=1.0d0
 895         facT4=1.0d0
 896         facT5=1.0d0
 897       else if (rescale_mode.eq.1) then
 898         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 899         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 900         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 901         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 902         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 903       else if (rescale_mode.eq.2) then
 904         x=t_bath/temp0
 905         x2=x*x
 906         x3=x2*x
 907         x4=x3*x
 908         x5=x4*x
 909         facT=licznik/dlog(dexp(x)+dexp(-x))
 910         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 911         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 912         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 913         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 914       else
 915         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 916         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 917 #ifdef MPI
 918        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 919 #endif
 920        stop 555
 921       endif
 922       welec=weights(3)*fact
 923       wcorr=weights(4)*fact3
 924       wcorr5=weights(5)*fact4
 925       wcorr6=weights(6)*fact5
 926       wel_loc=weights(7)*fact2
 927       wturn3=weights(8)*fact2
 928       wturn4=weights(9)*fact3
 929       wturn6=weights(10)*fact5
 930       wtor=weights(13)*fact
 931       wtor_d=weights(14)*fact2
 932       wsccor=weights(21)*fact
 933
 934       return
 935       end
 936 C------------------------------------------------------------------------
 937       subroutine enerprint(energia)
 938       implicit real*8 (a-h,o-z)
 939       include 'DIMENSIONS'
 940       include 'COMMON.IOUNITS'
 941       include 'COMMON.FFIELD'
 942       include 'COMMON.SBRIDGE'
 943       include 'COMMON.MD'
 944       double precision energia(0:n_ene)
 945       etot=energia(0)
 946       evdw=energia(1)
 947       evdw2=energia(2)
 948 #ifdef SCP14
 949       evdw2=energia(2)+energia(18)
 950 #else
 951       evdw2=energia(2)
 952 #endif
 953       ees=energia(3)
 954 #ifdef SPLITELE
 955       evdw1=energia(16)
 956 #endif
 957       ecorr=energia(4)
 958       ecorr5=energia(5)
 959       ecorr6=energia(6)
 960       eel_loc=energia(7)
 961       eello_turn3=energia(8)
 962       eello_turn4=energia(9)
 963       eello_turn6=energia(10)
 964       ebe=energia(11)
 965       escloc=energia(12)
 966       etors=energia(13)
 967       etors_d=energia(14)
 968       ehpb=energia(15)
 969       edihcnstr=energia(19)
 970       estr=energia(17)
 971       Uconst=energia(20)
 972       esccor=energia(21)
 973 #ifdef SPLITELE
 974       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 975      &  estr,wbond,ebe,wang,
 976      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 977      &  ecorr,wcorr,
 978      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 979      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 980      &  edihcnstr,ebr*nss,
 981      &  Uconst,etot
 982    10 format (/'Virtual-chain energies:'//
 983      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 984      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 985      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 986      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 987      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 988      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 989      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 990      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 991      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 992      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 993      & ' (SS bridges & dist. cnstr.)'/
 994      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 998      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 999      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1000      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1001      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1002      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1003      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1004      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1005      & 'ETOT=  ',1pE16.6,' (total)')
1006 #else
1007       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1008      &  estr,wbond,ebe,wang,
1009      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1010      &  ecorr,wcorr,
1011      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1012      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1013      &  ebr*nss,Uconst,etot
1014    10 format (/'Virtual-chain energies:'//
1015      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1016      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1017      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1018      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1019      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1020      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1021      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1022      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1023      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1024      & ' (SS bridges & dist. cnstr.)'/
1025      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1029      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1030      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1031      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1032      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1033      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1034      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1035      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1036      & 'ETOT=  ',1pE16.6,' (total)')
1037 #endif
1038       return
1039       end
1040 C-----------------------------------------------------------------------
1041       subroutine elj(evdw)
1042 C
1043 C This subroutine calculates the interaction energy of nonbonded side chains
1044 C assuming the LJ potential of interaction.
1045 C
1046       implicit real*8 (a-h,o-z)
1047       include 'DIMENSIONS'
1048       parameter (accur=1.0d-10)
1049       include 'COMMON.GEO'
1050       include 'COMMON.VAR'
1051       include 'COMMON.LOCAL'
1052       include 'COMMON.CHAIN'
1053       include 'COMMON.DERIV'
1054       include 'COMMON.INTERACT'
1055       include 'COMMON.TORSION'
1056       include 'COMMON.SBRIDGE'
1057       include 'COMMON.NAMES'
1058       include 'COMMON.IOUNITS'
1059       include 'COMMON.CONTACTS'
1060       dimension gg(3)
1061 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 C Change 12/1/95
1071         num_conti=0
1072 C
1073 C Calculate SC interaction energy.
1074 C
1075         do iint=1,nint_gr(i)
1076 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1077 cd   &                  'iend=',iend(i,iint)
1078           do j=istart(i,iint),iend(i,iint)
1079             itypj=iabs(itype(j))
1080             if (itypj.eq.ntyp1) cycle
1081             xj=c(1,nres+j)-xi
1082             yj=c(2,nres+j)-yi
1083             zj=c(3,nres+j)-zi
1084 C Change 12/1/95 to calculate four-body interactions
1085             rij=xj*xj+yj*yj+zj*zj
1086             rrij=1.0D0/rij
1087 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1088             eps0ij=eps(itypi,itypj)
1089             fac=rrij**expon2
1090             e1=fac*fac*aa(itypi,itypj)
1091             e2=fac*bb(itypi,itypj)
1092             evdwij=e1+e2
1093 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1096 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1097 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1098 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1099             evdw=evdw+evdwij
1100 C
1101 C Calculate the components of the gradient in DC and X
1102 C
1103             fac=-rrij*(e1+evdwij)
1104             gg(1)=xj*fac
1105             gg(2)=yj*fac
1106             gg(3)=zj*fac
1107             do k=1,3
1108               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1109               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1110               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1111               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1112             enddo
1113 cgrad            do k=i,j-1
1114 cgrad              do l=1,3
1115 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1116 cgrad              enddo
1117 cgrad            enddo
1118 C
1119 C 12/1/95, revised on 5/20/97
1120 C
1121 C Calculate the contact function. The ith column of the array JCONT will
1122 C contain the numbers of atoms that make contacts with the atom I (of numbers
1123 C greater than I). The arrays FACONT and GACONT will contain the values of
1124 C the contact function and its derivative.
1125 C
1126 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1127 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1128 C Uncomment next line, if the correlation interactions are contact function only
1129             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1130               rij=dsqrt(rij)
1131               sigij=sigma(itypi,itypj)
1132               r0ij=rs0(itypi,itypj)
1133 C
1134 C Check whether the SC's are not too far to make a contact.
1135 C
1136               rcut=1.5d0*r0ij
1137               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1138 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1139 C
1140               if (fcont.gt.0.0D0) then
1141 C If the SC-SC distance if close to sigma, apply spline.
1142 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1143 cAdam &             fcont1,fprimcont1)
1144 cAdam           fcont1=1.0d0-fcont1
1145 cAdam           if (fcont1.gt.0.0d0) then
1146 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1147 cAdam             fcont=fcont*fcont1
1148 cAdam           endif
1149 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1150 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1151 cga             do k=1,3
1152 cga               gg(k)=gg(k)*eps0ij
1153 cga             enddo
1154 cga             eps0ij=-evdwij*eps0ij
1155 C Uncomment for AL's type of SC correlation interactions.
1156 cadam           eps0ij=-evdwij
1157                 num_conti=num_conti+1
1158                 jcont(num_conti,i)=j
1159                 facont(num_conti,i)=fcont*eps0ij
1160                 fprimcont=eps0ij*fprimcont/rij
1161                 fcont=expon*fcont
1162 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1163 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1164 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1165 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1166                 gacont(1,num_conti,i)=-fprimcont*xj
1167                 gacont(2,num_conti,i)=-fprimcont*yj
1168                 gacont(3,num_conti,i)=-fprimcont*zj
1169 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1170 cd              write (iout,'(2i3,3f10.5)')
1171 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1172               endif
1173             endif
1174           enddo      ! j
1175         enddo        ! iint
1176 C Change 12/1/95
1177         num_cont(i)=num_conti
1178       enddo          ! i
1179       do i=1,nct
1180         do j=1,3
1181           gvdwc(j,i)=expon*gvdwc(j,i)
1182           gvdwx(j,i)=expon*gvdwx(j,i)
1183         enddo
1184       enddo
1185 C******************************************************************************
1186 C
1187 C                              N O T E !!!
1188 C
1189 C To save time, the factor of EXPON has been extracted from ALL components
1190 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1191 C use!
1192 C
1193 C******************************************************************************
1194       return
1195       end
1196 C-----------------------------------------------------------------------------
1197       subroutine eljk(evdw)
1198 C
1199 C This subroutine calculates the interaction energy of nonbonded side chains
1200 C assuming the LJK potential of interaction.
1201 C
1202       implicit real*8 (a-h,o-z)
1203       include 'DIMENSIONS'
1204       include 'COMMON.GEO'
1205       include 'COMMON.VAR'
1206       include 'COMMON.LOCAL'
1207       include 'COMMON.CHAIN'
1208       include 'COMMON.DERIV'
1209       include 'COMMON.INTERACT'
1210       include 'COMMON.IOUNITS'
1211       include 'COMMON.NAMES'
1212       dimension gg(3)
1213       logical scheck
1214 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1215       evdw=0.0D0
1216       do i=iatsc_s,iatsc_e
1217         itypi=iabs(itype(i))
1218         if (itypi.eq.ntyp1) cycle
1219         itypi1=iabs(itype(i+1))
1220         xi=c(1,nres+i)
1221         yi=c(2,nres+i)
1222         zi=c(3,nres+i)
1223 C
1224 C Calculate SC interaction energy.
1225 C
1226         do iint=1,nint_gr(i)
1227           do j=istart(i,iint),iend(i,iint)
1228             itypj=iabs(itype(j))
1229             if (itypj.eq.ntyp1) cycle
1230             xj=c(1,nres+j)-xi
1231             yj=c(2,nres+j)-yi
1232             zj=c(3,nres+j)-zi
1233             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1234             fac_augm=rrij**expon
1235             e_augm=augm(itypi,itypj)*fac_augm
1236             r_inv_ij=dsqrt(rrij)
1237             rij=1.0D0/r_inv_ij
1238             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1239             fac=r_shift_inv**expon
1240             e1=fac*fac*aa(itypi,itypj)
1241             e2=fac*bb(itypi,itypj)
1242             evdwij=e_augm+e1+e2
1243 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1244 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1245 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1246 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1247 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1248 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1249 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1250             evdw=evdw+evdwij
1251 C
1252 C Calculate the components of the gradient in DC and X
1253 C
1254             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1255             gg(1)=xj*fac
1256             gg(2)=yj*fac
1257             gg(3)=zj*fac
1258             do k=1,3
1259               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1260               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1261               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1262               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1263             enddo
1264 cgrad            do k=i,j-1
1265 cgrad              do l=1,3
1266 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1267 cgrad              enddo
1268 cgrad            enddo
1269           enddo      ! j
1270         enddo        ! iint
1271       enddo          ! i
1272       do i=1,nct
1273         do j=1,3
1274           gvdwc(j,i)=expon*gvdwc(j,i)
1275           gvdwx(j,i)=expon*gvdwx(j,i)
1276         enddo
1277       enddo
1278       return
1279       end
1280 C-----------------------------------------------------------------------------
1281       subroutine ebp(evdw)
1282 C
1283 C This subroutine calculates the interaction energy of nonbonded side chains
1284 C assuming the Berne-Pechukas potential of interaction.
1285 C
1286       implicit real*8 (a-h,o-z)
1287       include 'DIMENSIONS'
1288       include 'COMMON.GEO'
1289       include 'COMMON.VAR'
1290       include 'COMMON.LOCAL'
1291       include 'COMMON.CHAIN'
1292       include 'COMMON.DERIV'
1293       include 'COMMON.NAMES'
1294       include 'COMMON.INTERACT'
1295       include 'COMMON.IOUNITS'
1296       include 'COMMON.CALC'
1297       common /srutu/ icall
1298 c     double precision rrsave(maxdim)
1299       logical lprn
1300       evdw=0.0D0
1301 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1302       evdw=0.0D0
1303 c     if (icall.eq.0) then
1304 c       lprn=.true.
1305 c     else
1306         lprn=.false.
1307 c     endif
1308       ind=0
1309       do i=iatsc_s,iatsc_e
1310         itypi=iabs(itype(i))
1311         if (itypi.eq.ntyp1) cycle
1312         itypi1=iabs(itype(i+1))
1313         xi=c(1,nres+i)
1314         yi=c(2,nres+i)
1315         zi=c(3,nres+i)
1316         dxi=dc_norm(1,nres+i)
1317         dyi=dc_norm(2,nres+i)
1318         dzi=dc_norm(3,nres+i)
1319 c        dsci_inv=dsc_inv(itypi)
1320         dsci_inv=vbld_inv(i+nres)
1321 C
1322 C Calculate SC interaction energy.
1323 C
1324         do iint=1,nint_gr(i)
1325           do j=istart(i,iint),iend(i,iint)
1326             ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 c            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331             chi1=chi(itypi,itypj)
1332             chi2=chi(itypj,itypi)
1333             chi12=chi1*chi2
1334             chip1=chip(itypi)
1335             chip2=chip(itypj)
1336             chip12=chip1*chip2
1337             alf1=alp(itypi)
1338             alf2=alp(itypj)
1339             alf12=0.5D0*(alf1+alf2)
1340 C For diagnostics only!!!
1341 c           chi1=0.0D0
1342 c           chi2=0.0D0
1343 c           chi12=0.0D0
1344 c           chip1=0.0D0
1345 c           chip2=0.0D0
1346 c           chip12=0.0D0
1347 c           alf1=0.0D0
1348 c           alf2=0.0D0
1349 c           alf12=0.0D0
1350             xj=c(1,nres+j)-xi
1351             yj=c(2,nres+j)-yi
1352             zj=c(3,nres+j)-zi
1353             dxj=dc_norm(1,nres+j)
1354             dyj=dc_norm(2,nres+j)
1355             dzj=dc_norm(3,nres+j)
1356             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1357 cd          if (icall.eq.0) then
1358 cd            rrsave(ind)=rrij
1359 cd          else
1360 cd            rrij=rrsave(ind)
1361 cd          endif
1362             rij=dsqrt(rrij)
1363 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1364             call sc_angular
1365 C Calculate whole angle-dependent part of epsilon and contributions
1366 C to its derivatives
1367             fac=(rrij*sigsq)**expon2
1368             e1=fac*fac*aa(itypi,itypj)
1369             e2=fac*bb(itypi,itypj)
1370             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1371             eps2der=evdwij*eps3rt
1372             eps3der=evdwij*eps2rt
1373             evdwij=evdwij*eps2rt*eps3rt
1374             evdw=evdw+evdwij
1375             if (lprn) then
1376             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1377             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1378 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1379 cd     &        restyp(itypi),i,restyp(itypj),j,
1380 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1381 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1382 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1383 cd     &        evdwij
1384             endif
1385 C Calculate gradient components.
1386             e1=e1*eps1*eps2rt**2*eps3rt**2
1387             fac=-expon*(e1+evdwij)
1388             sigder=fac/sigsq
1389             fac=rrij*fac
1390 C Calculate radial part of the gradient
1391             gg(1)=xj*fac
1392             gg(2)=yj*fac
1393             gg(3)=zj*fac
1394 C Calculate the angular part of the gradient and sum add the contributions
1395 C to the appropriate components of the Cartesian gradient.
1396             call sc_grad
1397           enddo      ! j
1398         enddo        ! iint
1399       enddo          ! i
1400 c     stop
1401       return
1402       end
1403 C-----------------------------------------------------------------------------
1404       subroutine egb(evdw)
1405 C
1406 C This subroutine calculates the interaction energy of nonbonded side chains
1407 C assuming the Gay-Berne potential of interaction.
1408 C
1409       implicit real*8 (a-h,o-z)
1410       include 'DIMENSIONS'
1411       include 'COMMON.GEO'
1412       include 'COMMON.VAR'
1413       include 'COMMON.LOCAL'
1414       include 'COMMON.CHAIN'
1415       include 'COMMON.DERIV'
1416       include 'COMMON.NAMES'
1417       include 'COMMON.INTERACT'
1418       include 'COMMON.IOUNITS'
1419       include 'COMMON.CALC'
1420       include 'COMMON.CONTROL'
1421       include 'COMMON.SBRIDGE'
1422       logical lprn
1423       evdw=0.0D0
1424 ccccc      energy_dec=.false.
1425 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427       lprn=.false.
1428 c     if (icall.eq.0) lprn=.false.
1429       ind=0
1430       do i=iatsc_s,iatsc_e
1431         itypi=iabs(itype(i))
1432         if (itypi.eq.ntyp1) cycle
1433         itypi1=iabs(itype(i+1))
1434         xi=c(1,nres+i)
1435         yi=c(2,nres+i)
1436         zi=c(3,nres+i)
1437         dxi=dc_norm(1,nres+i)
1438         dyi=dc_norm(2,nres+i)
1439         dzi=dc_norm(3,nres+i)
1440 c        dsci_inv=dsc_inv(itypi)
1441         dsci_inv=vbld_inv(i+nres)
1442 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1443 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1450               call dyn_ssbond_ene(i,j,evdwij)
1451               evdw=evdw+evdwij
1452               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1453      &                        'evdw',i,j,evdwij,' ss'
1454 C triple bond artifac removal
1455              do k=j+1,iend(i,iint)
1456 C search over all next residues
1457               if (dyn_ss_mask(k)) then
1458 C check if they are cysteins
1459 C              write(iout,*) 'k=',k
1460               call triple_ssbond_ene(i,j,k,evdwij)
1461 C call the energy function that removes the artifical triple disulfide
1462 C bond the soubroutine is located in ssMD.F
1463               evdw=evdw+evdwij
1464               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1465      &                        'evdw',i,j,evdwij,'tss'
1466               endif!dyn_ss_mask(k)
1467              enddo! k
1468             ELSE
1469             ind=ind+1
1470             itypj=iabs(itype(j))
1471             if (itypj.eq.ntyp1) cycle
1472 c            dscj_inv=dsc_inv(itypj)
1473             dscj_inv=vbld_inv(j+nres)
1474 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1475 c     &       1.0d0/vbld(j+nres)
1476 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1477             sig0ij=sigma(itypi,itypj)
1478             chi1=chi(itypi,itypj)
1479             chi2=chi(itypj,itypi)
1480             chi12=chi1*chi2
1481             chip1=chip(itypi)
1482             chip2=chip(itypj)
1483             chip12=chip1*chip2
1484             alf1=alp(itypi)
1485             alf2=alp(itypj)
1486             alf12=0.5D0*(alf1+alf2)
1487 C For diagnostics only!!!
1488 c           chi1=0.0D0
1489 c           chi2=0.0D0
1490 c           chi12=0.0D0
1491 c           chip1=0.0D0
1492 c           chip2=0.0D0
1493 c           chip12=0.0D0
1494 c           alf1=0.0D0
1495 c           alf2=0.0D0
1496 c           alf12=0.0D0
1497             xj=c(1,nres+j)-xi
1498             yj=c(2,nres+j)-yi
1499             zj=c(3,nres+j)-zi
1500             dxj=dc_norm(1,nres+j)
1501             dyj=dc_norm(2,nres+j)
1502             dzj=dc_norm(3,nres+j)
1503 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1504 c            write (iout,*) "j",j," dc_norm",
1505 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1506             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1507             rij=dsqrt(rrij)
1508 C Calculate angle-dependent terms of energy and contributions to their
1509 C derivatives.
1510             call sc_angular
1511             sigsq=1.0D0/sigsq
1512             sig=sig0ij*dsqrt(sigsq)
1513             rij_shift=1.0D0/rij-sig+sig0ij
1514 c for diagnostics; uncomment
1515 c            rij_shift=1.2*sig0ij
1516 C I hate to put IF's in the loops, but here don't have another choice!!!!
1517             if (rij_shift.le.0.0D0) then
1518               evdw=1.0D20
1519 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1520 cd     &        restyp(itypi),i,restyp(itypj),j,
1521 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1522               return
1523             endif
1524             sigder=-sig*sigsq
1525 c---------------------------------------------------------------
1526             rij_shift=1.0D0/rij_shift
1527             fac=rij_shift**expon
1528             e1=fac*fac*aa(itypi,itypj)
1529             e2=fac*bb(itypi,itypj)
1530             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1531             eps2der=evdwij*eps3rt
1532             eps3der=evdwij*eps2rt
1533 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1534 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1535             evdwij=evdwij*eps2rt*eps3rt
1536             evdw=evdw+evdwij
1537             if (lprn) then
1538             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1539             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1540             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1541      &        restyp(itypi),i,restyp(itypj),j,
1542      &        epsi,sigm,chi1,chi2,chip1,chip2,
1543      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1544      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1545      &        evdwij
1546             endif
1547
1548             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1549      &                        'evdw',i,j,evdwij
1550
1551 C Calculate gradient components.
1552             e1=e1*eps1*eps2rt**2*eps3rt**2
1553             fac=-expon*(e1+evdwij)*rij_shift
1554             sigder=fac*sigder
1555             fac=rij*fac
1556 c            fac=0.0d0
1557 C Calculate the radial part of the gradient
1558             gg(1)=xj*fac
1559             gg(2)=yj*fac
1560             gg(3)=zj*fac
1561 C Calculate angular part of the gradient.
1562             call sc_grad
1563             ENDIF    ! dyn_ss
1564           enddo      ! j
1565         enddo        ! iint
1566       enddo          ! i
1567 c      write (iout,*) "Number of loop steps in EGB:",ind
1568 cccc      energy_dec=.false.
1569       return
1570       end
1571 C-----------------------------------------------------------------------------
1572       subroutine egbv(evdw)
1573 C
1574 C This subroutine calculates the interaction energy of nonbonded side chains
1575 C assuming the Gay-Berne-Vorobjev potential of interaction.
1576 C
1577       implicit real*8 (a-h,o-z)
1578       include 'DIMENSIONS'
1579       include 'COMMON.GEO'
1580       include 'COMMON.VAR'
1581       include 'COMMON.LOCAL'
1582       include 'COMMON.CHAIN'
1583       include 'COMMON.DERIV'
1584       include 'COMMON.NAMES'
1585       include 'COMMON.INTERACT'
1586       include 'COMMON.IOUNITS'
1587       include 'COMMON.CALC'
1588       common /srutu/ icall
1589       logical lprn
1590       evdw=0.0D0
1591 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1592       evdw=0.0D0
1593       lprn=.false.
1594 c     if (icall.eq.0) lprn=.true.
1595       ind=0
1596       do i=iatsc_s,iatsc_e
1597         itypi=iabs(itype(i))
1598         if (itypi.eq.ntyp1) cycle
1599         itypi1=iabs(itype(i+1))
1600         xi=c(1,nres+i)
1601         yi=c(2,nres+i)
1602         zi=c(3,nres+i)
1603         dxi=dc_norm(1,nres+i)
1604         dyi=dc_norm(2,nres+i)
1605         dzi=dc_norm(3,nres+i)
1606 c        dsci_inv=dsc_inv(itypi)
1607         dsci_inv=vbld_inv(i+nres)
1608 C
1609 C Calculate SC interaction energy.
1610 C
1611         do iint=1,nint_gr(i)
1612           do j=istart(i,iint),iend(i,iint)
1613             ind=ind+1
1614             itypj=iabs(itype(j))
1615             if (itypj.eq.ntyp1) cycle
1616 c            dscj_inv=dsc_inv(itypj)
1617             dscj_inv=vbld_inv(j+nres)
1618             sig0ij=sigma(itypi,itypj)
1619             r0ij=r0(itypi,itypj)
1620             chi1=chi(itypi,itypj)
1621             chi2=chi(itypj,itypi)
1622             chi12=chi1*chi2
1623             chip1=chip(itypi)
1624             chip2=chip(itypj)
1625             chip12=chip1*chip2
1626             alf1=alp(itypi)
1627             alf2=alp(itypj)
1628             alf12=0.5D0*(alf1+alf2)
1629 C For diagnostics only!!!
1630 c           chi1=0.0D0
1631 c           chi2=0.0D0
1632 c           chi12=0.0D0
1633 c           chip1=0.0D0
1634 c           chip2=0.0D0
1635 c           chip12=0.0D0
1636 c           alf1=0.0D0
1637 c           alf2=0.0D0
1638 c           alf12=0.0D0
1639             xj=c(1,nres+j)-xi
1640             yj=c(2,nres+j)-yi
1641             zj=c(3,nres+j)-zi
1642             dxj=dc_norm(1,nres+j)
1643             dyj=dc_norm(2,nres+j)
1644             dzj=dc_norm(3,nres+j)
1645             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1646             rij=dsqrt(rrij)
1647 C Calculate angle-dependent terms of energy and contributions to their
1648 C derivatives.
1649             call sc_angular
1650             sigsq=1.0D0/sigsq
1651             sig=sig0ij*dsqrt(sigsq)
1652             rij_shift=1.0D0/rij-sig+r0ij
1653 C I hate to put IF's in the loops, but here don't have another choice!!!!
1654             if (rij_shift.le.0.0D0) then
1655               evdw=1.0D20
1656               return
1657             endif
1658             sigder=-sig*sigsq
1659 c---------------------------------------------------------------
1660             rij_shift=1.0D0/rij_shift
1661             fac=rij_shift**expon
1662             e1=fac*fac*aa(itypi,itypj)
1663             e2=fac*bb(itypi,itypj)
1664             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1665             eps2der=evdwij*eps3rt
1666             eps3der=evdwij*eps2rt
1667             fac_augm=rrij**expon
1668             e_augm=augm(itypi,itypj)*fac_augm
1669             evdwij=evdwij*eps2rt*eps3rt
1670             evdw=evdw+evdwij+e_augm
1671             if (lprn) then
1672             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1673             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1674             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1675      &        restyp(itypi),i,restyp(itypj),j,
1676      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1677      &        chi1,chi2,chip1,chip2,
1678      &        eps1,eps2rt**2,eps3rt**2,
1679      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1680      &        evdwij+e_augm
1681             endif
1682 C Calculate gradient components.
1683             e1=e1*eps1*eps2rt**2*eps3rt**2
1684             fac=-expon*(e1+evdwij)*rij_shift
1685             sigder=fac*sigder
1686             fac=rij*fac-2*expon*rrij*e_augm
1687 C Calculate the radial part of the gradient
1688             gg(1)=xj*fac
1689             gg(2)=yj*fac
1690             gg(3)=zj*fac
1691 C Calculate angular part of the gradient.
1692             call sc_grad
1693           enddo      ! j
1694         enddo        ! iint
1695       enddo          ! i
1696       end
1697 C-----------------------------------------------------------------------------
1698       subroutine sc_angular
1699 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1700 C om12. Called by ebp, egb, and egbv.
1701       implicit none
1702       include 'COMMON.CALC'
1703       include 'COMMON.IOUNITS'
1704       erij(1)=xj*rij
1705       erij(2)=yj*rij
1706       erij(3)=zj*rij
1707       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1708       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1709       om12=dxi*dxj+dyi*dyj+dzi*dzj
1710       chiom12=chi12*om12
1711 C Calculate eps1(om12) and its derivative in om12
1712       faceps1=1.0D0-om12*chiom12
1713       faceps1_inv=1.0D0/faceps1
1714       eps1=dsqrt(faceps1_inv)
1715 C Following variable is eps1*deps1/dom12
1716       eps1_om12=faceps1_inv*chiom12
1717 c diagnostics only
1718 c      faceps1_inv=om12
1719 c      eps1=om12
1720 c      eps1_om12=1.0d0
1721 c      write (iout,*) "om12",om12," eps1",eps1
1722 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1723 C and om12.
1724       om1om2=om1*om2
1725       chiom1=chi1*om1
1726       chiom2=chi2*om2
1727       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1728       sigsq=1.0D0-facsig*faceps1_inv
1729       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1730       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1731       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1732 c diagnostics only
1733 c      sigsq=1.0d0
1734 c      sigsq_om1=0.0d0
1735 c      sigsq_om2=0.0d0
1736 c      sigsq_om12=0.0d0
1737 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1738 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1739 c     &    " eps1",eps1
1740 C Calculate eps2 and its derivatives in om1, om2, and om12.
1741       chipom1=chip1*om1
1742       chipom2=chip2*om2
1743       chipom12=chip12*om12
1744       facp=1.0D0-om12*chipom12
1745       facp_inv=1.0D0/facp
1746       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1747 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1748 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1749 C Following variable is the square root of eps2
1750       eps2rt=1.0D0-facp1*facp_inv
1751 C Following three variables are the derivatives of the square root of eps
1752 C in om1, om2, and om12.
1753       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1754       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1755       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1756 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1757       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1758 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1759 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1760 c     &  " eps2rt_om12",eps2rt_om12
1761 C Calculate whole angle-dependent part of epsilon and contributions
1762 C to its derivatives
1763       return
1764       end
1765 C----------------------------------------------------------------------------
1766       subroutine sc_grad
1767       implicit real*8 (a-h,o-z)
1768       include 'DIMENSIONS'
1769       include 'COMMON.CHAIN'
1770       include 'COMMON.DERIV'
1771       include 'COMMON.CALC'
1772       include 'COMMON.IOUNITS'
1773       double precision dcosom1(3),dcosom2(3)
1774       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1775       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1776       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1777      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1778 c diagnostics only
1779 c      eom1=0.0d0
1780 c      eom2=0.0d0
1781 c      eom12=evdwij*eps1_om12
1782 c end diagnostics
1783 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1784 c     &  " sigder",sigder
1785 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1786 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1787       do k=1,3
1788         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1789         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1790       enddo
1791       do k=1,3
1792         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1793       enddo
1794 c      write (iout,*) "gg",(gg(k),k=1,3)
1795       do k=1,3
1796         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1797      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1798      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1799         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1800      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1801      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1802 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1803 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1804 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1805 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1806       enddo
1807 C
1808 C Calculate the components of the gradient in DC and X
1809 C
1810 cgrad      do k=i,j-1
1811 cgrad        do l=1,3
1812 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1813 cgrad        enddo
1814 cgrad      enddo
1815       do l=1,3
1816         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1817         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1818       enddo
1819       return
1820       end
1821 C-----------------------------------------------------------------------
1822       subroutine e_softsphere(evdw)
1823 C
1824 C This subroutine calculates the interaction energy of nonbonded side chains
1825 C assuming the LJ potential of interaction.
1826 C
1827       implicit real*8 (a-h,o-z)
1828       include 'DIMENSIONS'
1829       parameter (accur=1.0d-10)
1830       include 'COMMON.GEO'
1831       include 'COMMON.VAR'
1832       include 'COMMON.LOCAL'
1833       include 'COMMON.CHAIN'
1834       include 'COMMON.DERIV'
1835       include 'COMMON.INTERACT'
1836       include 'COMMON.TORSION'
1837       include 'COMMON.SBRIDGE'
1838       include 'COMMON.NAMES'
1839       include 'COMMON.IOUNITS'
1840       include 'COMMON.CONTACTS'
1841       dimension gg(3)
1842 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1843       evdw=0.0D0
1844       do i=iatsc_s,iatsc_e
1845         itypi=iabs(itype(i))
1846         if (itypi.eq.ntyp1) cycle
1847         itypi1=iabs(itype(i+1))
1848         xi=c(1,nres+i)
1849         yi=c(2,nres+i)
1850         zi=c(3,nres+i)
1851 C
1852 C Calculate SC interaction energy.
1853 C
1854         do iint=1,nint_gr(i)
1855 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1856 cd   &                  'iend=',iend(i,iint)
1857           do j=istart(i,iint),iend(i,iint)
1858             itypj=iabs(itype(j))
1859             if (itypj.eq.ntyp1) cycle
1860             xj=c(1,nres+j)-xi
1861             yj=c(2,nres+j)-yi
1862             zj=c(3,nres+j)-zi
1863             rij=xj*xj+yj*yj+zj*zj
1864 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1865             r0ij=r0(itypi,itypj)
1866             r0ijsq=r0ij*r0ij
1867 c            print *,i,j,r0ij,dsqrt(rij)
1868             if (rij.lt.r0ijsq) then
1869               evdwij=0.25d0*(rij-r0ijsq)**2
1870               fac=rij-r0ijsq
1871             else
1872               evdwij=0.0d0
1873               fac=0.0d0
1874             endif
1875             evdw=evdw+evdwij
1876 C
1877 C Calculate the components of the gradient in DC and X
1878 C
1879             gg(1)=xj*fac
1880             gg(2)=yj*fac
1881             gg(3)=zj*fac
1882             do k=1,3
1883               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1884               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1885               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1886               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1887             enddo
1888 cgrad            do k=i,j-1
1889 cgrad              do l=1,3
1890 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1891 cgrad              enddo
1892 cgrad            enddo
1893           enddo ! j
1894         enddo ! iint
1895       enddo ! i
1896       return
1897       end
1898 C--------------------------------------------------------------------------
1899       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1900      &              eello_turn4)
1901 C
1902 C Soft-sphere potential of p-p interaction
1903 C
1904       implicit real*8 (a-h,o-z)
1905       include 'DIMENSIONS'
1906       include 'COMMON.CONTROL'
1907       include 'COMMON.IOUNITS'
1908       include 'COMMON.GEO'
1909       include 'COMMON.VAR'
1910       include 'COMMON.LOCAL'
1911       include 'COMMON.CHAIN'
1912       include 'COMMON.DERIV'
1913       include 'COMMON.INTERACT'
1914       include 'COMMON.CONTACTS'
1915       include 'COMMON.TORSION'
1916       include 'COMMON.VECTORS'
1917       include 'COMMON.FFIELD'
1918       dimension ggg(3)
1919 cd      write(iout,*) 'In EELEC_soft_sphere'
1920       ees=0.0D0
1921       evdw1=0.0D0
1922       eel_loc=0.0d0
1923       eello_turn3=0.0d0
1924       eello_turn4=0.0d0
1925       ind=0
1926       do i=iatel_s,iatel_e
1927         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1928         dxi=dc(1,i)
1929         dyi=dc(2,i)
1930         dzi=dc(3,i)
1931         xmedi=c(1,i)+0.5d0*dxi
1932         ymedi=c(2,i)+0.5d0*dyi
1933         zmedi=c(3,i)+0.5d0*dzi
1934         num_conti=0
1935 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1936         do j=ielstart(i),ielend(i)
1937           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1938           ind=ind+1
1939           iteli=itel(i)
1940           itelj=itel(j)
1941           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1942           r0ij=rpp(iteli,itelj)
1943           r0ijsq=r0ij*r0ij
1944           dxj=dc(1,j)
1945           dyj=dc(2,j)
1946           dzj=dc(3,j)
1947           xj=c(1,j)+0.5D0*dxj-xmedi
1948           yj=c(2,j)+0.5D0*dyj-ymedi
1949           zj=c(3,j)+0.5D0*dzj-zmedi
1950           rij=xj*xj+yj*yj+zj*zj
1951           if (rij.lt.r0ijsq) then
1952             evdw1ij=0.25d0*(rij-r0ijsq)**2
1953             fac=rij-r0ijsq
1954           else
1955             evdw1ij=0.0d0
1956             fac=0.0d0
1957           endif
1958           evdw1=evdw1+evdw1ij
1959 C
1960 C Calculate contributions to the Cartesian gradient.
1961 C
1962           ggg(1)=fac*xj
1963           ggg(2)=fac*yj
1964           ggg(3)=fac*zj
1965           do k=1,3
1966             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1967             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1968           enddo
1969 *
1970 * Loop over residues i+1 thru j-1.
1971 *
1972 cgrad          do k=i+1,j-1
1973 cgrad            do l=1,3
1974 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1975 cgrad            enddo
1976 cgrad          enddo
1977         enddo ! j
1978       enddo   ! i
1979 cgrad      do i=nnt,nct-1
1980 cgrad        do k=1,3
1981 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1982 cgrad        enddo
1983 cgrad        do j=i+1,nct-1
1984 cgrad          do k=1,3
1985 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1986 cgrad          enddo
1987 cgrad        enddo
1988 cgrad      enddo
1989       return
1990       end
1991 c------------------------------------------------------------------------------
1992       subroutine vec_and_deriv
1993       implicit real*8 (a-h,o-z)
1994       include 'DIMENSIONS'
1995 #ifdef MPI
1996       include 'mpif.h'
1997 #endif
1998       include 'COMMON.IOUNITS'
1999       include 'COMMON.GEO'
2000       include 'COMMON.VAR'
2001       include 'COMMON.LOCAL'
2002       include 'COMMON.CHAIN'
2003       include 'COMMON.VECTORS'
2004       include 'COMMON.SETUP'
2005       include 'COMMON.TIME1'
2006       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2007 C Compute the local reference systems. For reference system (i), the
2008 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2009 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2010 #ifdef PARVEC
2011       do i=ivec_start,ivec_end
2012 #else
2013       do i=1,nres-1
2014 #endif
2015           if (i.eq.nres-1) then
2016 C Case of the last full residue
2017 C Compute the Z-axis
2018             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2019             costh=dcos(pi-theta(nres))
2020             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2021             do k=1,3
2022               uz(k,i)=fac*uz(k,i)
2023             enddo
2024 C Compute the derivatives of uz
2025             uzder(1,1,1)= 0.0d0
2026             uzder(2,1,1)=-dc_norm(3,i-1)
2027             uzder(3,1,1)= dc_norm(2,i-1)
2028             uzder(1,2,1)= dc_norm(3,i-1)
2029             uzder(2,2,1)= 0.0d0
2030             uzder(3,2,1)=-dc_norm(1,i-1)
2031             uzder(1,3,1)=-dc_norm(2,i-1)
2032             uzder(2,3,1)= dc_norm(1,i-1)
2033             uzder(3,3,1)= 0.0d0
2034             uzder(1,1,2)= 0.0d0
2035             uzder(2,1,2)= dc_norm(3,i)
2036             uzder(3,1,2)=-dc_norm(2,i)
2037             uzder(1,2,2)=-dc_norm(3,i)
2038             uzder(2,2,2)= 0.0d0
2039             uzder(3,2,2)= dc_norm(1,i)
2040             uzder(1,3,2)= dc_norm(2,i)
2041             uzder(2,3,2)=-dc_norm(1,i)
2042             uzder(3,3,2)= 0.0d0
2043 C Compute the Y-axis
2044             facy=fac
2045             do k=1,3
2046               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2047             enddo
2048 C Compute the derivatives of uy
2049             do j=1,3
2050               do k=1,3
2051                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2052      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2053                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2054               enddo
2055               uyder(j,j,1)=uyder(j,j,1)-costh
2056               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2057             enddo
2058             do j=1,2
2059               do k=1,3
2060                 do l=1,3
2061                   uygrad(l,k,j,i)=uyder(l,k,j)
2062                   uzgrad(l,k,j,i)=uzder(l,k,j)
2063                 enddo
2064               enddo
2065             enddo
2066             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2067             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2068             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2069             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2070           else
2071 C Other residues
2072 C Compute the Z-axis
2073             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2074             costh=dcos(pi-theta(i+2))
2075             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2076             do k=1,3
2077               uz(k,i)=fac*uz(k,i)
2078             enddo
2079 C Compute the derivatives of uz
2080             uzder(1,1,1)= 0.0d0
2081             uzder(2,1,1)=-dc_norm(3,i+1)
2082             uzder(3,1,1)= dc_norm(2,i+1)
2083             uzder(1,2,1)= dc_norm(3,i+1)
2084             uzder(2,2,1)= 0.0d0
2085             uzder(3,2,1)=-dc_norm(1,i+1)
2086             uzder(1,3,1)=-dc_norm(2,i+1)
2087             uzder(2,3,1)= dc_norm(1,i+1)
2088             uzder(3,3,1)= 0.0d0
2089             uzder(1,1,2)= 0.0d0
2090             uzder(2,1,2)= dc_norm(3,i)
2091             uzder(3,1,2)=-dc_norm(2,i)
2092             uzder(1,2,2)=-dc_norm(3,i)
2093             uzder(2,2,2)= 0.0d0
2094             uzder(3,2,2)= dc_norm(1,i)
2095             uzder(1,3,2)= dc_norm(2,i)
2096             uzder(2,3,2)=-dc_norm(1,i)
2097             uzder(3,3,2)= 0.0d0
2098 C Compute the Y-axis
2099             facy=fac
2100             do k=1,3
2101               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2102             enddo
2103 C Compute the derivatives of uy
2104             do j=1,3
2105               do k=1,3
2106                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2107      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2108                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2109               enddo
2110               uyder(j,j,1)=uyder(j,j,1)-costh
2111               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2112             enddo
2113             do j=1,2
2114               do k=1,3
2115                 do l=1,3
2116                   uygrad(l,k,j,i)=uyder(l,k,j)
2117                   uzgrad(l,k,j,i)=uzder(l,k,j)
2118                 enddo
2119               enddo
2120             enddo
2121             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2122             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2123             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2124             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2125           endif
2126       enddo
2127       do i=1,nres-1
2128         vbld_inv_temp(1)=vbld_inv(i+1)
2129         if (i.lt.nres-1) then
2130           vbld_inv_temp(2)=vbld_inv(i+2)
2131           else
2132           vbld_inv_temp(2)=vbld_inv(i)
2133           endif
2134         do j=1,2
2135           do k=1,3
2136             do l=1,3
2137               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2138               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2139             enddo
2140           enddo
2141         enddo
2142       enddo
2143 #if defined(PARVEC) && defined(MPI)
2144       if (nfgtasks1.gt.1) then
2145         time00=MPI_Wtime()
2146 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2147 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2148 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2149         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2150      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2151      &   FG_COMM1,IERR)
2152         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2153      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2154      &   FG_COMM1,IERR)
2155         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2156      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2157      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2158         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2159      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2160      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2161         time_gather=time_gather+MPI_Wtime()-time00
2162       endif
2163 c      if (fg_rank.eq.0) then
2164 c        write (iout,*) "Arrays UY and UZ"
2165 c        do i=1,nres-1
2166 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2167 c     &     (uz(k,i),k=1,3)
2168 c        enddo
2169 c      endif
2170 #endif
2171       return
2172       end
2173 C-----------------------------------------------------------------------------
2174       subroutine check_vecgrad
2175       implicit real*8 (a-h,o-z)
2176       include 'DIMENSIONS'
2177       include 'COMMON.IOUNITS'
2178       include 'COMMON.GEO'
2179       include 'COMMON.VAR'
2180       include 'COMMON.LOCAL'
2181       include 'COMMON.CHAIN'
2182       include 'COMMON.VECTORS'
2183       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2184       dimension uyt(3,maxres),uzt(3,maxres)
2185       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2186       double precision delta /1.0d-7/
2187       call vec_and_deriv
2188 cd      do i=1,nres
2189 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2190 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2191 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2192 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2193 cd     &     (dc_norm(if90,i),if90=1,3)
2194 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2195 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2196 cd          write(iout,'(a)')
2197 cd      enddo
2198       do i=1,nres
2199         do j=1,2
2200           do k=1,3
2201             do l=1,3
2202               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2203               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2204             enddo
2205           enddo
2206         enddo
2207       enddo
2208       call vec_and_deriv
2209       do i=1,nres
2210         do j=1,3
2211           uyt(j,i)=uy(j,i)
2212           uzt(j,i)=uz(j,i)
2213         enddo
2214       enddo
2215       do i=1,nres
2216 cd        write (iout,*) 'i=',i
2217         do k=1,3
2218           erij(k)=dc_norm(k,i)
2219         enddo
2220         do j=1,3
2221           do k=1,3
2222             dc_norm(k,i)=erij(k)
2223           enddo
2224           dc_norm(j,i)=dc_norm(j,i)+delta
2225 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2226 c          do k=1,3
2227 c            dc_norm(k,i)=dc_norm(k,i)/fac
2228 c          enddo
2229 c          write (iout,*) (dc_norm(k,i),k=1,3)
2230 c          write (iout,*) (erij(k),k=1,3)
2231           call vec_and_deriv
2232           do k=1,3
2233             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2234             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2235             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2236             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2237           enddo
2238 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2239 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2240 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2241         enddo
2242         do k=1,3
2243           dc_norm(k,i)=erij(k)
2244         enddo
2245 cd        do k=1,3
2246 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2247 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2248 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2249 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2250 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2251 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2252 cd          write (iout,'(a)')
2253 cd        enddo
2254       enddo
2255       return
2256       end
2257 C--------------------------------------------------------------------------
2258       subroutine set_matrices
2259       implicit real*8 (a-h,o-z)
2260       include 'DIMENSIONS'
2261 #ifdef MPI
2262       include "mpif.h"
2263       include "COMMON.SETUP"
2264       integer IERR
2265       integer status(MPI_STATUS_SIZE)
2266 #endif
2267       include 'COMMON.IOUNITS'
2268       include 'COMMON.GEO'
2269       include 'COMMON.VAR'
2270       include 'COMMON.LOCAL'
2271       include 'COMMON.CHAIN'
2272       include 'COMMON.DERIV'
2273       include 'COMMON.INTERACT'
2274       include 'COMMON.CONTACTS'
2275       include 'COMMON.TORSION'
2276       include 'COMMON.VECTORS'
2277       include 'COMMON.FFIELD'
2278       double precision auxvec(2),auxmat(2,2)
2279 C
2280 C Compute the virtual-bond-torsional-angle dependent quantities needed
2281 C to calculate the el-loc multibody terms of various order.
2282 C
2283 #ifdef PARMAT
2284       do i=ivec_start+2,ivec_end+2
2285 #else
2286       do i=3,nres+1
2287 #endif
2288         if (i .lt. nres+1) then
2289           sin1=dsin(phi(i))
2290           cos1=dcos(phi(i))
2291           sintab(i-2)=sin1
2292           costab(i-2)=cos1
2293           obrot(1,i-2)=cos1
2294           obrot(2,i-2)=sin1
2295           sin2=dsin(2*phi(i))
2296           cos2=dcos(2*phi(i))
2297           sintab2(i-2)=sin2
2298           costab2(i-2)=cos2
2299           obrot2(1,i-2)=cos2
2300           obrot2(2,i-2)=sin2
2301           Ug(1,1,i-2)=-cos1
2302           Ug(1,2,i-2)=-sin1
2303           Ug(2,1,i-2)=-sin1
2304           Ug(2,2,i-2)= cos1
2305           Ug2(1,1,i-2)=-cos2
2306           Ug2(1,2,i-2)=-sin2
2307           Ug2(2,1,i-2)=-sin2
2308           Ug2(2,2,i-2)= cos2
2309         else
2310           costab(i-2)=1.0d0
2311           sintab(i-2)=0.0d0
2312           obrot(1,i-2)=1.0d0
2313           obrot(2,i-2)=0.0d0
2314           obrot2(1,i-2)=0.0d0
2315           obrot2(2,i-2)=0.0d0
2316           Ug(1,1,i-2)=1.0d0
2317           Ug(1,2,i-2)=0.0d0
2318           Ug(2,1,i-2)=0.0d0
2319           Ug(2,2,i-2)=1.0d0
2320           Ug2(1,1,i-2)=0.0d0
2321           Ug2(1,2,i-2)=0.0d0
2322           Ug2(2,1,i-2)=0.0d0
2323           Ug2(2,2,i-2)=0.0d0
2324         endif
2325         if (i .gt. 3 .and. i .lt. nres+1) then
2326           obrot_der(1,i-2)=-sin1
2327           obrot_der(2,i-2)= cos1
2328           Ugder(1,1,i-2)= sin1
2329           Ugder(1,2,i-2)=-cos1
2330           Ugder(2,1,i-2)=-cos1
2331           Ugder(2,2,i-2)=-sin1
2332           dwacos2=cos2+cos2
2333           dwasin2=sin2+sin2
2334           obrot2_der(1,i-2)=-dwasin2
2335           obrot2_der(2,i-2)= dwacos2
2336           Ug2der(1,1,i-2)= dwasin2
2337           Ug2der(1,2,i-2)=-dwacos2
2338           Ug2der(2,1,i-2)=-dwacos2
2339           Ug2der(2,2,i-2)=-dwasin2
2340         else
2341           obrot_der(1,i-2)=0.0d0
2342           obrot_der(2,i-2)=0.0d0
2343           Ugder(1,1,i-2)=0.0d0
2344           Ugder(1,2,i-2)=0.0d0
2345           Ugder(2,1,i-2)=0.0d0
2346           Ugder(2,2,i-2)=0.0d0
2347           obrot2_der(1,i-2)=0.0d0
2348           obrot2_der(2,i-2)=0.0d0
2349           Ug2der(1,1,i-2)=0.0d0
2350           Ug2der(1,2,i-2)=0.0d0
2351           Ug2der(2,1,i-2)=0.0d0
2352           Ug2der(2,2,i-2)=0.0d0
2353         endif
2354 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2355         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2356           iti = itortyp(itype(i-2))
2357         else
2358           iti=ntortyp+1
2359         endif
2360 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2361         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2362           iti1 = itortyp(itype(i-1))
2363         else
2364           iti1=ntortyp+1
2365         endif
2366 cd        write (iout,*) '*******i',i,' iti1',iti
2367 cd        write (iout,*) 'b1',b1(:,iti)
2368 cd        write (iout,*) 'b2',b2(:,iti)
2369 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2370 c        if (i .gt. iatel_s+2) then
2371         if (i .gt. nnt+2) then
2372           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2373           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2374           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2375      &    then
2376           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2377           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2378           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2379           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2380           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2381           endif
2382         else
2383           do k=1,2
2384             Ub2(k,i-2)=0.0d0
2385             Ctobr(k,i-2)=0.0d0
2386             Dtobr2(k,i-2)=0.0d0
2387             do l=1,2
2388               EUg(l,k,i-2)=0.0d0
2389               CUg(l,k,i-2)=0.0d0
2390               DUg(l,k,i-2)=0.0d0
2391               DtUg2(l,k,i-2)=0.0d0
2392             enddo
2393           enddo
2394         endif
2395         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2396         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2397         do k=1,2
2398           muder(k,i-2)=Ub2der(k,i-2)
2399         enddo
2400 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2401         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2402           if (itype(i-1).le.ntyp) then
2403             iti1 = itortyp(itype(i-1))
2404           else
2405             iti1=ntortyp+1
2406           endif
2407         else
2408           iti1=ntortyp+1
2409         endif
2410         do k=1,2
2411           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2412         enddo
2413 cd        write (iout,*) 'mu ',mu(:,i-2)
2414 cd        write (iout,*) 'mu1',mu1(:,i-2)
2415 cd        write (iout,*) 'mu2',mu2(:,i-2)
2416         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2417      &  then
2418         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2419         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2420         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2421         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2422         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2423 C Vectors and matrices dependent on a single virtual-bond dihedral.
2424         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2425         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2426         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2427         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2428         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2429         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2430         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2431         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2432         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2433         endif
2434       enddo
2435 C Matrices dependent on two consecutive virtual-bond dihedrals.
2436 C The order of matrices is from left to right.
2437       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2438      &then
2439 c      do i=max0(ivec_start,2),ivec_end
2440       do i=2,nres-1
2441         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2442         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2443         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2444         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2445         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2446         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2447         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2448         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2449       enddo
2450       endif
2451 #if defined(MPI) && defined(PARMAT)
2452 #ifdef DEBUG
2453 c      if (fg_rank.eq.0) then
2454         write (iout,*) "Arrays UG and UGDER before GATHER"
2455         do i=1,nres-1
2456           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2457      &     ((ug(l,k,i),l=1,2),k=1,2),
2458      &     ((ugder(l,k,i),l=1,2),k=1,2)
2459         enddo
2460         write (iout,*) "Arrays UG2 and UG2DER"
2461         do i=1,nres-1
2462           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2463      &     ((ug2(l,k,i),l=1,2),k=1,2),
2464      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2465         enddo
2466         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2467         do i=1,nres-1
2468           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2469      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2470      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2471         enddo
2472         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2473         do i=1,nres-1
2474           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2475      &     costab(i),sintab(i),costab2(i),sintab2(i)
2476         enddo
2477         write (iout,*) "Array MUDER"
2478         do i=1,nres-1
2479           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2480         enddo
2481 c      endif
2482 #endif
2483       if (nfgtasks.gt.1) then
2484         time00=MPI_Wtime()
2485 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2486 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2487 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2488 #ifdef MATGATHER
2489         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2490      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2491      &   FG_COMM1,IERR)
2492         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2493      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2494      &   FG_COMM1,IERR)
2495         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2496      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2497      &   FG_COMM1,IERR)
2498         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2499      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2500      &   FG_COMM1,IERR)
2501         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2502      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2503      &   FG_COMM1,IERR)
2504         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2505      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2506      &   FG_COMM1,IERR)
2507         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2508      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2509      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2510         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2511      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2512      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2513         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2514      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2515      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2516         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2517      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2518      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2519         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2520      &  then
2521         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2528      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2529      &   FG_COMM1,IERR)
2530        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2531      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2532      &   FG_COMM1,IERR)
2533         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2534      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2535      &   FG_COMM1,IERR)
2536         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2537      &   ivec_count(fg_rank1),
2538      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2539      &   FG_COMM1,IERR)
2540         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2541      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2542      &   FG_COMM1,IERR)
2543         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2544      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2545      &   FG_COMM1,IERR)
2546         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2547      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2548      &   FG_COMM1,IERR)
2549         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2550      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2551      &   FG_COMM1,IERR)
2552         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2562      &   ivec_count(fg_rank1),
2563      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2564      &   FG_COMM1,IERR)
2565         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2566      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2567      &   FG_COMM1,IERR)
2568        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2569      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2570      &   FG_COMM1,IERR)
2571         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2572      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2573      &   FG_COMM1,IERR)
2574        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2575      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2576      &   FG_COMM1,IERR)
2577         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2578      &   ivec_count(fg_rank1),
2579      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2580      &   FG_COMM1,IERR)
2581         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2582      &   ivec_count(fg_rank1),
2583      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2584      &   FG_COMM1,IERR)
2585         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2586      &   ivec_count(fg_rank1),
2587      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2588      &   MPI_MAT2,FG_COMM1,IERR)
2589         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2590      &   ivec_count(fg_rank1),
2591      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2592      &   MPI_MAT2,FG_COMM1,IERR)
2593         endif
2594 #else
2595 c Passes matrix info through the ring
2596       isend=fg_rank1
2597       irecv=fg_rank1-1
2598       if (irecv.lt.0) irecv=nfgtasks1-1
2599       iprev=irecv
2600       inext=fg_rank1+1
2601       if (inext.ge.nfgtasks1) inext=0
2602       do i=1,nfgtasks1-1
2603 c        write (iout,*) "isend",isend," irecv",irecv
2604 c        call flush(iout)
2605         lensend=lentyp(isend)
2606         lenrecv=lentyp(irecv)
2607 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2608 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2609 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2610 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2611 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2612 c        write (iout,*) "Gather ROTAT1"
2613 c        call flush(iout)
2614 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2615 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2616 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2617 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2618 c        write (iout,*) "Gather ROTAT2"
2619 c        call flush(iout)
2620         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2621      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2622      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2623      &   iprev,4400+irecv,FG_COMM,status,IERR)
2624 c        write (iout,*) "Gather ROTAT_OLD"
2625 c        call flush(iout)
2626         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2627      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2628      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2629      &   iprev,5500+irecv,FG_COMM,status,IERR)
2630 c        write (iout,*) "Gather PRECOMP11"
2631 c        call flush(iout)
2632         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2633      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2634      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2635      &   iprev,6600+irecv,FG_COMM,status,IERR)
2636 c        write (iout,*) "Gather PRECOMP12"
2637 c        call flush(iout)
2638         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2639      &  then
2640         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2641      &   MPI_ROTAT2(lensend),inext,7700+isend,
2642      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2643      &   iprev,7700+irecv,FG_COMM,status,IERR)
2644 c        write (iout,*) "Gather PRECOMP21"
2645 c        call flush(iout)
2646         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2647      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2648      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2649      &   iprev,8800+irecv,FG_COMM,status,IERR)
2650 c        write (iout,*) "Gather PRECOMP22"
2651 c        call flush(iout)
2652         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2653      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2654      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2655      &   MPI_PRECOMP23(lenrecv),
2656      &   iprev,9900+irecv,FG_COMM,status,IERR)
2657 c        write (iout,*) "Gather PRECOMP23"
2658 c        call flush(iout)
2659         endif
2660         isend=irecv
2661         irecv=irecv-1
2662         if (irecv.lt.0) irecv=nfgtasks1-1
2663       enddo
2664 #endif
2665         time_gather=time_gather+MPI_Wtime()-time00
2666       endif
2667 #ifdef DEBUG
2668 c      if (fg_rank.eq.0) then
2669         write (iout,*) "Arrays UG and UGDER"
2670         do i=1,nres-1
2671           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2672      &     ((ug(l,k,i),l=1,2),k=1,2),
2673      &     ((ugder(l,k,i),l=1,2),k=1,2)
2674         enddo
2675         write (iout,*) "Arrays UG2 and UG2DER"
2676         do i=1,nres-1
2677           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2678      &     ((ug2(l,k,i),l=1,2),k=1,2),
2679      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2680         enddo
2681         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2682         do i=1,nres-1
2683           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2684      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2685      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2686         enddo
2687         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2688         do i=1,nres-1
2689           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2690      &     costab(i),sintab(i),costab2(i),sintab2(i)
2691         enddo
2692         write (iout,*) "Array MUDER"
2693         do i=1,nres-1
2694           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2695         enddo
2696 c      endif
2697 #endif
2698 #endif
2699 cd      do i=1,nres
2700 cd        iti = itortyp(itype(i))
2701 cd        write (iout,*) i
2702 cd        do j=1,2
2703 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2704 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2705 cd        enddo
2706 cd      enddo
2707       return
2708       end
2709 C--------------------------------------------------------------------------
2710       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2711 C
2712 C This subroutine calculates the average interaction energy and its gradient
2713 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2714 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2715 C The potential depends both on the distance of peptide-group centers and on
2716 C the orientation of the CA-CA virtual bonds.
2717 C
2718       implicit real*8 (a-h,o-z)
2719 #ifdef MPI
2720       include 'mpif.h'
2721 #endif
2722       include 'DIMENSIONS'
2723       include 'COMMON.CONTROL'
2724       include 'COMMON.SETUP'
2725       include 'COMMON.IOUNITS'
2726       include 'COMMON.GEO'
2727       include 'COMMON.VAR'
2728       include 'COMMON.LOCAL'
2729       include 'COMMON.CHAIN'
2730       include 'COMMON.DERIV'
2731       include 'COMMON.INTERACT'
2732       include 'COMMON.CONTACTS'
2733       include 'COMMON.TORSION'
2734       include 'COMMON.VECTORS'
2735       include 'COMMON.FFIELD'
2736       include 'COMMON.TIME1'
2737       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2738      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2739       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2740      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2741       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2742      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2743      &    num_conti,j1,j2
2744 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2745 #ifdef MOMENT
2746       double precision scal_el /1.0d0/
2747 #else
2748       double precision scal_el /0.5d0/
2749 #endif
2750 C 12/13/98
2751 C 13-go grudnia roku pamietnego...
2752       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2753      &                   0.0d0,1.0d0,0.0d0,
2754      &                   0.0d0,0.0d0,1.0d0/
2755 cd      write(iout,*) 'In EELEC'
2756 cd      do i=1,nloctyp
2757 cd        write(iout,*) 'Type',i
2758 cd        write(iout,*) 'B1',B1(:,i)
2759 cd        write(iout,*) 'B2',B2(:,i)
2760 cd        write(iout,*) 'CC',CC(:,:,i)
2761 cd        write(iout,*) 'DD',DD(:,:,i)
2762 cd        write(iout,*) 'EE',EE(:,:,i)
2763 cd      enddo
2764 cd      call check_vecgrad
2765 cd      stop
2766       if (icheckgrad.eq.1) then
2767         do i=1,nres-1
2768           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2769           do k=1,3
2770             dc_norm(k,i)=dc(k,i)*fac
2771           enddo
2772 c          write (iout,*) 'i',i,' fac',fac
2773         enddo
2774       endif
2775       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2776      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2777      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2778 c        call vec_and_deriv
2779 #ifdef TIMING
2780         time01=MPI_Wtime()
2781 #endif
2782         call set_matrices
2783 #ifdef TIMING
2784         time_mat=time_mat+MPI_Wtime()-time01
2785 #endif
2786       endif
2787 cd      do i=1,nres-1
2788 cd        write (iout,*) 'i=',i
2789 cd        do k=1,3
2790 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2791 cd        enddo
2792 cd        do k=1,3
2793 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2794 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2795 cd        enddo
2796 cd      enddo
2797       t_eelecij=0.0d0
2798       ees=0.0D0
2799       evdw1=0.0D0
2800       eel_loc=0.0d0
2801       eello_turn3=0.0d0
2802       eello_turn4=0.0d0
2803       ind=0
2804       do i=1,nres
2805         num_cont_hb(i)=0
2806       enddo
2807 cd      print '(a)','Enter EELEC'
2808 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2809       do i=1,nres
2810         gel_loc_loc(i)=0.0d0
2811         gcorr_loc(i)=0.0d0
2812       enddo
2813 c
2814 c
2815 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2816 C
2817 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2818 C
2819       do i=iturn3_start,iturn3_end
2820         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2821      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2822         dxi=dc(1,i)
2823         dyi=dc(2,i)
2824         dzi=dc(3,i)
2825         dx_normi=dc_norm(1,i)
2826         dy_normi=dc_norm(2,i)
2827         dz_normi=dc_norm(3,i)
2828         xmedi=c(1,i)+0.5d0*dxi
2829         ymedi=c(2,i)+0.5d0*dyi
2830         zmedi=c(3,i)+0.5d0*dzi
2831         num_conti=0
2832         call eelecij(i,i+2,ees,evdw1,eel_loc)
2833         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2834         num_cont_hb(i)=num_conti
2835       enddo
2836       do i=iturn4_start,iturn4_end
2837         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2838      &    .or. itype(i+3).eq.ntyp1
2839      &    .or. itype(i+4).eq.ntyp1) cycle
2840         dxi=dc(1,i)
2841         dyi=dc(2,i)
2842         dzi=dc(3,i)
2843         dx_normi=dc_norm(1,i)
2844         dy_normi=dc_norm(2,i)
2845         dz_normi=dc_norm(3,i)
2846         xmedi=c(1,i)+0.5d0*dxi
2847         ymedi=c(2,i)+0.5d0*dyi
2848         zmedi=c(3,i)+0.5d0*dzi
2849         num_conti=num_cont_hb(i)
2850         call eelecij(i,i+3,ees,evdw1,eel_loc)
2851         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2852      &   call eturn4(i,eello_turn4)
2853         num_cont_hb(i)=num_conti
2854       enddo   ! i
2855 c
2856 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2857 c
2858       do i=iatel_s,iatel_e
2859         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2860         dxi=dc(1,i)
2861         dyi=dc(2,i)
2862         dzi=dc(3,i)
2863         dx_normi=dc_norm(1,i)
2864         dy_normi=dc_norm(2,i)
2865         dz_normi=dc_norm(3,i)
2866         xmedi=c(1,i)+0.5d0*dxi
2867         ymedi=c(2,i)+0.5d0*dyi
2868         zmedi=c(3,i)+0.5d0*dzi
2869 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2870         num_conti=num_cont_hb(i)
2871         do j=ielstart(i),ielend(i)
2872 c          write (iout,*) i,j,itype(i),itype(j)
2873           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2874           call eelecij(i,j,ees,evdw1,eel_loc)
2875         enddo ! j
2876         num_cont_hb(i)=num_conti
2877       enddo   ! i
2878 c      write (iout,*) "Number of loop steps in EELEC:",ind
2879 cd      do i=1,nres
2880 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2881 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2882 cd      enddo
2883 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2884 ccc      eel_loc=eel_loc+eello_turn3
2885 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2886       return
2887       end
2888 C-------------------------------------------------------------------------------
2889       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2890       implicit real*8 (a-h,o-z)
2891       include 'DIMENSIONS'
2892 #ifdef MPI
2893       include "mpif.h"
2894 #endif
2895       include 'COMMON.CONTROL'
2896       include 'COMMON.IOUNITS'
2897       include 'COMMON.GEO'
2898       include 'COMMON.VAR'
2899       include 'COMMON.LOCAL'
2900       include 'COMMON.CHAIN'
2901       include 'COMMON.DERIV'
2902       include 'COMMON.INTERACT'
2903       include 'COMMON.CONTACTS'
2904       include 'COMMON.TORSION'
2905       include 'COMMON.VECTORS'
2906       include 'COMMON.FFIELD'
2907       include 'COMMON.TIME1'
2908       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2909      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2910       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2911      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2912       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2913      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2914      &    num_conti,j1,j2
2915 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2916 #ifdef MOMENT
2917       double precision scal_el /1.0d0/
2918 #else
2919       double precision scal_el /0.5d0/
2920 #endif
2921 C 12/13/98
2922 C 13-go grudnia roku pamietnego...
2923       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2924      &                   0.0d0,1.0d0,0.0d0,
2925      &                   0.0d0,0.0d0,1.0d0/
2926 c          time00=MPI_Wtime()
2927 cd      write (iout,*) "eelecij",i,j
2928 c          ind=ind+1
2929           iteli=itel(i)
2930           itelj=itel(j)
2931           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2932           aaa=app(iteli,itelj)
2933           bbb=bpp(iteli,itelj)
2934           ael6i=ael6(iteli,itelj)
2935           ael3i=ael3(iteli,itelj)
2936           dxj=dc(1,j)
2937           dyj=dc(2,j)
2938           dzj=dc(3,j)
2939           dx_normj=dc_norm(1,j)
2940           dy_normj=dc_norm(2,j)
2941           dz_normj=dc_norm(3,j)
2942           xj=c(1,j)+0.5D0*dxj-xmedi
2943           yj=c(2,j)+0.5D0*dyj-ymedi
2944           zj=c(3,j)+0.5D0*dzj-zmedi
2945           rij=xj*xj+yj*yj+zj*zj
2946           rrmij=1.0D0/rij
2947           rij=dsqrt(rij)
2948           rmij=1.0D0/rij
2949           r3ij=rrmij*rmij
2950           r6ij=r3ij*r3ij
2951           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2952           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2953           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2954           fac=cosa-3.0D0*cosb*cosg
2955           ev1=aaa*r6ij*r6ij
2956 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2957           if (j.eq.i+2) ev1=scal_el*ev1
2958           ev2=bbb*r6ij
2959           fac3=ael6i*r6ij
2960           fac4=ael3i*r3ij
2961           evdwij=ev1+ev2
2962           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2963           el2=fac4*fac
2964           eesij=el1+el2
2965 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2966           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2967           ees=ees+eesij
2968           evdw1=evdw1+evdwij
2969 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2970 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2971 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2972 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2973
2974           if (energy_dec) then
2975               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2976      &'evdw1',i,j,evdwij
2977      &,iteli,itelj,aaa,evdw1
2978               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2979           endif
2980
2981 C
2982 C Calculate contributions to the Cartesian gradient.
2983 C
2984 #ifdef SPLITELE
2985           facvdw=-6*rrmij*(ev1+evdwij)
2986           facel=-3*rrmij*(el1+eesij)
2987           fac1=fac
2988           erij(1)=xj*rmij
2989           erij(2)=yj*rmij
2990           erij(3)=zj*rmij
2991 *
2992 * Radial derivatives. First process both termini of the fragment (i,j)
2993 *
2994           ggg(1)=facel*xj
2995           ggg(2)=facel*yj
2996           ggg(3)=facel*zj
2997 c          do k=1,3
2998 c            ghalf=0.5D0*ggg(k)
2999 c            gelc(k,i)=gelc(k,i)+ghalf
3000 c            gelc(k,j)=gelc(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             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3005             gelc_long(k,i)=gelc_long(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              gelc(l,k)=gelc(l,k)+ggg(l)
3013 cgrad            enddo
3014 cgrad          enddo
3015           ggg(1)=facvdw*xj
3016           ggg(2)=facvdw*yj
3017           ggg(3)=facvdw*zj
3018 c          do k=1,3
3019 c            ghalf=0.5D0*ggg(k)
3020 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3021 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3022 c          enddo
3023 c 9/28/08 AL Gradient compotents will be summed only at the end
3024           do k=1,3
3025             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3026             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3027           enddo
3028 *
3029 * Loop over residues i+1 thru j-1.
3030 *
3031 cgrad          do k=i+1,j-1
3032 cgrad            do l=1,3
3033 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3034 cgrad            enddo
3035 cgrad          enddo
3036 #else
3037           facvdw=ev1+evdwij
3038           facel=el1+eesij
3039           fac1=fac
3040           fac=-3*rrmij*(facvdw+facvdw+facel)
3041           erij(1)=xj*rmij
3042           erij(2)=yj*rmij
3043           erij(3)=zj*rmij
3044 *
3045 * Radial derivatives. First process both termini of the fragment (i,j)
3046 *
3047           ggg(1)=fac*xj
3048           ggg(2)=fac*yj
3049           ggg(3)=fac*zj
3050 c          do k=1,3
3051 c            ghalf=0.5D0*ggg(k)
3052 c            gelc(k,i)=gelc(k,i)+ghalf
3053 c            gelc(k,j)=gelc(k,j)+ghalf
3054 c          enddo
3055 c 9/28/08 AL Gradient compotents will be summed only at the end
3056           do k=1,3
3057             gelc_long(k,j)=gelc(k,j)+ggg(k)
3058             gelc_long(k,i)=gelc(k,i)-ggg(k)
3059           enddo
3060 *
3061 * Loop over residues i+1 thru j-1.
3062 *
3063 cgrad          do k=i+1,j-1
3064 cgrad            do l=1,3
3065 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3066 cgrad            enddo
3067 cgrad          enddo
3068 c 9/28/08 AL Gradient compotents will be summed only at the end
3069           ggg(1)=facvdw*xj
3070           ggg(2)=facvdw*yj
3071           ggg(3)=facvdw*zj
3072           do k=1,3
3073             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3074             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3075           enddo
3076 #endif
3077 *
3078 * Angular part
3079 *
3080           ecosa=2.0D0*fac3*fac1+fac4
3081           fac4=-3.0D0*fac4
3082           fac3=-6.0D0*fac3
3083           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3084           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3085           do k=1,3
3086             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3087             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3088           enddo
3089 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3090 cd   &          (dcosg(k),k=1,3)
3091           do k=1,3
3092             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3093           enddo
3094 c          do k=1,3
3095 c            ghalf=0.5D0*ggg(k)
3096 c            gelc(k,i)=gelc(k,i)+ghalf
3097 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3098 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3099 c            gelc(k,j)=gelc(k,j)+ghalf
3100 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3101 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3102 c          enddo
3103 cgrad          do k=i+1,j-1
3104 cgrad            do l=1,3
3105 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3106 cgrad            enddo
3107 cgrad          enddo
3108           do k=1,3
3109             gelc(k,i)=gelc(k,i)
3110      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3111      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3112             gelc(k,j)=gelc(k,j)
3113      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3114      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3115             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3116             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3117           enddo
3118           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3119      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3120      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3121 C
3122 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3123 C   energy of a peptide unit is assumed in the form of a second-order
3124 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3125 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3126 C   are computed for EVERY pair of non-contiguous peptide groups.
3127 C
3128           if (j.lt.nres-1) then
3129             j1=j+1
3130             j2=j-1
3131           else
3132             j1=j-1
3133             j2=j-2
3134           endif
3135           kkk=0
3136           do k=1,2
3137             do l=1,2
3138               kkk=kkk+1
3139               muij(kkk)=mu(k,i)*mu(l,j)
3140             enddo
3141           enddo
3142 cd         write (iout,*) 'EELEC: i',i,' j',j
3143 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3144 cd          write(iout,*) 'muij',muij
3145           ury=scalar(uy(1,i),erij)
3146           urz=scalar(uz(1,i),erij)
3147           vry=scalar(uy(1,j),erij)
3148           vrz=scalar(uz(1,j),erij)
3149           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3150           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3151           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3152           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3153           fac=dsqrt(-ael6i)*r3ij
3154           a22=a22*fac
3155           a23=a23*fac
3156           a32=a32*fac
3157           a33=a33*fac
3158 cd          write (iout,'(4i5,4f10.5)')
3159 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3160 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3161 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3162 cd     &      uy(:,j),uz(:,j)
3163 cd          write (iout,'(4f10.5)')
3164 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3165 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3166 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3167 cd           write (iout,'(9f10.5/)')
3168 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3169 C Derivatives of the elements of A in virtual-bond vectors
3170           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3171           do k=1,3
3172             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3173             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3174             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3175             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3176             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3177             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3178             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3179             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3180             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3181             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3182             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3183             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3184           enddo
3185 C Compute radial contributions to the gradient
3186           facr=-3.0d0*rrmij
3187           a22der=a22*facr
3188           a23der=a23*facr
3189           a32der=a32*facr
3190           a33der=a33*facr
3191           agg(1,1)=a22der*xj
3192           agg(2,1)=a22der*yj
3193           agg(3,1)=a22der*zj
3194           agg(1,2)=a23der*xj
3195           agg(2,2)=a23der*yj
3196           agg(3,2)=a23der*zj
3197           agg(1,3)=a32der*xj
3198           agg(2,3)=a32der*yj
3199           agg(3,3)=a32der*zj
3200           agg(1,4)=a33der*xj
3201           agg(2,4)=a33der*yj
3202           agg(3,4)=a33der*zj
3203 C Add the contributions coming from er
3204           fac3=-3.0d0*fac
3205           do k=1,3
3206             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3207             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3208             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3209             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3210           enddo
3211           do k=1,3
3212 C Derivatives in DC(i)
3213 cgrad            ghalf1=0.5d0*agg(k,1)
3214 cgrad            ghalf2=0.5d0*agg(k,2)
3215 cgrad            ghalf3=0.5d0*agg(k,3)
3216 cgrad            ghalf4=0.5d0*agg(k,4)
3217             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3218      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3219             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3220      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3221             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3222      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3223             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3224      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3225 C Derivatives in DC(i+1)
3226             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3227      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3228             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3229      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3230             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3231      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3232             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3233      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3234 C Derivatives in DC(j)
3235             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3236      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3237             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3238      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3239             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3240      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3241             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3242      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3243 C Derivatives in DC(j+1) or DC(nres-1)
3244             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3245      &      -3.0d0*vryg(k,3)*ury)
3246             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3247      &      -3.0d0*vrzg(k,3)*ury)
3248             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3249      &      -3.0d0*vryg(k,3)*urz)
3250             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3251      &      -3.0d0*vrzg(k,3)*urz)
3252 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3253 cgrad              do l=1,4
3254 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3255 cgrad              enddo
3256 cgrad            endif
3257           enddo
3258           acipa(1,1)=a22
3259           acipa(1,2)=a23
3260           acipa(2,1)=a32
3261           acipa(2,2)=a33
3262           a22=-a22
3263           a23=-a23
3264           do l=1,2
3265             do k=1,3
3266               agg(k,l)=-agg(k,l)
3267               aggi(k,l)=-aggi(k,l)
3268               aggi1(k,l)=-aggi1(k,l)
3269               aggj(k,l)=-aggj(k,l)
3270               aggj1(k,l)=-aggj1(k,l)
3271             enddo
3272           enddo
3273           if (j.lt.nres-1) then
3274             a22=-a22
3275             a32=-a32
3276             do l=1,3,2
3277               do k=1,3
3278                 agg(k,l)=-agg(k,l)
3279                 aggi(k,l)=-aggi(k,l)
3280                 aggi1(k,l)=-aggi1(k,l)
3281                 aggj(k,l)=-aggj(k,l)
3282                 aggj1(k,l)=-aggj1(k,l)
3283               enddo
3284             enddo
3285           else
3286             a22=-a22
3287             a23=-a23
3288             a32=-a32
3289             a33=-a33
3290             do l=1,4
3291               do k=1,3
3292                 agg(k,l)=-agg(k,l)
3293                 aggi(k,l)=-aggi(k,l)
3294                 aggi1(k,l)=-aggi1(k,l)
3295                 aggj(k,l)=-aggj(k,l)
3296                 aggj1(k,l)=-aggj1(k,l)
3297               enddo
3298             enddo
3299           endif
3300           ENDIF ! WCORR
3301           IF (wel_loc.gt.0.0d0) THEN
3302 C Contribution to the local-electrostatic energy coming from the i-j pair
3303           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3304      &     +a33*muij(4)
3305 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3306
3307           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3308      &            'eelloc',i,j,eel_loc_ij
3309 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3310
3311           eel_loc=eel_loc+eel_loc_ij
3312 C Partial derivatives in virtual-bond dihedral angles gamma
3313           if (i.gt.1)
3314      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3315      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3316      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3317           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3318      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3319      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3320 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3321           do l=1,3
3322             ggg(l)=agg(l,1)*muij(1)+
3323      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3324             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3325             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3326 cgrad            ghalf=0.5d0*ggg(l)
3327 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3328 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3329           enddo
3330 cgrad          do k=i+1,j2
3331 cgrad            do l=1,3
3332 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3333 cgrad            enddo
3334 cgrad          enddo
3335 C Remaining derivatives of eello
3336           do l=1,3
3337             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3338      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3339             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3340      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3341             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3342      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3343             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3344      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3345           enddo
3346           ENDIF
3347 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3348 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3349           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3350      &       .and. num_conti.le.maxconts) then
3351 c            write (iout,*) i,j," entered corr"
3352 C
3353 C Calculate the contact function. The ith column of the array JCONT will
3354 C contain the numbers of atoms that make contacts with the atom I (of numbers
3355 C greater than I). The arrays FACONT and GACONT will contain the values of
3356 C the contact function and its derivative.
3357 c           r0ij=1.02D0*rpp(iteli,itelj)
3358 c           r0ij=1.11D0*rpp(iteli,itelj)
3359             r0ij=2.20D0*rpp(iteli,itelj)
3360 c           r0ij=1.55D0*rpp(iteli,itelj)
3361             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3362             if (fcont.gt.0.0D0) then
3363               num_conti=num_conti+1
3364               if (num_conti.gt.maxconts) then
3365                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3366      &                         ' will skip next contacts for this conf.'
3367               else
3368                 jcont_hb(num_conti,i)=j
3369 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3370 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3371                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3372      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3373 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3374 C  terms.
3375                 d_cont(num_conti,i)=rij
3376 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3377 C     --- Electrostatic-interaction matrix ---
3378                 a_chuj(1,1,num_conti,i)=a22
3379                 a_chuj(1,2,num_conti,i)=a23
3380                 a_chuj(2,1,num_conti,i)=a32
3381                 a_chuj(2,2,num_conti,i)=a33
3382 C     --- Gradient of rij
3383                 do kkk=1,3
3384                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3385                 enddo
3386                 kkll=0
3387                 do k=1,2
3388                   do l=1,2
3389                     kkll=kkll+1
3390                     do m=1,3
3391                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3392                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3393                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3394                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3395                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3396                     enddo
3397                   enddo
3398                 enddo
3399                 ENDIF
3400                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3401 C Calculate contact energies
3402                 cosa4=4.0D0*cosa
3403                 wij=cosa-3.0D0*cosb*cosg
3404                 cosbg1=cosb+cosg
3405                 cosbg2=cosb-cosg
3406 c               fac3=dsqrt(-ael6i)/r0ij**3
3407                 fac3=dsqrt(-ael6i)*r3ij
3408 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3409                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3410                 if (ees0tmp.gt.0) then
3411                   ees0pij=dsqrt(ees0tmp)
3412                 else
3413                   ees0pij=0
3414                 endif
3415 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3416                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3417                 if (ees0tmp.gt.0) then
3418                   ees0mij=dsqrt(ees0tmp)
3419                 else
3420                   ees0mij=0
3421                 endif
3422 c               ees0mij=0.0D0
3423                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3424                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3425 C Diagnostics. Comment out or remove after debugging!
3426 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3427 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3428 c               ees0m(num_conti,i)=0.0D0
3429 C End diagnostics.
3430 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3431 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3432 C Angular derivatives of the contact function
3433                 ees0pij1=fac3/ees0pij
3434                 ees0mij1=fac3/ees0mij
3435                 fac3p=-3.0D0*fac3*rrmij
3436                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3437                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3438 c               ees0mij1=0.0D0
3439                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3440                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3441                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3442                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3443                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3444                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3445                 ecosap=ecosa1+ecosa2
3446                 ecosbp=ecosb1+ecosb2
3447                 ecosgp=ecosg1+ecosg2
3448                 ecosam=ecosa1-ecosa2
3449                 ecosbm=ecosb1-ecosb2
3450                 ecosgm=ecosg1-ecosg2
3451 C Diagnostics
3452 c               ecosap=ecosa1
3453 c               ecosbp=ecosb1
3454 c               ecosgp=ecosg1
3455 c               ecosam=0.0D0
3456 c               ecosbm=0.0D0
3457 c               ecosgm=0.0D0
3458 C End diagnostics
3459                 facont_hb(num_conti,i)=fcont
3460                 fprimcont=fprimcont/rij
3461 cd              facont_hb(num_conti,i)=1.0D0
3462 C Following line is for diagnostics.
3463 cd              fprimcont=0.0D0
3464                 do k=1,3
3465                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3466                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3467                 enddo
3468                 do k=1,3
3469                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3470                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3471                 enddo
3472                 gggp(1)=gggp(1)+ees0pijp*xj
3473                 gggp(2)=gggp(2)+ees0pijp*yj
3474                 gggp(3)=gggp(3)+ees0pijp*zj
3475                 gggm(1)=gggm(1)+ees0mijp*xj
3476                 gggm(2)=gggm(2)+ees0mijp*yj
3477                 gggm(3)=gggm(3)+ees0mijp*zj
3478 C Derivatives due to the contact function
3479                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3480                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3481                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3482                 do k=1,3
3483 c
3484 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3485 c          following the change of gradient-summation algorithm.
3486 c
3487 cgrad                  ghalfp=0.5D0*gggp(k)
3488 cgrad                  ghalfm=0.5D0*gggm(k)
3489                   gacontp_hb1(k,num_conti,i)=!ghalfp
3490      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3491      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3492                   gacontp_hb2(k,num_conti,i)=!ghalfp
3493      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3494      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3495                   gacontp_hb3(k,num_conti,i)=gggp(k)
3496                   gacontm_hb1(k,num_conti,i)=!ghalfm
3497      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3498      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3499                   gacontm_hb2(k,num_conti,i)=!ghalfm
3500      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3501      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3502                   gacontm_hb3(k,num_conti,i)=gggm(k)
3503                 enddo
3504 C Diagnostics. Comment out or remove after debugging!
3505 cdiag           do k=1,3
3506 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3507 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3508 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3509 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3510 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3511 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3512 cdiag           enddo
3513               ENDIF ! wcorr
3514               endif  ! num_conti.le.maxconts
3515             endif  ! fcont.gt.0
3516           endif    ! j.gt.i+1
3517           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3518             do k=1,4
3519               do l=1,3
3520                 ghalf=0.5d0*agg(l,k)
3521                 aggi(l,k)=aggi(l,k)+ghalf
3522                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3523                 aggj(l,k)=aggj(l,k)+ghalf
3524               enddo
3525             enddo
3526             if (j.eq.nres-1 .and. i.lt.j-2) then
3527               do k=1,4
3528                 do l=1,3
3529                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3530                 enddo
3531               enddo
3532             endif
3533           endif
3534 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3535       return
3536       end
3537 C-----------------------------------------------------------------------------
3538       subroutine eturn3(i,eello_turn3)
3539 C Third- and fourth-order contributions from turns
3540       implicit real*8 (a-h,o-z)
3541       include 'DIMENSIONS'
3542       include 'COMMON.IOUNITS'
3543       include 'COMMON.GEO'
3544       include 'COMMON.VAR'
3545       include 'COMMON.LOCAL'
3546       include 'COMMON.CHAIN'
3547       include 'COMMON.DERIV'
3548       include 'COMMON.INTERACT'
3549       include 'COMMON.CONTACTS'
3550       include 'COMMON.TORSION'
3551       include 'COMMON.VECTORS'
3552       include 'COMMON.FFIELD'
3553       include 'COMMON.CONTROL'
3554       dimension ggg(3)
3555       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3556      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3557      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3558       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3559      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3560       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3561      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3562      &    num_conti,j1,j2
3563       j=i+2
3564 c      write (iout,*) "eturn3",i,j,j1,j2
3565       a_temp(1,1)=a22
3566       a_temp(1,2)=a23
3567       a_temp(2,1)=a32
3568       a_temp(2,2)=a33
3569 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3570 C
3571 C               Third-order contributions
3572 C
3573 C                 (i+2)o----(i+3)
3574 C                      | |
3575 C                      | |
3576 C                 (i+1)o----i
3577 C
3578 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3579 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3580         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3581         call transpose2(auxmat(1,1),auxmat1(1,1))
3582         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3583         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3584         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3585      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3586 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3587 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3588 cd     &    ' eello_turn3_num',4*eello_turn3_num
3589 C Derivatives in gamma(i)
3590         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3591         call transpose2(auxmat2(1,1),auxmat3(1,1))
3592         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3593         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3594 C Derivatives in gamma(i+1)
3595         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3596         call transpose2(auxmat2(1,1),auxmat3(1,1))
3597         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3598         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3599      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3600 C Cartesian derivatives
3601         do l=1,3
3602 c            ghalf1=0.5d0*agg(l,1)
3603 c            ghalf2=0.5d0*agg(l,2)
3604 c            ghalf3=0.5d0*agg(l,3)
3605 c            ghalf4=0.5d0*agg(l,4)
3606           a_temp(1,1)=aggi(l,1)!+ghalf1
3607           a_temp(1,2)=aggi(l,2)!+ghalf2
3608           a_temp(2,1)=aggi(l,3)!+ghalf3
3609           a_temp(2,2)=aggi(l,4)!+ghalf4
3610           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3611           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3612      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3613           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3614           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3615           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3616           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3617           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3618           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3619      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3620           a_temp(1,1)=aggj(l,1)!+ghalf1
3621           a_temp(1,2)=aggj(l,2)!+ghalf2
3622           a_temp(2,1)=aggj(l,3)!+ghalf3
3623           a_temp(2,2)=aggj(l,4)!+ghalf4
3624           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3625           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3626      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3627           a_temp(1,1)=aggj1(l,1)
3628           a_temp(1,2)=aggj1(l,2)
3629           a_temp(2,1)=aggj1(l,3)
3630           a_temp(2,2)=aggj1(l,4)
3631           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3632           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3633      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3634         enddo
3635       return
3636       end
3637 C-------------------------------------------------------------------------------
3638       subroutine eturn4(i,eello_turn4)
3639 C Third- and fourth-order contributions from turns
3640       implicit real*8 (a-h,o-z)
3641       include 'DIMENSIONS'
3642       include 'COMMON.IOUNITS'
3643       include 'COMMON.GEO'
3644       include 'COMMON.VAR'
3645       include 'COMMON.LOCAL'
3646       include 'COMMON.CHAIN'
3647       include 'COMMON.DERIV'
3648       include 'COMMON.INTERACT'
3649       include 'COMMON.CONTACTS'
3650       include 'COMMON.TORSION'
3651       include 'COMMON.VECTORS'
3652       include 'COMMON.FFIELD'
3653       include 'COMMON.CONTROL'
3654       dimension ggg(3)
3655       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3656      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3657      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3658       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3659      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3660       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3661      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3662      &    num_conti,j1,j2
3663       j=i+3
3664 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3665 C
3666 C               Fourth-order contributions
3667 C
3668 C                 (i+3)o----(i+4)
3669 C                     /  |
3670 C               (i+2)o   |
3671 C                     \  |
3672 C                 (i+1)o----i
3673 C
3674 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3675 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3676 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3677         a_temp(1,1)=a22
3678         a_temp(1,2)=a23
3679         a_temp(2,1)=a32
3680         a_temp(2,2)=a33
3681         iti1=itortyp(itype(i+1))
3682         iti2=itortyp(itype(i+2))
3683         iti3=itortyp(itype(i+3))
3684 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3685         call transpose2(EUg(1,1,i+1),e1t(1,1))
3686         call transpose2(Eug(1,1,i+2),e2t(1,1))
3687         call transpose2(Eug(1,1,i+3),e3t(1,1))
3688         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3689         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3690         s1=scalar2(b1(1,iti2),auxvec(1))
3691         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3692         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3693         s2=scalar2(b1(1,iti1),auxvec(1))
3694         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3695         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3696         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3697         eello_turn4=eello_turn4-(s1+s2+s3)
3698         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3699      &      'eturn4',i,j,-(s1+s2+s3)
3700 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3701 cd     &    ' eello_turn4_num',8*eello_turn4_num
3702 C Derivatives in gamma(i)
3703         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3704         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3705         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3706         s1=scalar2(b1(1,iti2),auxvec(1))
3707         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3708         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3709         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3710 C Derivatives in gamma(i+1)
3711         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3712         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3713         s2=scalar2(b1(1,iti1),auxvec(1))
3714         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3715         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3716         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3717         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3718 C Derivatives in gamma(i+2)
3719         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3720         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3721         s1=scalar2(b1(1,iti2),auxvec(1))
3722         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3723         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3724         s2=scalar2(b1(1,iti1),auxvec(1))
3725         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3726         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3727         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3728         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3729 C Cartesian derivatives
3730 C Derivatives of this turn contributions in DC(i+2)
3731         if (j.lt.nres-1) then
3732           do l=1,3
3733             a_temp(1,1)=agg(l,1)
3734             a_temp(1,2)=agg(l,2)
3735             a_temp(2,1)=agg(l,3)
3736             a_temp(2,2)=agg(l,4)
3737             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3738             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3739             s1=scalar2(b1(1,iti2),auxvec(1))
3740             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3741             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3742             s2=scalar2(b1(1,iti1),auxvec(1))
3743             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3744             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3745             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3746             ggg(l)=-(s1+s2+s3)
3747             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3748           enddo
3749         endif
3750 C Remaining derivatives of this turn contribution
3751         do l=1,3
3752           a_temp(1,1)=aggi(l,1)
3753           a_temp(1,2)=aggi(l,2)
3754           a_temp(2,1)=aggi(l,3)
3755           a_temp(2,2)=aggi(l,4)
3756           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3757           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3758           s1=scalar2(b1(1,iti2),auxvec(1))
3759           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3760           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3761           s2=scalar2(b1(1,iti1),auxvec(1))
3762           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3763           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3764           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3765           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3766           a_temp(1,1)=aggi1(l,1)
3767           a_temp(1,2)=aggi1(l,2)
3768           a_temp(2,1)=aggi1(l,3)
3769           a_temp(2,2)=aggi1(l,4)
3770           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3771           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3772           s1=scalar2(b1(1,iti2),auxvec(1))
3773           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3774           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3775           s2=scalar2(b1(1,iti1),auxvec(1))
3776           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3777           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3778           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3779           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3780           a_temp(1,1)=aggj(l,1)
3781           a_temp(1,2)=aggj(l,2)
3782           a_temp(2,1)=aggj(l,3)
3783           a_temp(2,2)=aggj(l,4)
3784           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3785           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3786           s1=scalar2(b1(1,iti2),auxvec(1))
3787           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3788           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3789           s2=scalar2(b1(1,iti1),auxvec(1))
3790           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3791           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3792           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3793           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3794           a_temp(1,1)=aggj1(l,1)
3795           a_temp(1,2)=aggj1(l,2)
3796           a_temp(2,1)=aggj1(l,3)
3797           a_temp(2,2)=aggj1(l,4)
3798           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3799           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3800           s1=scalar2(b1(1,iti2),auxvec(1))
3801           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3802           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3803           s2=scalar2(b1(1,iti1),auxvec(1))
3804           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3805           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3806           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3807 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3808           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3809         enddo
3810       return
3811       end
3812 C-----------------------------------------------------------------------------
3813       subroutine vecpr(u,v,w)
3814       implicit real*8(a-h,o-z)
3815       dimension u(3),v(3),w(3)
3816       w(1)=u(2)*v(3)-u(3)*v(2)
3817       w(2)=-u(1)*v(3)+u(3)*v(1)
3818       w(3)=u(1)*v(2)-u(2)*v(1)
3819       return
3820       end
3821 C-----------------------------------------------------------------------------
3822       subroutine unormderiv(u,ugrad,unorm,ungrad)
3823 C This subroutine computes the derivatives of a normalized vector u, given
3824 C the derivatives computed without normalization conditions, ugrad. Returns
3825 C ungrad.
3826       implicit none
3827       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3828       double precision vec(3)
3829       double precision scalar
3830       integer i,j
3831 c      write (2,*) 'ugrad',ugrad
3832 c      write (2,*) 'u',u
3833       do i=1,3
3834         vec(i)=scalar(ugrad(1,i),u(1))
3835       enddo
3836 c      write (2,*) 'vec',vec
3837       do i=1,3
3838         do j=1,3
3839           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3840         enddo
3841       enddo
3842 c      write (2,*) 'ungrad',ungrad
3843       return
3844       end
3845 C-----------------------------------------------------------------------------
3846       subroutine escp_soft_sphere(evdw2,evdw2_14)
3847 C
3848 C This subroutine calculates the excluded-volume interaction energy between
3849 C peptide-group centers and side chains and its gradient in virtual-bond and
3850 C side-chain vectors.
3851 C
3852       implicit real*8 (a-h,o-z)
3853       include 'DIMENSIONS'
3854       include 'COMMON.GEO'
3855       include 'COMMON.VAR'
3856       include 'COMMON.LOCAL'
3857       include 'COMMON.CHAIN'
3858       include 'COMMON.DERIV'
3859       include 'COMMON.INTERACT'
3860       include 'COMMON.FFIELD'
3861       include 'COMMON.IOUNITS'
3862       include 'COMMON.CONTROL'
3863       dimension ggg(3)
3864       evdw2=0.0D0
3865       evdw2_14=0.0d0
3866       r0_scp=4.5d0
3867 cd    print '(a)','Enter ESCP'
3868 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3869       do i=iatscp_s,iatscp_e
3870         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3871         iteli=itel(i)
3872         xi=0.5D0*(c(1,i)+c(1,i+1))
3873         yi=0.5D0*(c(2,i)+c(2,i+1))
3874         zi=0.5D0*(c(3,i)+c(3,i+1))
3875
3876         do iint=1,nscp_gr(i)
3877
3878         do j=iscpstart(i,iint),iscpend(i,iint)
3879           if (itype(j).eq.ntyp1) cycle
3880           itypj=iabs(itype(j))
3881 C Uncomment following three lines for SC-p interactions
3882 c         xj=c(1,nres+j)-xi
3883 c         yj=c(2,nres+j)-yi
3884 c         zj=c(3,nres+j)-zi
3885 C Uncomment following three lines for Ca-p interactions
3886           xj=c(1,j)-xi
3887           yj=c(2,j)-yi
3888           zj=c(3,j)-zi
3889           rij=xj*xj+yj*yj+zj*zj
3890           r0ij=r0_scp
3891           r0ijsq=r0ij*r0ij
3892           if (rij.lt.r0ijsq) then
3893             evdwij=0.25d0*(rij-r0ijsq)**2
3894             fac=rij-r0ijsq
3895           else
3896             evdwij=0.0d0
3897             fac=0.0d0
3898           endif
3899           evdw2=evdw2+evdwij
3900 C
3901 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3902 C
3903           ggg(1)=xj*fac
3904           ggg(2)=yj*fac
3905           ggg(3)=zj*fac
3906 cgrad          if (j.lt.i) then
3907 cd          write (iout,*) 'j<i'
3908 C Uncomment following three lines for SC-p interactions
3909 c           do k=1,3
3910 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3911 c           enddo
3912 cgrad          else
3913 cd          write (iout,*) 'j>i'
3914 cgrad            do k=1,3
3915 cgrad              ggg(k)=-ggg(k)
3916 C Uncomment following line for SC-p interactions
3917 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3918 cgrad            enddo
3919 cgrad          endif
3920 cgrad          do k=1,3
3921 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3922 cgrad          enddo
3923 cgrad          kstart=min0(i+1,j)
3924 cgrad          kend=max0(i-1,j-1)
3925 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3926 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3927 cgrad          do k=kstart,kend
3928 cgrad            do l=1,3
3929 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3930 cgrad            enddo
3931 cgrad          enddo
3932           do k=1,3
3933             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3934             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3935           enddo
3936         enddo
3937
3938         enddo ! iint
3939       enddo ! i
3940       return
3941       end
3942 C-----------------------------------------------------------------------------
3943       subroutine escp(evdw2,evdw2_14)
3944 C
3945 C This subroutine calculates the excluded-volume interaction energy between
3946 C peptide-group centers and side chains and its gradient in virtual-bond and
3947 C side-chain vectors.
3948 C
3949       implicit real*8 (a-h,o-z)
3950       include 'DIMENSIONS'
3951       include 'COMMON.GEO'
3952       include 'COMMON.VAR'
3953       include 'COMMON.LOCAL'
3954       include 'COMMON.CHAIN'
3955       include 'COMMON.DERIV'
3956       include 'COMMON.INTERACT'
3957       include 'COMMON.FFIELD'
3958       include 'COMMON.IOUNITS'
3959       include 'COMMON.CONTROL'
3960       dimension ggg(3)
3961       evdw2=0.0D0
3962       evdw2_14=0.0d0
3963 cd    print '(a)','Enter ESCP'
3964 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3965       do i=iatscp_s,iatscp_e
3966         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3967         iteli=itel(i)
3968         xi=0.5D0*(c(1,i)+c(1,i+1))
3969         yi=0.5D0*(c(2,i)+c(2,i+1))
3970         zi=0.5D0*(c(3,i)+c(3,i+1))
3971
3972         do iint=1,nscp_gr(i)
3973
3974         do j=iscpstart(i,iint),iscpend(i,iint)
3975           itypj=iabs(itype(j))
3976           if (itypj.eq.ntyp1) cycle
3977 C Uncomment following three lines for SC-p interactions
3978 c         xj=c(1,nres+j)-xi
3979 c         yj=c(2,nres+j)-yi
3980 c         zj=c(3,nres+j)-zi
3981 C Uncomment following three lines for Ca-p interactions
3982           xj=c(1,j)-xi
3983           yj=c(2,j)-yi
3984           zj=c(3,j)-zi
3985           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3986           fac=rrij**expon2
3987           e1=fac*fac*aad(itypj,iteli)
3988           e2=fac*bad(itypj,iteli)
3989           if (iabs(j-i) .le. 2) then
3990             e1=scal14*e1
3991             e2=scal14*e2
3992             evdw2_14=evdw2_14+e1+e2
3993           endif
3994           evdwij=e1+e2
3995           evdw2=evdw2+evdwij
3996           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3997      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3998      &       bad(itypj,iteli)
3999 C
4000 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4001 C
4002           fac=-(evdwij+e1)*rrij
4003           ggg(1)=xj*fac
4004           ggg(2)=yj*fac
4005           ggg(3)=zj*fac
4006 cgrad          if (j.lt.i) then
4007 cd          write (iout,*) 'j<i'
4008 C Uncomment following three lines for SC-p interactions
4009 c           do k=1,3
4010 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4011 c           enddo
4012 cgrad          else
4013 cd          write (iout,*) 'j>i'
4014 cgrad            do k=1,3
4015 cgrad              ggg(k)=-ggg(k)
4016 C Uncomment following line for SC-p interactions
4017 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4018 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4019 cgrad            enddo
4020 cgrad          endif
4021 cgrad          do k=1,3
4022 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4023 cgrad          enddo
4024 cgrad          kstart=min0(i+1,j)
4025 cgrad          kend=max0(i-1,j-1)
4026 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4027 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4028 cgrad          do k=kstart,kend
4029 cgrad            do l=1,3
4030 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4031 cgrad            enddo
4032 cgrad          enddo
4033           do k=1,3
4034             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4035             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4036           enddo
4037         enddo
4038
4039         enddo ! iint
4040       enddo ! i
4041       do i=1,nct
4042         do j=1,3
4043           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4044           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4045           gradx_scp(j,i)=expon*gradx_scp(j,i)
4046         enddo
4047       enddo
4048 C******************************************************************************
4049 C
4050 C                              N O T E !!!
4051 C
4052 C To save time the factor EXPON has been extracted from ALL components
4053 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4054 C use!
4055 C
4056 C******************************************************************************
4057       return
4058       end
4059 C--------------------------------------------------------------------------
4060       subroutine edis(ehpb)
4061 C
4062 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4063 C
4064       implicit real*8 (a-h,o-z)
4065       include 'DIMENSIONS'
4066       include 'COMMON.SBRIDGE'
4067       include 'COMMON.CHAIN'
4068       include 'COMMON.DERIV'
4069       include 'COMMON.VAR'
4070       include 'COMMON.INTERACT'
4071       include 'COMMON.IOUNITS'
4072       dimension ggg(3)
4073       ehpb=0.0D0
4074 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4075 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4076       if (link_end.eq.0) return
4077       do i=link_start,link_end
4078 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4079 C CA-CA distance used in regularization of structure.
4080         ii=ihpb(i)
4081         jj=jhpb(i)
4082 C iii and jjj point to the residues for which the distance is assigned.
4083         if (ii.gt.nres) then
4084           iii=ii-nres
4085           jjj=jj-nres
4086         else
4087           iii=ii
4088           jjj=jj
4089         endif
4090 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4091 c     &    dhpb(i),dhpb1(i),forcon(i)
4092 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4093 C    distance and angle dependent SS bond potential.
4094 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4095 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4096         if (.not.dyn_ss .and. i.le.nss) then
4097 C 15/02/13 CC dynamic SSbond - additional check
4098          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4099      & iabs(itype(jjj)).eq.1) then
4100           call ssbond_ene(iii,jjj,eij)
4101           ehpb=ehpb+2*eij
4102          endif
4103 cd          write (iout,*) "eij",eij
4104         else
4105 C Calculate the distance between the two points and its difference from the
4106 C target distance.
4107           dd=dist(ii,jj)
4108             rdis=dd-dhpb(i)
4109 C Get the force constant corresponding to this distance.
4110             waga=forcon(i)
4111 C Calculate the contribution to energy.
4112             ehpb=ehpb+waga*rdis*rdis
4113 C
4114 C Evaluate gradient.
4115 C
4116             fac=waga*rdis/dd
4117 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4118 cd   &   ' waga=',waga,' fac=',fac
4119             do j=1,3
4120               ggg(j)=fac*(c(j,jj)-c(j,ii))
4121             enddo
4122 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4123 C If this is a SC-SC distance, we need to calculate the contributions to the
4124 C Cartesian gradient in the SC vectors (ghpbx).
4125           if (iii.lt.ii) then
4126           do j=1,3
4127             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4128             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4129           enddo
4130           endif
4131 cgrad        do j=iii,jjj-1
4132 cgrad          do k=1,3
4133 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4134 cgrad          enddo
4135 cgrad        enddo
4136           do k=1,3
4137             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4138             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4139           enddo
4140         endif
4141       enddo
4142       ehpb=0.5D0*ehpb
4143       return
4144       end
4145 C--------------------------------------------------------------------------
4146       subroutine ssbond_ene(i,j,eij)
4147 C
4148 C Calculate the distance and angle dependent SS-bond potential energy
4149 C using a free-energy function derived based on RHF/6-31G** ab initio
4150 C calculations of diethyl disulfide.
4151 C
4152 C A. Liwo and U. Kozlowska, 11/24/03
4153 C
4154       implicit real*8 (a-h,o-z)
4155       include 'DIMENSIONS'
4156       include 'COMMON.SBRIDGE'
4157       include 'COMMON.CHAIN'
4158       include 'COMMON.DERIV'
4159       include 'COMMON.LOCAL'
4160       include 'COMMON.INTERACT'
4161       include 'COMMON.VAR'
4162       include 'COMMON.IOUNITS'
4163       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4164       itypi=iabs(itype(i))
4165       xi=c(1,nres+i)
4166       yi=c(2,nres+i)
4167       zi=c(3,nres+i)
4168       dxi=dc_norm(1,nres+i)
4169       dyi=dc_norm(2,nres+i)
4170       dzi=dc_norm(3,nres+i)
4171 c      dsci_inv=dsc_inv(itypi)
4172       dsci_inv=vbld_inv(nres+i)
4173       itypj=iabs(itype(j))
4174 c      dscj_inv=dsc_inv(itypj)
4175       dscj_inv=vbld_inv(nres+j)
4176       xj=c(1,nres+j)-xi
4177       yj=c(2,nres+j)-yi
4178       zj=c(3,nres+j)-zi
4179       dxj=dc_norm(1,nres+j)
4180       dyj=dc_norm(2,nres+j)
4181       dzj=dc_norm(3,nres+j)
4182       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4183       rij=dsqrt(rrij)
4184       erij(1)=xj*rij
4185       erij(2)=yj*rij
4186       erij(3)=zj*rij
4187       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4188       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4189       om12=dxi*dxj+dyi*dyj+dzi*dzj
4190       do k=1,3
4191         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4192         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4193       enddo
4194       rij=1.0d0/rij
4195       deltad=rij-d0cm
4196       deltat1=1.0d0-om1
4197       deltat2=1.0d0+om2
4198       deltat12=om2-om1+2.0d0
4199       cosphi=om12-om1*om2
4200       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4201      &  +akct*deltad*deltat12
4202      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4203 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4204 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4205 c     &  " deltat12",deltat12," eij",eij
4206       ed=2*akcm*deltad+akct*deltat12
4207       pom1=akct*deltad
4208       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4209       eom1=-2*akth*deltat1-pom1-om2*pom2
4210       eom2= 2*akth*deltat2+pom1-om1*pom2
4211       eom12=pom2
4212       do k=1,3
4213         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4214         ghpbx(k,i)=ghpbx(k,i)-ggk
4215      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4216      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4217         ghpbx(k,j)=ghpbx(k,j)+ggk
4218      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4219      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4220         ghpbc(k,i)=ghpbc(k,i)-ggk
4221         ghpbc(k,j)=ghpbc(k,j)+ggk
4222       enddo
4223 C
4224 C Calculate the components of the gradient in DC and X
4225 C
4226 cgrad      do k=i,j-1
4227 cgrad        do l=1,3
4228 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4229 cgrad        enddo
4230 cgrad      enddo
4231       return
4232       end
4233 C--------------------------------------------------------------------------
4234       subroutine ebond(estr)
4235 c
4236 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4237 c
4238       implicit real*8 (a-h,o-z)
4239       include 'DIMENSIONS'
4240       include 'COMMON.LOCAL'
4241       include 'COMMON.GEO'
4242       include 'COMMON.INTERACT'
4243       include 'COMMON.DERIV'
4244       include 'COMMON.VAR'
4245       include 'COMMON.CHAIN'
4246       include 'COMMON.IOUNITS'
4247       include 'COMMON.NAMES'
4248       include 'COMMON.FFIELD'
4249       include 'COMMON.CONTROL'
4250       include 'COMMON.SETUP'
4251       double precision u(3),ud(3)
4252       estr=0.0d0
4253       estr1=0.0d0
4254       do i=ibondp_start,ibondp_end
4255         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4256           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4257           do j=1,3
4258           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4259      &      *dc(j,i-1)/vbld(i)
4260           enddo
4261           if (energy_dec) write(iout,*)
4262      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4263         else
4264         diff = vbld(i)-vbldp0
4265         if (energy_dec) write (iout,*)
4266      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4267         estr=estr+diff*diff
4268         do j=1,3
4269           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4270         enddo
4271 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4272         endif
4273       enddo
4274       estr=0.5d0*AKP*estr+estr1
4275 c
4276 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4277 c
4278       do i=ibond_start,ibond_end
4279         iti=iabs(itype(i))
4280         if (iti.ne.10 .and. iti.ne.ntyp1) then
4281           nbi=nbondterm(iti)
4282           if (nbi.eq.1) then
4283             diff=vbld(i+nres)-vbldsc0(1,iti)
4284             if (energy_dec) write (iout,*)
4285      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4286      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4287             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4288             do j=1,3
4289               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4290             enddo
4291           else
4292             do j=1,nbi
4293               diff=vbld(i+nres)-vbldsc0(j,iti)
4294               ud(j)=aksc(j,iti)*diff
4295               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4296             enddo
4297             uprod=u(1)
4298             do j=2,nbi
4299               uprod=uprod*u(j)
4300             enddo
4301             usum=0.0d0
4302             usumsqder=0.0d0
4303             do j=1,nbi
4304               uprod1=1.0d0
4305               uprod2=1.0d0
4306               do k=1,nbi
4307                 if (k.ne.j) then
4308                   uprod1=uprod1*u(k)
4309                   uprod2=uprod2*u(k)*u(k)
4310                 endif
4311               enddo
4312               usum=usum+uprod1
4313               usumsqder=usumsqder+ud(j)*uprod2
4314             enddo
4315             estr=estr+uprod/usum
4316             do j=1,3
4317              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4318             enddo
4319           endif
4320         endif
4321       enddo
4322       return
4323       end
4324 #ifdef CRYST_THETA
4325 C--------------------------------------------------------------------------
4326       subroutine ebend(etheta)
4327 C
4328 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4329 C angles gamma and its derivatives in consecutive thetas and gammas.
4330 C
4331       implicit real*8 (a-h,o-z)
4332       include 'DIMENSIONS'
4333       include 'COMMON.LOCAL'
4334       include 'COMMON.GEO'
4335       include 'COMMON.INTERACT'
4336       include 'COMMON.DERIV'
4337       include 'COMMON.VAR'
4338       include 'COMMON.CHAIN'
4339       include 'COMMON.IOUNITS'
4340       include 'COMMON.NAMES'
4341       include 'COMMON.FFIELD'
4342       include 'COMMON.CONTROL'
4343       common /calcthet/ term1,term2,termm,diffak,ratak,
4344      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4345      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4346       double precision y(2),z(2)
4347       delta=0.02d0*pi
4348 c      time11=dexp(-2*time)
4349 c      time12=1.0d0
4350       etheta=0.0D0
4351 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4352       do i=ithet_start,ithet_end
4353         if (itype(i-1).eq.ntyp1) cycle
4354 C Zero the energy function and its derivative at 0 or pi.
4355         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4356         it=itype(i-1)
4357         ichir1=isign(1,itype(i-2))
4358         ichir2=isign(1,itype(i))
4359          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4360          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4361          if (itype(i-1).eq.10) then
4362           itype1=isign(10,itype(i-2))
4363           ichir11=isign(1,itype(i-2))
4364           ichir12=isign(1,itype(i-2))
4365           itype2=isign(10,itype(i))
4366           ichir21=isign(1,itype(i))
4367           ichir22=isign(1,itype(i))
4368          endif
4369
4370         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4371 #ifdef OSF
4372           phii=phi(i)
4373           if (phii.ne.phii) phii=150.0
4374 #else
4375           phii=phi(i)
4376 #endif
4377           y(1)=dcos(phii)
4378           y(2)=dsin(phii)
4379         else
4380           y(1)=0.0D0
4381           y(2)=0.0D0
4382         endif
4383         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4384 #ifdef OSF
4385           phii1=phi(i+1)
4386           if (phii1.ne.phii1) phii1=150.0
4387           phii1=pinorm(phii1)
4388           z(1)=cos(phii1)
4389 #else
4390           phii1=phi(i+1)
4391           z(1)=dcos(phii1)
4392 #endif
4393           z(2)=dsin(phii1)
4394         else
4395           z(1)=0.0D0
4396           z(2)=0.0D0
4397         endif
4398 C Calculate the "mean" value of theta from the part of the distribution
4399 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4400 C In following comments this theta will be referred to as t_c.
4401         thet_pred_mean=0.0d0
4402         do k=1,2
4403             athetk=athet(k,it,ichir1,ichir2)
4404             bthetk=bthet(k,it,ichir1,ichir2)
4405           if (it.eq.10) then
4406              athetk=athet(k,itype1,ichir11,ichir12)
4407              bthetk=bthet(k,itype2,ichir21,ichir22)
4408           endif
4409          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4410         enddo
4411         dthett=thet_pred_mean*ssd
4412         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4413 C Derivatives of the "mean" values in gamma1 and gamma2.
4414         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4415      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4416          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4417      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4418          if (it.eq.10) then
4419       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4420      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4421         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4422      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4423          endif
4424         if (theta(i).gt.pi-delta) then
4425           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4426      &         E_tc0)
4427           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4428           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4429           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4430      &        E_theta)
4431           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4432      &        E_tc)
4433         else if (theta(i).lt.delta) then
4434           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4435           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4436           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4437      &        E_theta)
4438           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4439           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4440      &        E_tc)
4441         else
4442           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4443      &        E_theta,E_tc)
4444         endif
4445         etheta=etheta+ethetai
4446         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4447      &      'ebend',i,ethetai
4448         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4449         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4450         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4451       enddo
4452 C Ufff.... We've done all this!!!
4453       return
4454       end
4455 C---------------------------------------------------------------------------
4456       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4457      &     E_tc)
4458       implicit real*8 (a-h,o-z)
4459       include 'DIMENSIONS'
4460       include 'COMMON.LOCAL'
4461       include 'COMMON.IOUNITS'
4462       common /calcthet/ term1,term2,termm,diffak,ratak,
4463      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4464      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4465 C Calculate the contributions to both Gaussian lobes.
4466 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4467 C The "polynomial part" of the "standard deviation" of this part of
4468 C the distribution.
4469         sig=polthet(3,it)
4470         do j=2,0,-1
4471           sig=sig*thet_pred_mean+polthet(j,it)
4472         enddo
4473 C Derivative of the "interior part" of the "standard deviation of the"
4474 C gamma-dependent Gaussian lobe in t_c.
4475         sigtc=3*polthet(3,it)
4476         do j=2,1,-1
4477           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4478         enddo
4479         sigtc=sig*sigtc
4480 C Set the parameters of both Gaussian lobes of the distribution.
4481 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4482         fac=sig*sig+sigc0(it)
4483         sigcsq=fac+fac
4484         sigc=1.0D0/sigcsq
4485 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4486         sigsqtc=-4.0D0*sigcsq*sigtc
4487 c       print *,i,sig,sigtc,sigsqtc
4488 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4489         sigtc=-sigtc/(fac*fac)
4490 C Following variable is sigma(t_c)**(-2)
4491         sigcsq=sigcsq*sigcsq
4492         sig0i=sig0(it)
4493         sig0inv=1.0D0/sig0i**2
4494         delthec=thetai-thet_pred_mean
4495         delthe0=thetai-theta0i
4496         term1=-0.5D0*sigcsq*delthec*delthec
4497         term2=-0.5D0*sig0inv*delthe0*delthe0
4498 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4499 C NaNs in taking the logarithm. We extract the largest exponent which is added
4500 C to the energy (this being the log of the distribution) at the end of energy
4501 C term evaluation for this virtual-bond angle.
4502         if (term1.gt.term2) then
4503           termm=term1
4504           term2=dexp(term2-termm)
4505           term1=1.0d0
4506         else
4507           termm=term2
4508           term1=dexp(term1-termm)
4509           term2=1.0d0
4510         endif
4511 C The ratio between the gamma-independent and gamma-dependent lobes of
4512 C the distribution is a Gaussian function of thet_pred_mean too.
4513         diffak=gthet(2,it)-thet_pred_mean
4514         ratak=diffak/gthet(3,it)**2
4515         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4516 C Let's differentiate it in thet_pred_mean NOW.
4517         aktc=ak*ratak
4518 C Now put together the distribution terms to make complete distribution.
4519         termexp=term1+ak*term2
4520         termpre=sigc+ak*sig0i
4521 C Contribution of the bending energy from this theta is just the -log of
4522 C the sum of the contributions from the two lobes and the pre-exponential
4523 C factor. Simple enough, isn't it?
4524         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4525 C NOW the derivatives!!!
4526 C 6/6/97 Take into account the deformation.
4527         E_theta=(delthec*sigcsq*term1
4528      &       +ak*delthe0*sig0inv*term2)/termexp
4529         E_tc=((sigtc+aktc*sig0i)/termpre
4530      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4531      &       aktc*term2)/termexp)
4532       return
4533       end
4534 c-----------------------------------------------------------------------------
4535       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4536       implicit real*8 (a-h,o-z)
4537       include 'DIMENSIONS'
4538       include 'COMMON.LOCAL'
4539       include 'COMMON.IOUNITS'
4540       common /calcthet/ term1,term2,termm,diffak,ratak,
4541      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4542      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4543       delthec=thetai-thet_pred_mean
4544       delthe0=thetai-theta0i
4545 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4546       t3 = thetai-thet_pred_mean
4547       t6 = t3**2
4548       t9 = term1
4549       t12 = t3*sigcsq
4550       t14 = t12+t6*sigsqtc
4551       t16 = 1.0d0
4552       t21 = thetai-theta0i
4553       t23 = t21**2
4554       t26 = term2
4555       t27 = t21*t26
4556       t32 = termexp
4557       t40 = t32**2
4558       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4559      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4560      & *(-t12*t9-ak*sig0inv*t27)
4561       return
4562       end
4563 #else
4564 C--------------------------------------------------------------------------
4565       subroutine ebend(etheta)
4566 C
4567 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4568 C angles gamma and its derivatives in consecutive thetas and gammas.
4569 C ab initio-derived potentials from
4570 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4571 C
4572       implicit real*8 (a-h,o-z)
4573       include 'DIMENSIONS'
4574       include 'COMMON.LOCAL'
4575       include 'COMMON.GEO'
4576       include 'COMMON.INTERACT'
4577       include 'COMMON.DERIV'
4578       include 'COMMON.VAR'
4579       include 'COMMON.CHAIN'
4580       include 'COMMON.IOUNITS'
4581       include 'COMMON.NAMES'
4582       include 'COMMON.FFIELD'
4583       include 'COMMON.CONTROL'
4584       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4585      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4586      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4587      & sinph1ph2(maxdouble,maxdouble)
4588       logical lprn /.false./, lprn1 /.false./
4589       etheta=0.0D0
4590       do i=ithet_start,ithet_end
4591         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4592      &(itype(i).eq.ntyp1)) cycle
4593 C        print *,i,theta(i)
4594         if (iabs(itype(i+1)).eq.20) iblock=2
4595         if (iabs(itype(i+1)).ne.20) iblock=1
4596         dethetai=0.0d0
4597         dephii=0.0d0
4598         dephii1=0.0d0
4599         theti2=0.5d0*theta(i)
4600         ityp2=ithetyp((itype(i-1)))
4601         do k=1,nntheterm
4602           coskt(k)=dcos(k*theti2)
4603           sinkt(k)=dsin(k*theti2)
4604         enddo
4605 C        print *,ethetai
4606
4607         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4608 #ifdef OSF
4609           phii=phi(i)
4610           if (phii.ne.phii) phii=150.0
4611 #else
4612           phii=phi(i)
4613 #endif
4614           ityp1=ithetyp((itype(i-2)))
4615 C propagation of chirality for glycine type
4616           do k=1,nsingle
4617             cosph1(k)=dcos(k*phii)
4618             sinph1(k)=dsin(k*phii)
4619           enddo
4620         else
4621           phii=0.0d0
4622           do k=1,nsingle
4623           ityp1=ithetyp((itype(i-2)))
4624             cosph1(k)=0.0d0
4625             sinph1(k)=0.0d0
4626           enddo
4627         endif
4628         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4629 #ifdef OSF
4630           phii1=phi(i+1)
4631           if (phii1.ne.phii1) phii1=150.0
4632           phii1=pinorm(phii1)
4633 #else
4634           phii1=phi(i+1)
4635 #endif
4636           ityp3=ithetyp((itype(i)))
4637           do k=1,nsingle
4638             cosph2(k)=dcos(k*phii1)
4639             sinph2(k)=dsin(k*phii1)
4640           enddo
4641         else
4642           phii1=0.0d0
4643           ityp3=ithetyp((itype(i)))
4644           do k=1,nsingle
4645             cosph2(k)=0.0d0
4646             sinph2(k)=0.0d0
4647           enddo
4648         endif
4649         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4650         do k=1,ndouble
4651           do l=1,k-1
4652             ccl=cosph1(l)*cosph2(k-l)
4653             ssl=sinph1(l)*sinph2(k-l)
4654             scl=sinph1(l)*cosph2(k-l)
4655             csl=cosph1(l)*sinph2(k-l)
4656             cosph1ph2(l,k)=ccl-ssl
4657             cosph1ph2(k,l)=ccl+ssl
4658             sinph1ph2(l,k)=scl+csl
4659             sinph1ph2(k,l)=scl-csl
4660           enddo
4661         enddo
4662         if (lprn) then
4663         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4664      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4665         write (iout,*) "coskt and sinkt"
4666         do k=1,nntheterm
4667           write (iout,*) k,coskt(k),sinkt(k)
4668         enddo
4669         endif
4670         do k=1,ntheterm
4671           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4672           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4673      &      *coskt(k)
4674           if (lprn)
4675      &    write (iout,*) "k",k,"
4676      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4677      &     " ethetai",ethetai
4678         enddo
4679         if (lprn) then
4680         write (iout,*) "cosph and sinph"
4681         do k=1,nsingle
4682           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4683         enddo
4684         write (iout,*) "cosph1ph2 and sinph2ph2"
4685         do k=2,ndouble
4686           do l=1,k-1
4687             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4688      &         sinph1ph2(l,k),sinph1ph2(k,l)
4689           enddo
4690         enddo
4691         write(iout,*) "ethetai",ethetai
4692         endif
4693 C       print *,ethetai
4694         do m=1,ntheterm2
4695           do k=1,nsingle
4696             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4697      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4698      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4699      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4700             ethetai=ethetai+sinkt(m)*aux
4701             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4702             dephii=dephii+k*sinkt(m)*(
4703      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4704      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4705             dephii1=dephii1+k*sinkt(m)*(
4706      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4707      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4708             if (lprn)
4709      &      write (iout,*) "m",m," k",k," bbthet",
4710      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4711      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4712      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4713      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4714 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4715           enddo
4716         enddo
4717 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4718 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4719 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4720 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4721         if (lprn)
4722      &  write(iout,*) "ethetai",ethetai
4723 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4724         do m=1,ntheterm3
4725           do k=2,ndouble
4726             do l=1,k-1
4727               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4728      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4729      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4730      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4731               ethetai=ethetai+sinkt(m)*aux
4732               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4733               dephii=dephii+l*sinkt(m)*(
4734      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4735      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4736      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4737      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4738               dephii1=dephii1+(k-l)*sinkt(m)*(
4739      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4740      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4741      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4742      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4743               if (lprn) then
4744               write (iout,*) "m",m," k",k," l",l," ffthet",
4745      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4746      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4747      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4748      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4749      &            " ethetai",ethetai
4750               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4751      &            cosph1ph2(k,l)*sinkt(m),
4752      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4753               endif
4754             enddo
4755           enddo
4756         enddo
4757 10      continue
4758 c        lprn1=.true.
4759 C        print *,ethetai
4760         if (lprn1)
4761      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4762      &   i,theta(i)*rad2deg,phii*rad2deg,
4763      &   phii1*rad2deg,ethetai
4764 c        lprn1=.false.
4765         etheta=etheta+ethetai
4766         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4767         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4768         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4769       enddo
4770       return
4771       end
4772 #endif
4773 #ifdef CRYST_SC
4774 c-----------------------------------------------------------------------------
4775       subroutine esc(escloc)
4776 C Calculate the local energy of a side chain and its derivatives in the
4777 C corresponding virtual-bond valence angles THETA and the spherical angles
4778 C ALPHA and OMEGA.
4779       implicit real*8 (a-h,o-z)
4780       include 'DIMENSIONS'
4781       include 'COMMON.GEO'
4782       include 'COMMON.LOCAL'
4783       include 'COMMON.VAR'
4784       include 'COMMON.INTERACT'
4785       include 'COMMON.DERIV'
4786       include 'COMMON.CHAIN'
4787       include 'COMMON.IOUNITS'
4788       include 'COMMON.NAMES'
4789       include 'COMMON.FFIELD'
4790       include 'COMMON.CONTROL'
4791       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4792      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4793       common /sccalc/ time11,time12,time112,theti,it,nlobit
4794       delta=0.02d0*pi
4795       escloc=0.0D0
4796 c     write (iout,'(a)') 'ESC'
4797       do i=loc_start,loc_end
4798         it=itype(i)
4799         if (it.eq.ntyp1) cycle
4800         if (it.eq.10) goto 1
4801         nlobit=nlob(iabs(it))
4802 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4803 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4804         theti=theta(i+1)-pipol
4805         x(1)=dtan(theti)
4806         x(2)=alph(i)
4807         x(3)=omeg(i)
4808
4809         if (x(2).gt.pi-delta) then
4810           xtemp(1)=x(1)
4811           xtemp(2)=pi-delta
4812           xtemp(3)=x(3)
4813           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4814           xtemp(2)=pi
4815           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4816           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4817      &        escloci,dersc(2))
4818           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4819      &        ddersc0(1),dersc(1))
4820           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4821      &        ddersc0(3),dersc(3))
4822           xtemp(2)=pi-delta
4823           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4824           xtemp(2)=pi
4825           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4826           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4827      &            dersc0(2),esclocbi,dersc02)
4828           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4829      &            dersc12,dersc01)
4830           call splinthet(x(2),0.5d0*delta,ss,ssd)
4831           dersc0(1)=dersc01
4832           dersc0(2)=dersc02
4833           dersc0(3)=0.0d0
4834           do k=1,3
4835             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4836           enddo
4837           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4838 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4839 c    &             esclocbi,ss,ssd
4840           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4841 c         escloci=esclocbi
4842 c         write (iout,*) escloci
4843         else if (x(2).lt.delta) then
4844           xtemp(1)=x(1)
4845           xtemp(2)=delta
4846           xtemp(3)=x(3)
4847           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4848           xtemp(2)=0.0d0
4849           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4850           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4851      &        escloci,dersc(2))
4852           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4853      &        ddersc0(1),dersc(1))
4854           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4855      &        ddersc0(3),dersc(3))
4856           xtemp(2)=delta
4857           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4858           xtemp(2)=0.0d0
4859           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4860           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4861      &            dersc0(2),esclocbi,dersc02)
4862           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4863      &            dersc12,dersc01)
4864           dersc0(1)=dersc01
4865           dersc0(2)=dersc02
4866           dersc0(3)=0.0d0
4867           call splinthet(x(2),0.5d0*delta,ss,ssd)
4868           do k=1,3
4869             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4870           enddo
4871           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4872 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4873 c    &             esclocbi,ss,ssd
4874           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4875 c         write (iout,*) escloci
4876         else
4877           call enesc(x,escloci,dersc,ddummy,.false.)
4878         endif
4879
4880         escloc=escloc+escloci
4881         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4882      &     'escloc',i,escloci
4883 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4884
4885         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4886      &   wscloc*dersc(1)
4887         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4888         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4889     1   continue
4890       enddo
4891       return
4892       end
4893 C---------------------------------------------------------------------------
4894       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4895       implicit real*8 (a-h,o-z)
4896       include 'DIMENSIONS'
4897       include 'COMMON.GEO'
4898       include 'COMMON.LOCAL'
4899       include 'COMMON.IOUNITS'
4900       common /sccalc/ time11,time12,time112,theti,it,nlobit
4901       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4902       double precision contr(maxlob,-1:1)
4903       logical mixed
4904 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4905         escloc_i=0.0D0
4906         do j=1,3
4907           dersc(j)=0.0D0
4908           if (mixed) ddersc(j)=0.0d0
4909         enddo
4910         x3=x(3)
4911
4912 C Because of periodicity of the dependence of the SC energy in omega we have
4913 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4914 C To avoid underflows, first compute & store the exponents.
4915
4916         do iii=-1,1
4917
4918           x(3)=x3+iii*dwapi
4919
4920           do j=1,nlobit
4921             do k=1,3
4922               z(k)=x(k)-censc(k,j,it)
4923             enddo
4924             do k=1,3
4925               Axk=0.0D0
4926               do l=1,3
4927                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4928               enddo
4929               Ax(k,j,iii)=Axk
4930             enddo
4931             expfac=0.0D0
4932             do k=1,3
4933               expfac=expfac+Ax(k,j,iii)*z(k)
4934             enddo
4935             contr(j,iii)=expfac
4936           enddo ! j
4937
4938         enddo ! iii
4939
4940         x(3)=x3
4941 C As in the case of ebend, we want to avoid underflows in exponentiation and
4942 C subsequent NaNs and INFs in energy calculation.
4943 C Find the largest exponent
4944         emin=contr(1,-1)
4945         do iii=-1,1
4946           do j=1,nlobit
4947             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4948           enddo
4949         enddo
4950         emin=0.5D0*emin
4951 cd      print *,'it=',it,' emin=',emin
4952
4953 C Compute the contribution to SC energy and derivatives
4954         do iii=-1,1
4955
4956           do j=1,nlobit
4957 #ifdef OSF
4958             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4959             if(adexp.ne.adexp) adexp=1.0
4960             expfac=dexp(adexp)
4961 #else
4962             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4963 #endif
4964 cd          print *,'j=',j,' expfac=',expfac
4965             escloc_i=escloc_i+expfac
4966             do k=1,3
4967               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4968             enddo
4969             if (mixed) then
4970               do k=1,3,2
4971                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4972      &            +gaussc(k,2,j,it))*expfac
4973               enddo
4974             endif
4975           enddo
4976
4977         enddo ! iii
4978
4979         dersc(1)=dersc(1)/cos(theti)**2
4980         ddersc(1)=ddersc(1)/cos(theti)**2
4981         ddersc(3)=ddersc(3)
4982
4983         escloci=-(dlog(escloc_i)-emin)
4984         do j=1,3
4985           dersc(j)=dersc(j)/escloc_i
4986         enddo
4987         if (mixed) then
4988           do j=1,3,2
4989             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4990           enddo
4991         endif
4992       return
4993       end
4994 C------------------------------------------------------------------------------
4995       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4996       implicit real*8 (a-h,o-z)
4997       include 'DIMENSIONS'
4998       include 'COMMON.GEO'
4999       include 'COMMON.LOCAL'
5000       include 'COMMON.IOUNITS'
5001       common /sccalc/ time11,time12,time112,theti,it,nlobit
5002       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5003       double precision contr(maxlob)
5004       logical mixed
5005
5006       escloc_i=0.0D0
5007
5008       do j=1,3
5009         dersc(j)=0.0D0
5010       enddo
5011
5012       do j=1,nlobit
5013         do k=1,2
5014           z(k)=x(k)-censc(k,j,it)
5015         enddo
5016         z(3)=dwapi
5017         do k=1,3
5018           Axk=0.0D0
5019           do l=1,3
5020             Axk=Axk+gaussc(l,k,j,it)*z(l)
5021           enddo
5022           Ax(k,j)=Axk
5023         enddo
5024         expfac=0.0D0
5025         do k=1,3
5026           expfac=expfac+Ax(k,j)*z(k)
5027         enddo
5028         contr(j)=expfac
5029       enddo ! j
5030
5031 C As in the case of ebend, we want to avoid underflows in exponentiation and
5032 C subsequent NaNs and INFs in energy calculation.
5033 C Find the largest exponent
5034       emin=contr(1)
5035       do j=1,nlobit
5036         if (emin.gt.contr(j)) emin=contr(j)
5037       enddo
5038       emin=0.5D0*emin
5039
5040 C Compute the contribution to SC energy and derivatives
5041
5042       dersc12=0.0d0
5043       do j=1,nlobit
5044         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5045         escloc_i=escloc_i+expfac
5046         do k=1,2
5047           dersc(k)=dersc(k)+Ax(k,j)*expfac
5048         enddo
5049         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5050      &            +gaussc(1,2,j,it))*expfac
5051         dersc(3)=0.0d0
5052       enddo
5053
5054       dersc(1)=dersc(1)/cos(theti)**2
5055       dersc12=dersc12/cos(theti)**2
5056       escloci=-(dlog(escloc_i)-emin)
5057       do j=1,2
5058         dersc(j)=dersc(j)/escloc_i
5059       enddo
5060       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5061       return
5062       end
5063 #else
5064 c----------------------------------------------------------------------------------
5065       subroutine esc(escloc)
5066 C Calculate the local energy of a side chain and its derivatives in the
5067 C corresponding virtual-bond valence angles THETA and the spherical angles
5068 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5069 C added by Urszula Kozlowska. 07/11/2007
5070 C
5071       implicit real*8 (a-h,o-z)
5072       include 'DIMENSIONS'
5073       include 'COMMON.GEO'
5074       include 'COMMON.LOCAL'
5075       include 'COMMON.VAR'
5076       include 'COMMON.SCROT'
5077       include 'COMMON.INTERACT'
5078       include 'COMMON.DERIV'
5079       include 'COMMON.CHAIN'
5080       include 'COMMON.IOUNITS'
5081       include 'COMMON.NAMES'
5082       include 'COMMON.FFIELD'
5083       include 'COMMON.CONTROL'
5084       include 'COMMON.VECTORS'
5085       double precision x_prime(3),y_prime(3),z_prime(3)
5086      &    , sumene,dsc_i,dp2_i,x(65),
5087      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5088      &    de_dxx,de_dyy,de_dzz,de_dt
5089       double precision s1_t,s1_6_t,s2_t,s2_6_t
5090       double precision
5091      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5092      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5093      & dt_dCi(3),dt_dCi1(3)
5094       common /sccalc/ time11,time12,time112,theti,it,nlobit
5095       delta=0.02d0*pi
5096       escloc=0.0D0
5097       do i=loc_start,loc_end
5098         if (itype(i).eq.ntyp1) cycle
5099         costtab(i+1) =dcos(theta(i+1))
5100         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5101         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5102         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5103         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5104         cosfac=dsqrt(cosfac2)
5105         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5106         sinfac=dsqrt(sinfac2)
5107         it=iabs(itype(i))
5108         if (it.eq.10) goto 1
5109 c
5110 C  Compute the axes of tghe local cartesian coordinates system; store in
5111 c   x_prime, y_prime and z_prime
5112 c
5113         do j=1,3
5114           x_prime(j) = 0.00
5115           y_prime(j) = 0.00
5116           z_prime(j) = 0.00
5117         enddo
5118 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5119 C     &   dc_norm(3,i+nres)
5120         do j = 1,3
5121           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5122           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5123         enddo
5124         do j = 1,3
5125           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5126         enddo
5127 c       write (2,*) "i",i
5128 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5129 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5130 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5131 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5132 c      & " xy",scalar(x_prime(1),y_prime(1)),
5133 c      & " xz",scalar(x_prime(1),z_prime(1)),
5134 c      & " yy",scalar(y_prime(1),y_prime(1)),
5135 c      & " yz",scalar(y_prime(1),z_prime(1)),
5136 c      & " zz",scalar(z_prime(1),z_prime(1))
5137 c
5138 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5139 C to local coordinate system. Store in xx, yy, zz.
5140 c
5141         xx=0.0d0
5142         yy=0.0d0
5143         zz=0.0d0
5144         do j = 1,3
5145           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5146           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5147           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5148         enddo
5149
5150         xxtab(i)=xx
5151         yytab(i)=yy
5152         zztab(i)=zz
5153 C
5154 C Compute the energy of the ith side cbain
5155 C
5156 c        write (2,*) "xx",xx," yy",yy," zz",zz
5157         it=iabs(itype(i))
5158         do j = 1,65
5159           x(j) = sc_parmin(j,it)
5160         enddo
5161 #ifdef CHECK_COORD
5162 Cc diagnostics - remove later
5163         xx1 = dcos(alph(2))
5164         yy1 = dsin(alph(2))*dcos(omeg(2))
5165         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5166         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5167      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5168      &    xx1,yy1,zz1
5169 C,"  --- ", xx_w,yy_w,zz_w
5170 c end diagnostics
5171 #endif
5172         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5173      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5174      &   + x(10)*yy*zz
5175         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5176      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5177      & + x(20)*yy*zz
5178         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5179      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5180      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5181      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5182      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5183      &  +x(40)*xx*yy*zz
5184         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5185      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5186      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5187      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5188      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5189      &  +x(60)*xx*yy*zz
5190         dsc_i   = 0.743d0+x(61)
5191         dp2_i   = 1.9d0+x(62)
5192         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5193      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5194         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5195      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5196         s1=(1+x(63))/(0.1d0 + dscp1)
5197         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5198         s2=(1+x(65))/(0.1d0 + dscp2)
5199         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5200         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5201      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5202 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5203 c     &   sumene4,
5204 c     &   dscp1,dscp2,sumene
5205 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5206         escloc = escloc + sumene
5207 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5208 c     & ,zz,xx,yy
5209 c#define DEBUG
5210 #ifdef DEBUG
5211 C
5212 C This section to check the numerical derivatives of the energy of ith side
5213 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5214 C #define DEBUG in the code to turn it on.
5215 C
5216         write (2,*) "sumene               =",sumene
5217         aincr=1.0d-7
5218         xxsave=xx
5219         xx=xx+aincr
5220         write (2,*) xx,yy,zz
5221         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5222         de_dxx_num=(sumenep-sumene)/aincr
5223         xx=xxsave
5224         write (2,*) "xx+ sumene from enesc=",sumenep
5225         yysave=yy
5226         yy=yy+aincr
5227         write (2,*) xx,yy,zz
5228         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5229         de_dyy_num=(sumenep-sumene)/aincr
5230         yy=yysave
5231         write (2,*) "yy+ sumene from enesc=",sumenep
5232         zzsave=zz
5233         zz=zz+aincr
5234         write (2,*) xx,yy,zz
5235         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5236         de_dzz_num=(sumenep-sumene)/aincr
5237         zz=zzsave
5238         write (2,*) "zz+ sumene from enesc=",sumenep
5239         costsave=cost2tab(i+1)
5240         sintsave=sint2tab(i+1)
5241         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5242         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5243         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5244         de_dt_num=(sumenep-sumene)/aincr
5245         write (2,*) " t+ sumene from enesc=",sumenep
5246         cost2tab(i+1)=costsave
5247         sint2tab(i+1)=sintsave
5248 C End of diagnostics section.
5249 #endif
5250 C
5251 C Compute the gradient of esc
5252 C
5253 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5254         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5255         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5256         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5257         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5258         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5259         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5260         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5261         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5262         pom1=(sumene3*sint2tab(i+1)+sumene1)
5263      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5264         pom2=(sumene4*cost2tab(i+1)+sumene2)
5265      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5266         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5267         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5268      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5269      &  +x(40)*yy*zz
5270         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5271         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5272      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5273      &  +x(60)*yy*zz
5274         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5275      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5276      &        +(pom1+pom2)*pom_dx
5277 #ifdef DEBUG
5278         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5279 #endif
5280 C
5281         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5282         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5283      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5284      &  +x(40)*xx*zz
5285         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5286         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5287      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5288      &  +x(59)*zz**2 +x(60)*xx*zz
5289         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5290      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5291      &        +(pom1-pom2)*pom_dy
5292 #ifdef DEBUG
5293         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5294 #endif
5295 C
5296         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5297      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5298      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5299      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5300      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5301      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5302      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5303      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5304 #ifdef DEBUG
5305         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5306 #endif
5307 C
5308         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5309      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5310      &  +pom1*pom_dt1+pom2*pom_dt2
5311 #ifdef DEBUG
5312         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5313 #endif
5314 c#undef DEBUG
5315 c
5316 C
5317        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5318        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5319        cosfac2xx=cosfac2*xx
5320        sinfac2yy=sinfac2*yy
5321        do k = 1,3
5322          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5323      &      vbld_inv(i+1)
5324          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5325      &      vbld_inv(i)
5326          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5327          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5328 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5329 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5330 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5331 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5332          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5333          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5334          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5335          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5336          dZZ_Ci1(k)=0.0d0
5337          dZZ_Ci(k)=0.0d0
5338          do j=1,3
5339            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5340      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5341            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5342      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5343          enddo
5344
5345          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5346          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5347          dZZ_XYZ(k)=vbld_inv(i+nres)*
5348      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5349 c
5350          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5351          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5352        enddo
5353
5354        do k=1,3
5355          dXX_Ctab(k,i)=dXX_Ci(k)
5356          dXX_C1tab(k,i)=dXX_Ci1(k)
5357          dYY_Ctab(k,i)=dYY_Ci(k)
5358          dYY_C1tab(k,i)=dYY_Ci1(k)
5359          dZZ_Ctab(k,i)=dZZ_Ci(k)
5360          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5361          dXX_XYZtab(k,i)=dXX_XYZ(k)
5362          dYY_XYZtab(k,i)=dYY_XYZ(k)
5363          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5364        enddo
5365
5366        do k = 1,3
5367 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5368 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5369 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5370 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5371 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5372 c     &    dt_dci(k)
5373 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5374 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5375          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5376      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5377          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5378      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5379          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5380      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5381        enddo
5382 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5383 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5384
5385 C to check gradient call subroutine check_grad
5386
5387     1 continue
5388       enddo
5389       return
5390       end
5391 c------------------------------------------------------------------------------
5392       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5393       implicit none
5394       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5395      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5396       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5397      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5398      &   + x(10)*yy*zz
5399       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5400      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5401      & + x(20)*yy*zz
5402       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5403      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5404      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5405      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5406      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5407      &  +x(40)*xx*yy*zz
5408       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5409      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5410      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5411      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5412      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5413      &  +x(60)*xx*yy*zz
5414       dsc_i   = 0.743d0+x(61)
5415       dp2_i   = 1.9d0+x(62)
5416       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5417      &          *(xx*cost2+yy*sint2))
5418       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5419      &          *(xx*cost2-yy*sint2))
5420       s1=(1+x(63))/(0.1d0 + dscp1)
5421       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5422       s2=(1+x(65))/(0.1d0 + dscp2)
5423       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5424       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5425      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5426       enesc=sumene
5427       return
5428       end
5429 #endif
5430 c------------------------------------------------------------------------------
5431       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5432 C
5433 C This procedure calculates two-body contact function g(rij) and its derivative:
5434 C
5435 C           eps0ij                                     !       x < -1
5436 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5437 C            0                                         !       x > 1
5438 C
5439 C where x=(rij-r0ij)/delta
5440 C
5441 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5442 C
5443       implicit none
5444       double precision rij,r0ij,eps0ij,fcont,fprimcont
5445       double precision x,x2,x4,delta
5446 c     delta=0.02D0*r0ij
5447 c      delta=0.2D0*r0ij
5448       x=(rij-r0ij)/delta
5449       if (x.lt.-1.0D0) then
5450         fcont=eps0ij
5451         fprimcont=0.0D0
5452       else if (x.le.1.0D0) then
5453         x2=x*x
5454         x4=x2*x2
5455         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5456         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5457       else
5458         fcont=0.0D0
5459         fprimcont=0.0D0
5460       endif
5461       return
5462       end
5463 c------------------------------------------------------------------------------
5464       subroutine splinthet(theti,delta,ss,ssder)
5465       implicit real*8 (a-h,o-z)
5466       include 'DIMENSIONS'
5467       include 'COMMON.VAR'
5468       include 'COMMON.GEO'
5469       thetup=pi-delta
5470       thetlow=delta
5471       if (theti.gt.pipol) then
5472         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5473       else
5474         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5475         ssder=-ssder
5476       endif
5477       return
5478       end
5479 c------------------------------------------------------------------------------
5480       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5481       implicit none
5482       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5483       double precision ksi,ksi2,ksi3,a1,a2,a3
5484       a1=fprim0*delta/(f1-f0)
5485       a2=3.0d0-2.0d0*a1
5486       a3=a1-2.0d0
5487       ksi=(x-x0)/delta
5488       ksi2=ksi*ksi
5489       ksi3=ksi2*ksi
5490       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5491       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5492       return
5493       end
5494 c------------------------------------------------------------------------------
5495       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5496       implicit none
5497       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5498       double precision ksi,ksi2,ksi3,a1,a2,a3
5499       ksi=(x-x0)/delta
5500       ksi2=ksi*ksi
5501       ksi3=ksi2*ksi
5502       a1=fprim0x*delta
5503       a2=3*(f1x-f0x)-2*fprim0x*delta
5504       a3=fprim0x*delta-2*(f1x-f0x)
5505       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5506       return
5507       end
5508 C-----------------------------------------------------------------------------
5509 #ifdef CRYST_TOR
5510 C-----------------------------------------------------------------------------
5511       subroutine etor(etors,edihcnstr)
5512       implicit real*8 (a-h,o-z)
5513       include 'DIMENSIONS'
5514       include 'COMMON.VAR'
5515       include 'COMMON.GEO'
5516       include 'COMMON.LOCAL'
5517       include 'COMMON.TORSION'
5518       include 'COMMON.INTERACT'
5519       include 'COMMON.DERIV'
5520       include 'COMMON.CHAIN'
5521       include 'COMMON.NAMES'
5522       include 'COMMON.IOUNITS'
5523       include 'COMMON.FFIELD'
5524       include 'COMMON.TORCNSTR'
5525       include 'COMMON.CONTROL'
5526       logical lprn
5527 C Set lprn=.true. for debugging
5528       lprn=.false.
5529 c      lprn=.true.
5530       etors=0.0D0
5531       do i=iphi_start,iphi_end
5532       etors_ii=0.0D0
5533         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5534      &      .or. itype(i).eq.ntyp1) cycle
5535         itori=itortyp(itype(i-2))
5536         itori1=itortyp(itype(i-1))
5537         phii=phi(i)
5538         gloci=0.0D0
5539 C Proline-Proline pair is a special case...
5540         if (itori.eq.3 .and. itori1.eq.3) then
5541           if (phii.gt.-dwapi3) then
5542             cosphi=dcos(3*phii)
5543             fac=1.0D0/(1.0D0-cosphi)
5544             etorsi=v1(1,3,3)*fac
5545             etorsi=etorsi+etorsi
5546             etors=etors+etorsi-v1(1,3,3)
5547             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5548             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5549           endif
5550           do j=1,3
5551             v1ij=v1(j+1,itori,itori1)
5552             v2ij=v2(j+1,itori,itori1)
5553             cosphi=dcos(j*phii)
5554             sinphi=dsin(j*phii)
5555             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5556             if (energy_dec) etors_ii=etors_ii+
5557      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5558             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5559           enddo
5560         else
5561           do j=1,nterm_old
5562             v1ij=v1(j,itori,itori1)
5563             v2ij=v2(j,itori,itori1)
5564             cosphi=dcos(j*phii)
5565             sinphi=dsin(j*phii)
5566             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5567             if (energy_dec) etors_ii=etors_ii+
5568      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5569             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5570           enddo
5571         endif
5572         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5573              'etor',i,etors_ii
5574         if (lprn)
5575      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5576      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5577      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5578         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5579 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5580       enddo
5581 ! 6/20/98 - dihedral angle constraints
5582       edihcnstr=0.0d0
5583       do i=1,ndih_constr
5584         itori=idih_constr(i)
5585         phii=phi(itori)
5586         difi=phii-phi0(i)
5587         if (difi.gt.drange(i)) then
5588           difi=difi-drange(i)
5589           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5590           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5591         else if (difi.lt.-drange(i)) then
5592           difi=difi+drange(i)
5593           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5594           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5595         endif
5596 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5597 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5598       enddo
5599 !      write (iout,*) 'edihcnstr',edihcnstr
5600       return
5601       end
5602 c------------------------------------------------------------------------------
5603       subroutine etor_d(etors_d)
5604       etors_d=0.0d0
5605       return
5606       end
5607 c----------------------------------------------------------------------------
5608 #else
5609       subroutine etor(etors,edihcnstr)
5610       implicit real*8 (a-h,o-z)
5611       include 'DIMENSIONS'
5612       include 'COMMON.VAR'
5613       include 'COMMON.GEO'
5614       include 'COMMON.LOCAL'
5615       include 'COMMON.TORSION'
5616       include 'COMMON.INTERACT'
5617       include 'COMMON.DERIV'
5618       include 'COMMON.CHAIN'
5619       include 'COMMON.NAMES'
5620       include 'COMMON.IOUNITS'
5621       include 'COMMON.FFIELD'
5622       include 'COMMON.TORCNSTR'
5623       include 'COMMON.CONTROL'
5624       logical lprn
5625 C Set lprn=.true. for debugging
5626       lprn=.false.
5627 c     lprn=.true.
5628       etors=0.0D0
5629       do i=iphi_start,iphi_end
5630         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5631      &       .or. itype(i).eq.ntyp1) cycle
5632         etors_ii=0.0D0
5633          if (iabs(itype(i)).eq.20) then
5634          iblock=2
5635          else
5636          iblock=1
5637          endif
5638         itori=itortyp(itype(i-2))
5639         itori1=itortyp(itype(i-1))
5640         phii=phi(i)
5641         gloci=0.0D0
5642 C Regular cosine and sine terms
5643         do j=1,nterm(itori,itori1,iblock)
5644           v1ij=v1(j,itori,itori1,iblock)
5645           v2ij=v2(j,itori,itori1,iblock)
5646           cosphi=dcos(j*phii)
5647           sinphi=dsin(j*phii)
5648           etors=etors+v1ij*cosphi+v2ij*sinphi
5649           if (energy_dec) etors_ii=etors_ii+
5650      &                v1ij*cosphi+v2ij*sinphi
5651           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5652         enddo
5653 C Lorentz terms
5654 C                         v1
5655 C  E = SUM ----------------------------------- - v1
5656 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5657 C
5658         cosphi=dcos(0.5d0*phii)
5659         sinphi=dsin(0.5d0*phii)
5660         do j=1,nlor(itori,itori1,iblock)
5661           vl1ij=vlor1(j,itori,itori1)
5662           vl2ij=vlor2(j,itori,itori1)
5663           vl3ij=vlor3(j,itori,itori1)
5664           pom=vl2ij*cosphi+vl3ij*sinphi
5665           pom1=1.0d0/(pom*pom+1.0d0)
5666           etors=etors+vl1ij*pom1
5667           if (energy_dec) etors_ii=etors_ii+
5668      &                vl1ij*pom1
5669           pom=-pom*pom1*pom1
5670           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5671         enddo
5672 C Subtract the constant term
5673         etors=etors-v0(itori,itori1,iblock)
5674           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5675      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5676         if (lprn)
5677      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5678      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5679      &  (v1(j,itori,itori1,iblock),j=1,6),
5680      &  (v2(j,itori,itori1,iblock),j=1,6)
5681         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5682 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5683       enddo
5684 ! 6/20/98 - dihedral angle constraints
5685       edihcnstr=0.0d0
5686 c      do i=1,ndih_constr
5687       do i=idihconstr_start,idihconstr_end
5688         itori=idih_constr(i)
5689         phii=phi(itori)
5690         difi=pinorm(phii-phi0(i))
5691         if (difi.gt.drange(i)) then
5692           difi=difi-drange(i)
5693           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5694           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5695         else if (difi.lt.-drange(i)) then
5696           difi=difi+drange(i)
5697           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5698           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5699         else
5700           difi=0.0
5701         endif
5702 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5703 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5704 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5705       enddo
5706 cd       write (iout,*) 'edihcnstr',edihcnstr
5707       return
5708       end
5709 c----------------------------------------------------------------------------
5710       subroutine etor_d(etors_d)
5711 C 6/23/01 Compute double torsional energy
5712       implicit real*8 (a-h,o-z)
5713       include 'DIMENSIONS'
5714       include 'COMMON.VAR'
5715       include 'COMMON.GEO'
5716       include 'COMMON.LOCAL'
5717       include 'COMMON.TORSION'
5718       include 'COMMON.INTERACT'
5719       include 'COMMON.DERIV'
5720       include 'COMMON.CHAIN'
5721       include 'COMMON.NAMES'
5722       include 'COMMON.IOUNITS'
5723       include 'COMMON.FFIELD'
5724       include 'COMMON.TORCNSTR'
5725       logical lprn
5726 C Set lprn=.true. for debugging
5727       lprn=.false.
5728 c     lprn=.true.
5729       etors_d=0.0D0
5730 c      write(iout,*) "a tu??"
5731       do i=iphid_start,iphid_end
5732         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5733      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5734         itori=itortyp(itype(i-2))
5735         itori1=itortyp(itype(i-1))
5736         itori2=itortyp(itype(i))
5737         phii=phi(i)
5738         phii1=phi(i+1)
5739         gloci1=0.0D0
5740         gloci2=0.0D0
5741         iblock=1
5742         if (iabs(itype(i+1)).eq.20) iblock=2
5743
5744 C Regular cosine and sine terms
5745         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5746           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5747           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5748           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5749           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5750           cosphi1=dcos(j*phii)
5751           sinphi1=dsin(j*phii)
5752           cosphi2=dcos(j*phii1)
5753           sinphi2=dsin(j*phii1)
5754           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5755      &     v2cij*cosphi2+v2sij*sinphi2
5756           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5757           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5758         enddo
5759         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5760           do l=1,k-1
5761             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5762             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5763             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5764             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5765             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5766             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5767             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5768             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5769             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5770      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5771             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5772      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5773             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5774      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5775           enddo
5776         enddo
5777         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5778         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5779       enddo
5780       return
5781       end
5782 #endif
5783 c------------------------------------------------------------------------------
5784       subroutine eback_sc_corr(esccor)
5785 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5786 c        conformational states; temporarily implemented as differences
5787 c        between UNRES torsional potentials (dependent on three types of
5788 c        residues) and the torsional potentials dependent on all 20 types
5789 c        of residues computed from AM1  energy surfaces of terminally-blocked
5790 c        amino-acid residues.
5791       implicit real*8 (a-h,o-z)
5792       include 'DIMENSIONS'
5793       include 'COMMON.VAR'
5794       include 'COMMON.GEO'
5795       include 'COMMON.LOCAL'
5796       include 'COMMON.TORSION'
5797       include 'COMMON.SCCOR'
5798       include 'COMMON.INTERACT'
5799       include 'COMMON.DERIV'
5800       include 'COMMON.CHAIN'
5801       include 'COMMON.NAMES'
5802       include 'COMMON.IOUNITS'
5803       include 'COMMON.FFIELD'
5804       include 'COMMON.CONTROL'
5805       logical lprn
5806 C Set lprn=.true. for debugging
5807       lprn=.false.
5808 c      lprn=.true.
5809 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5810       esccor=0.0D0
5811       do i=itau_start,itau_end
5812         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5813         esccor_ii=0.0D0
5814         isccori=isccortyp(itype(i-2))
5815         isccori1=isccortyp(itype(i-1))
5816 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5817         phii=phi(i)
5818         do intertyp=1,3 !intertyp
5819 cc Added 09 May 2012 (Adasko)
5820 cc  Intertyp means interaction type of backbone mainchain correlation:
5821 c   1 = SC...Ca...Ca...Ca
5822 c   2 = Ca...Ca...Ca...SC
5823 c   3 = SC...Ca...Ca...SCi
5824         gloci=0.0D0
5825         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5826      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5827      &      (itype(i-1).eq.ntyp1)))
5828      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5829      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5830      &     .or.(itype(i).eq.ntyp1)))
5831      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5832      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5833      &      (itype(i-3).eq.ntyp1)))) cycle
5834         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5835         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5836      & cycle
5837        do j=1,nterm_sccor(isccori,isccori1)
5838           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5839           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5840           cosphi=dcos(j*tauangle(intertyp,i))
5841           sinphi=dsin(j*tauangle(intertyp,i))
5842           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5843           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5844         enddo
5845 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5846         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5847         if (lprn)
5848      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5849      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5850      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5851      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5852         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5853        enddo !intertyp
5854       enddo
5855
5856       return
5857       end
5858 c----------------------------------------------------------------------------
5859       subroutine multibody(ecorr)
5860 C This subroutine calculates multi-body contributions to energy following
5861 C the idea of Skolnick et al. If side chains I and J make a contact and
5862 C at the same time side chains I+1 and J+1 make a contact, an extra
5863 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5864       implicit real*8 (a-h,o-z)
5865       include 'DIMENSIONS'
5866       include 'COMMON.IOUNITS'
5867       include 'COMMON.DERIV'
5868       include 'COMMON.INTERACT'
5869       include 'COMMON.CONTACTS'
5870       double precision gx(3),gx1(3)
5871       logical lprn
5872
5873 C Set lprn=.true. for debugging
5874       lprn=.false.
5875
5876       if (lprn) then
5877         write (iout,'(a)') 'Contact function values:'
5878         do i=nnt,nct-2
5879           write (iout,'(i2,20(1x,i2,f10.5))')
5880      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5881         enddo
5882       endif
5883       ecorr=0.0D0
5884       do i=nnt,nct
5885         do j=1,3
5886           gradcorr(j,i)=0.0D0
5887           gradxorr(j,i)=0.0D0
5888         enddo
5889       enddo
5890       do i=nnt,nct-2
5891
5892         DO ISHIFT = 3,4
5893
5894         i1=i+ishift
5895         num_conti=num_cont(i)
5896         num_conti1=num_cont(i1)
5897         do jj=1,num_conti
5898           j=jcont(jj,i)
5899           do kk=1,num_conti1
5900             j1=jcont(kk,i1)
5901             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5902 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5903 cd   &                   ' ishift=',ishift
5904 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5905 C The system gains extra energy.
5906               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5907             endif   ! j1==j+-ishift
5908           enddo     ! kk
5909         enddo       ! jj
5910
5911         ENDDO ! ISHIFT
5912
5913       enddo         ! i
5914       return
5915       end
5916 c------------------------------------------------------------------------------
5917       double precision function esccorr(i,j,k,l,jj,kk)
5918       implicit real*8 (a-h,o-z)
5919       include 'DIMENSIONS'
5920       include 'COMMON.IOUNITS'
5921       include 'COMMON.DERIV'
5922       include 'COMMON.INTERACT'
5923       include 'COMMON.CONTACTS'
5924       double precision gx(3),gx1(3)
5925       logical lprn
5926       lprn=.false.
5927       eij=facont(jj,i)
5928       ekl=facont(kk,k)
5929 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5930 C Calculate the multi-body contribution to energy.
5931 C Calculate multi-body contributions to the gradient.
5932 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5933 cd   & k,l,(gacont(m,kk,k),m=1,3)
5934       do m=1,3
5935         gx(m) =ekl*gacont(m,jj,i)
5936         gx1(m)=eij*gacont(m,kk,k)
5937         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5938         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5939         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5940         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5941       enddo
5942       do m=i,j-1
5943         do ll=1,3
5944           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5945         enddo
5946       enddo
5947       do m=k,l-1
5948         do ll=1,3
5949           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5950         enddo
5951       enddo
5952       esccorr=-eij*ekl
5953       return
5954       end
5955 c------------------------------------------------------------------------------
5956       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5957 C This subroutine calculates multi-body contributions to hydrogen-bonding
5958       implicit real*8 (a-h,o-z)
5959       include 'DIMENSIONS'
5960       include 'COMMON.IOUNITS'
5961 #ifdef MPI
5962       include "mpif.h"
5963       parameter (max_cont=maxconts)
5964       parameter (max_dim=26)
5965       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5966       double precision zapas(max_dim,maxconts,max_fg_procs),
5967      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5968       common /przechowalnia/ zapas
5969       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5970      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5971 #endif
5972       include 'COMMON.SETUP'
5973       include 'COMMON.FFIELD'
5974       include 'COMMON.DERIV'
5975       include 'COMMON.INTERACT'
5976       include 'COMMON.CONTACTS'
5977       include 'COMMON.CONTROL'
5978       include 'COMMON.LOCAL'
5979       double precision gx(3),gx1(3),time00
5980       logical lprn,ldone
5981
5982 C Set lprn=.true. for debugging
5983       lprn=.false.
5984 #ifdef MPI
5985       n_corr=0
5986       n_corr1=0
5987       if (nfgtasks.le.1) goto 30
5988       if (lprn) then
5989         write (iout,'(a)') 'Contact function values before RECEIVE:'
5990         do i=nnt,nct-2
5991           write (iout,'(2i3,50(1x,i2,f5.2))')
5992      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5993      &    j=1,num_cont_hb(i))
5994         enddo
5995       endif
5996       call flush(iout)
5997       do i=1,ntask_cont_from
5998         ncont_recv(i)=0
5999       enddo
6000       do i=1,ntask_cont_to
6001         ncont_sent(i)=0
6002       enddo
6003 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6004 c     & ntask_cont_to
6005 C Make the list of contacts to send to send to other procesors
6006 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6007 c      call flush(iout)
6008       do i=iturn3_start,iturn3_end
6009 c        write (iout,*) "make contact list turn3",i," num_cont",
6010 c     &    num_cont_hb(i)
6011         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6012       enddo
6013       do i=iturn4_start,iturn4_end
6014 c        write (iout,*) "make contact list turn4",i," num_cont",
6015 c     &   num_cont_hb(i)
6016         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6017       enddo
6018       do ii=1,nat_sent
6019         i=iat_sent(ii)
6020 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6021 c     &    num_cont_hb(i)
6022         do j=1,num_cont_hb(i)
6023         do k=1,4
6024           jjc=jcont_hb(j,i)
6025           iproc=iint_sent_local(k,jjc,ii)
6026 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6027           if (iproc.gt.0) then
6028             ncont_sent(iproc)=ncont_sent(iproc)+1
6029             nn=ncont_sent(iproc)
6030             zapas(1,nn,iproc)=i
6031             zapas(2,nn,iproc)=jjc
6032             zapas(3,nn,iproc)=facont_hb(j,i)
6033             zapas(4,nn,iproc)=ees0p(j,i)
6034             zapas(5,nn,iproc)=ees0m(j,i)
6035             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6036             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6037             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6038             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6039             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6040             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6041             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6042             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6043             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6044             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6045             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6046             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6047             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6048             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6049             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6050             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6051             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6052             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6053             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6054             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6055             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6056           endif
6057         enddo
6058         enddo
6059       enddo
6060       if (lprn) then
6061       write (iout,*)
6062      &  "Numbers of contacts to be sent to other processors",
6063      &  (ncont_sent(i),i=1,ntask_cont_to)
6064       write (iout,*) "Contacts sent"
6065       do ii=1,ntask_cont_to
6066         nn=ncont_sent(ii)
6067         iproc=itask_cont_to(ii)
6068         write (iout,*) nn," contacts to processor",iproc,
6069      &   " of CONT_TO_COMM group"
6070         do i=1,nn
6071           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6072         enddo
6073       enddo
6074       call flush(iout)
6075       endif
6076       CorrelType=477
6077       CorrelID=fg_rank+1
6078       CorrelType1=478
6079       CorrelID1=nfgtasks+fg_rank+1
6080       ireq=0
6081 C Receive the numbers of needed contacts from other processors
6082       do ii=1,ntask_cont_from
6083         iproc=itask_cont_from(ii)
6084         ireq=ireq+1
6085         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6086      &    FG_COMM,req(ireq),IERR)
6087       enddo
6088 c      write (iout,*) "IRECV ended"
6089 c      call flush(iout)
6090 C Send the number of contacts needed by other processors
6091       do ii=1,ntask_cont_to
6092         iproc=itask_cont_to(ii)
6093         ireq=ireq+1
6094         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6095      &    FG_COMM,req(ireq),IERR)
6096       enddo
6097 c      write (iout,*) "ISEND ended"
6098 c      write (iout,*) "number of requests (nn)",ireq
6099       call flush(iout)
6100       if (ireq.gt.0)
6101      &  call MPI_Waitall(ireq,req,status_array,ierr)
6102 c      write (iout,*)
6103 c     &  "Numbers of contacts to be received from other processors",
6104 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6105 c      call flush(iout)
6106 C Receive contacts
6107       ireq=0
6108       do ii=1,ntask_cont_from
6109         iproc=itask_cont_from(ii)
6110         nn=ncont_recv(ii)
6111 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6112 c     &   " of CONT_TO_COMM group"
6113         call flush(iout)
6114         if (nn.gt.0) then
6115           ireq=ireq+1
6116           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6117      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6118 c          write (iout,*) "ireq,req",ireq,req(ireq)
6119         endif
6120       enddo
6121 C Send the contacts to processors that need them
6122       do ii=1,ntask_cont_to
6123         iproc=itask_cont_to(ii)
6124         nn=ncont_sent(ii)
6125 c        write (iout,*) nn," contacts to processor",iproc,
6126 c     &   " of CONT_TO_COMM group"
6127         if (nn.gt.0) then
6128           ireq=ireq+1
6129           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6130      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6131 c          write (iout,*) "ireq,req",ireq,req(ireq)
6132 c          do i=1,nn
6133 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6134 c          enddo
6135         endif
6136       enddo
6137 c      write (iout,*) "number of requests (contacts)",ireq
6138 c      write (iout,*) "req",(req(i),i=1,4)
6139 c      call flush(iout)
6140       if (ireq.gt.0)
6141      & call MPI_Waitall(ireq,req,status_array,ierr)
6142       do iii=1,ntask_cont_from
6143         iproc=itask_cont_from(iii)
6144         nn=ncont_recv(iii)
6145         if (lprn) then
6146         write (iout,*) "Received",nn," contacts from processor",iproc,
6147      &   " of CONT_FROM_COMM group"
6148         call flush(iout)
6149         do i=1,nn
6150           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6151         enddo
6152         call flush(iout)
6153         endif
6154         do i=1,nn
6155           ii=zapas_recv(1,i,iii)
6156 c Flag the received contacts to prevent double-counting
6157           jj=-zapas_recv(2,i,iii)
6158 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6159 c          call flush(iout)
6160           nnn=num_cont_hb(ii)+1
6161           num_cont_hb(ii)=nnn
6162           jcont_hb(nnn,ii)=jj
6163           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6164           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6165           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6166           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6167           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6168           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6169           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6170           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6171           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6172           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6173           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6174           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6175           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6176           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6177           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6178           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6179           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6180           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6181           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6182           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6183           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6184           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6185           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6186           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6187         enddo
6188       enddo
6189       call flush(iout)
6190       if (lprn) then
6191         write (iout,'(a)') 'Contact function values after receive:'
6192         do i=nnt,nct-2
6193           write (iout,'(2i3,50(1x,i3,f5.2))')
6194      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6195      &    j=1,num_cont_hb(i))
6196         enddo
6197         call flush(iout)
6198       endif
6199    30 continue
6200 #endif
6201       if (lprn) then
6202         write (iout,'(a)') 'Contact function values:'
6203         do i=nnt,nct-2
6204           write (iout,'(2i3,50(1x,i3,f5.2))')
6205      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6206      &    j=1,num_cont_hb(i))
6207         enddo
6208       endif
6209       ecorr=0.0D0
6210 C Remove the loop below after debugging !!!
6211       do i=nnt,nct
6212         do j=1,3
6213           gradcorr(j,i)=0.0D0
6214           gradxorr(j,i)=0.0D0
6215         enddo
6216       enddo
6217 C Calculate the local-electrostatic correlation terms
6218       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6219         i1=i+1
6220         num_conti=num_cont_hb(i)
6221         num_conti1=num_cont_hb(i+1)
6222         do jj=1,num_conti
6223           j=jcont_hb(jj,i)
6224           jp=iabs(j)
6225           do kk=1,num_conti1
6226             j1=jcont_hb(kk,i1)
6227             jp1=iabs(j1)
6228 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6229 c     &         ' jj=',jj,' kk=',kk
6230             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6231      &          .or. j.lt.0 .and. j1.gt.0) .and.
6232      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6233 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6234 C The system gains extra energy.
6235               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6236               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6237      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6238               n_corr=n_corr+1
6239             else if (j1.eq.j) then
6240 C Contacts I-J and I-(J+1) occur simultaneously.
6241 C The system loses extra energy.
6242 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6243             endif
6244           enddo ! kk
6245           do kk=1,num_conti
6246             j1=jcont_hb(kk,i)
6247 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6248 c    &         ' jj=',jj,' kk=',kk
6249             if (j1.eq.j+1) then
6250 C Contacts I-J and (I+1)-J occur simultaneously.
6251 C The system loses extra energy.
6252 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6253             endif ! j1==j+1
6254           enddo ! kk
6255         enddo ! jj
6256       enddo ! i
6257       return
6258       end
6259 c------------------------------------------------------------------------------
6260       subroutine add_hb_contact(ii,jj,itask)
6261       implicit real*8 (a-h,o-z)
6262       include "DIMENSIONS"
6263       include "COMMON.IOUNITS"
6264       integer max_cont
6265       integer max_dim
6266       parameter (max_cont=maxconts)
6267       parameter (max_dim=26)
6268       include "COMMON.CONTACTS"
6269       double precision zapas(max_dim,maxconts,max_fg_procs),
6270      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6271       common /przechowalnia/ zapas
6272       integer i,j,ii,jj,iproc,itask(4),nn
6273 c      write (iout,*) "itask",itask
6274       do i=1,2
6275         iproc=itask(i)
6276         if (iproc.gt.0) then
6277           do j=1,num_cont_hb(ii)
6278             jjc=jcont_hb(j,ii)
6279 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6280             if (jjc.eq.jj) then
6281               ncont_sent(iproc)=ncont_sent(iproc)+1
6282               nn=ncont_sent(iproc)
6283               zapas(1,nn,iproc)=ii
6284               zapas(2,nn,iproc)=jjc
6285               zapas(3,nn,iproc)=facont_hb(j,ii)
6286               zapas(4,nn,iproc)=ees0p(j,ii)
6287               zapas(5,nn,iproc)=ees0m(j,ii)
6288               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6289               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6290               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6291               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6292               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6293               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6294               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6295               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6296               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6297               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6298               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6299               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6300               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6301               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6302               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6303               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6304               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6305               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6306               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6307               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6308               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6309               exit
6310             endif
6311           enddo
6312         endif
6313       enddo
6314       return
6315       end
6316 c------------------------------------------------------------------------------
6317       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6318      &  n_corr1)
6319 C This subroutine calculates multi-body contributions to hydrogen-bonding
6320       implicit real*8 (a-h,o-z)
6321       include 'DIMENSIONS'
6322       include 'COMMON.IOUNITS'
6323 #ifdef MPI
6324       include "mpif.h"
6325       parameter (max_cont=maxconts)
6326       parameter (max_dim=70)
6327       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6328       double precision zapas(max_dim,maxconts,max_fg_procs),
6329      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6330       common /przechowalnia/ zapas
6331       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6332      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6333 #endif
6334       include 'COMMON.SETUP'
6335       include 'COMMON.FFIELD'
6336       include 'COMMON.DERIV'
6337       include 'COMMON.LOCAL'
6338       include 'COMMON.INTERACT'
6339       include 'COMMON.CONTACTS'
6340       include 'COMMON.CHAIN'
6341       include 'COMMON.CONTROL'
6342       double precision gx(3),gx1(3)
6343       integer num_cont_hb_old(maxres)
6344       logical lprn,ldone
6345       double precision eello4,eello5,eelo6,eello_turn6
6346       external eello4,eello5,eello6,eello_turn6
6347 C Set lprn=.true. for debugging
6348       lprn=.false.
6349       eturn6=0.0d0
6350 #ifdef MPI
6351       do i=1,nres
6352         num_cont_hb_old(i)=num_cont_hb(i)
6353       enddo
6354       n_corr=0
6355       n_corr1=0
6356       if (nfgtasks.le.1) goto 30
6357       if (lprn) then
6358         write (iout,'(a)') 'Contact function values before RECEIVE:'
6359         do i=nnt,nct-2
6360           write (iout,'(2i3,50(1x,i2,f5.2))')
6361      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6362      &    j=1,num_cont_hb(i))
6363         enddo
6364       endif
6365       call flush(iout)
6366       do i=1,ntask_cont_from
6367         ncont_recv(i)=0
6368       enddo
6369       do i=1,ntask_cont_to
6370         ncont_sent(i)=0
6371       enddo
6372 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6373 c     & ntask_cont_to
6374 C Make the list of contacts to send to send to other procesors
6375       do i=iturn3_start,iturn3_end
6376 c        write (iout,*) "make contact list turn3",i," num_cont",
6377 c     &    num_cont_hb(i)
6378         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6379       enddo
6380       do i=iturn4_start,iturn4_end
6381 c        write (iout,*) "make contact list turn4",i," num_cont",
6382 c     &   num_cont_hb(i)
6383         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6384       enddo
6385       do ii=1,nat_sent
6386         i=iat_sent(ii)
6387 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6388 c     &    num_cont_hb(i)
6389         do j=1,num_cont_hb(i)
6390         do k=1,4
6391           jjc=jcont_hb(j,i)
6392           iproc=iint_sent_local(k,jjc,ii)
6393 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6394           if (iproc.ne.0) then
6395             ncont_sent(iproc)=ncont_sent(iproc)+1
6396             nn=ncont_sent(iproc)
6397             zapas(1,nn,iproc)=i
6398             zapas(2,nn,iproc)=jjc
6399             zapas(3,nn,iproc)=d_cont(j,i)
6400             ind=3
6401             do kk=1,3
6402               ind=ind+1
6403               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6404             enddo
6405             do kk=1,2
6406               do ll=1,2
6407                 ind=ind+1
6408                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6409               enddo
6410             enddo
6411             do jj=1,5
6412               do kk=1,3
6413                 do ll=1,2
6414                   do mm=1,2
6415                     ind=ind+1
6416                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6417                   enddo
6418                 enddo
6419               enddo
6420             enddo
6421           endif
6422         enddo
6423         enddo
6424       enddo
6425       if (lprn) then
6426       write (iout,*)
6427      &  "Numbers of contacts to be sent to other processors",
6428      &  (ncont_sent(i),i=1,ntask_cont_to)
6429       write (iout,*) "Contacts sent"
6430       do ii=1,ntask_cont_to
6431         nn=ncont_sent(ii)
6432         iproc=itask_cont_to(ii)
6433         write (iout,*) nn," contacts to processor",iproc,
6434      &   " of CONT_TO_COMM group"
6435         do i=1,nn
6436           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6437         enddo
6438       enddo
6439       call flush(iout)
6440       endif
6441       CorrelType=477
6442       CorrelID=fg_rank+1
6443       CorrelType1=478
6444       CorrelID1=nfgtasks+fg_rank+1
6445       ireq=0
6446 C Receive the numbers of needed contacts from other processors
6447       do ii=1,ntask_cont_from
6448         iproc=itask_cont_from(ii)
6449         ireq=ireq+1
6450         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6451      &    FG_COMM,req(ireq),IERR)
6452       enddo
6453 c      write (iout,*) "IRECV ended"
6454 c      call flush(iout)
6455 C Send the number of contacts needed by other processors
6456       do ii=1,ntask_cont_to
6457         iproc=itask_cont_to(ii)
6458         ireq=ireq+1
6459         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6460      &    FG_COMM,req(ireq),IERR)
6461       enddo
6462 c      write (iout,*) "ISEND ended"
6463 c      write (iout,*) "number of requests (nn)",ireq
6464       call flush(iout)
6465       if (ireq.gt.0)
6466      &  call MPI_Waitall(ireq,req,status_array,ierr)
6467 c      write (iout,*)
6468 c     &  "Numbers of contacts to be received from other processors",
6469 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6470 c      call flush(iout)
6471 C Receive contacts
6472       ireq=0
6473       do ii=1,ntask_cont_from
6474         iproc=itask_cont_from(ii)
6475         nn=ncont_recv(ii)
6476 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6477 c     &   " of CONT_TO_COMM group"
6478         call flush(iout)
6479         if (nn.gt.0) then
6480           ireq=ireq+1
6481           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6482      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6483 c          write (iout,*) "ireq,req",ireq,req(ireq)
6484         endif
6485       enddo
6486 C Send the contacts to processors that need them
6487       do ii=1,ntask_cont_to
6488         iproc=itask_cont_to(ii)
6489         nn=ncont_sent(ii)
6490 c        write (iout,*) nn," contacts to processor",iproc,
6491 c     &   " of CONT_TO_COMM group"
6492         if (nn.gt.0) then
6493           ireq=ireq+1
6494           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6495      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6496 c          write (iout,*) "ireq,req",ireq,req(ireq)
6497 c          do i=1,nn
6498 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6499 c          enddo
6500         endif
6501       enddo
6502 c      write (iout,*) "number of requests (contacts)",ireq
6503 c      write (iout,*) "req",(req(i),i=1,4)
6504 c      call flush(iout)
6505       if (ireq.gt.0)
6506      & call MPI_Waitall(ireq,req,status_array,ierr)
6507       do iii=1,ntask_cont_from
6508         iproc=itask_cont_from(iii)
6509         nn=ncont_recv(iii)
6510         if (lprn) then
6511         write (iout,*) "Received",nn," contacts from processor",iproc,
6512      &   " of CONT_FROM_COMM group"
6513         call flush(iout)
6514         do i=1,nn
6515           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6516         enddo
6517         call flush(iout)
6518         endif
6519         do i=1,nn
6520           ii=zapas_recv(1,i,iii)
6521 c Flag the received contacts to prevent double-counting
6522           jj=-zapas_recv(2,i,iii)
6523 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6524 c          call flush(iout)
6525           nnn=num_cont_hb(ii)+1
6526           num_cont_hb(ii)=nnn
6527           jcont_hb(nnn,ii)=jj
6528           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6529           ind=3
6530           do kk=1,3
6531             ind=ind+1
6532             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6533           enddo
6534           do kk=1,2
6535             do ll=1,2
6536               ind=ind+1
6537               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6538             enddo
6539           enddo
6540           do jj=1,5
6541             do kk=1,3
6542               do ll=1,2
6543                 do mm=1,2
6544                   ind=ind+1
6545                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6546                 enddo
6547               enddo
6548             enddo
6549           enddo
6550         enddo
6551       enddo
6552       call flush(iout)
6553       if (lprn) then
6554         write (iout,'(a)') 'Contact function values after receive:'
6555         do i=nnt,nct-2
6556           write (iout,'(2i3,50(1x,i3,5f6.3))')
6557      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6558      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6559         enddo
6560         call flush(iout)
6561       endif
6562    30 continue
6563 #endif
6564       if (lprn) then
6565         write (iout,'(a)') 'Contact function values:'
6566         do i=nnt,nct-2
6567           write (iout,'(2i3,50(1x,i2,5f6.3))')
6568      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6569      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6570         enddo
6571       endif
6572       ecorr=0.0D0
6573       ecorr5=0.0d0
6574       ecorr6=0.0d0
6575 C Remove the loop below after debugging !!!
6576       do i=nnt,nct
6577         do j=1,3
6578           gradcorr(j,i)=0.0D0
6579           gradxorr(j,i)=0.0D0
6580         enddo
6581       enddo
6582 C Calculate the dipole-dipole interaction energies
6583       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6584       do i=iatel_s,iatel_e+1
6585         num_conti=num_cont_hb(i)
6586         do jj=1,num_conti
6587           j=jcont_hb(jj,i)
6588 #ifdef MOMENT
6589           call dipole(i,j,jj)
6590 #endif
6591         enddo
6592       enddo
6593       endif
6594 C Calculate the local-electrostatic correlation terms
6595 c                write (iout,*) "gradcorr5 in eello5 before loop"
6596 c                do iii=1,nres
6597 c                  write (iout,'(i5,3f10.5)')
6598 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6599 c                enddo
6600       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6601 c        write (iout,*) "corr loop i",i
6602         i1=i+1
6603         num_conti=num_cont_hb(i)
6604         num_conti1=num_cont_hb(i+1)
6605         do jj=1,num_conti
6606           j=jcont_hb(jj,i)
6607           jp=iabs(j)
6608           do kk=1,num_conti1
6609             j1=jcont_hb(kk,i1)
6610             jp1=iabs(j1)
6611 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6612 c     &         ' jj=',jj,' kk=',kk
6613 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6614             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6615      &          .or. j.lt.0 .and. j1.gt.0) .and.
6616      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6617 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6618 C The system gains extra energy.
6619               n_corr=n_corr+1
6620               sqd1=dsqrt(d_cont(jj,i))
6621               sqd2=dsqrt(d_cont(kk,i1))
6622               sred_geom = sqd1*sqd2
6623               IF (sred_geom.lt.cutoff_corr) THEN
6624                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6625      &            ekont,fprimcont)
6626 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6627 cd     &         ' jj=',jj,' kk=',kk
6628                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6629                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6630                 do l=1,3
6631                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6632                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6633                 enddo
6634                 n_corr1=n_corr1+1
6635 cd               write (iout,*) 'sred_geom=',sred_geom,
6636 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6637 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6638 cd               write (iout,*) "g_contij",g_contij
6639 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6640 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6641                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6642                 if (wcorr4.gt.0.0d0)
6643      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6644                   if (energy_dec.and.wcorr4.gt.0.0d0)
6645      1                 write (iout,'(a6,4i5,0pf7.3)')
6646      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6647 c                write (iout,*) "gradcorr5 before eello5"
6648 c                do iii=1,nres
6649 c                  write (iout,'(i5,3f10.5)')
6650 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6651 c                enddo
6652                 if (wcorr5.gt.0.0d0)
6653      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6654 c                write (iout,*) "gradcorr5 after eello5"
6655 c                do iii=1,nres
6656 c                  write (iout,'(i5,3f10.5)')
6657 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6658 c                enddo
6659                   if (energy_dec.and.wcorr5.gt.0.0d0)
6660      1                 write (iout,'(a6,4i5,0pf7.3)')
6661      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6662 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6663 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6664                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6665      &               .or. wturn6.eq.0.0d0))then
6666 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6667                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6668                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6669      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6670 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6671 cd     &            'ecorr6=',ecorr6
6672 cd                write (iout,'(4e15.5)') sred_geom,
6673 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6674 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6675 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6676                 else if (wturn6.gt.0.0d0
6677      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6678 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6679                   eturn6=eturn6+eello_turn6(i,jj,kk)
6680                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6681      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6682 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6683                 endif
6684               ENDIF
6685 1111          continue
6686             endif
6687           enddo ! kk
6688         enddo ! jj
6689       enddo ! i
6690       do i=1,nres
6691         num_cont_hb(i)=num_cont_hb_old(i)
6692       enddo
6693 c                write (iout,*) "gradcorr5 in eello5"
6694 c                do iii=1,nres
6695 c                  write (iout,'(i5,3f10.5)')
6696 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6697 c                enddo
6698       return
6699       end
6700 c------------------------------------------------------------------------------
6701       subroutine add_hb_contact_eello(ii,jj,itask)
6702       implicit real*8 (a-h,o-z)
6703       include "DIMENSIONS"
6704       include "COMMON.IOUNITS"
6705       integer max_cont
6706       integer max_dim
6707       parameter (max_cont=maxconts)
6708       parameter (max_dim=70)
6709       include "COMMON.CONTACTS"
6710       double precision zapas(max_dim,maxconts,max_fg_procs),
6711      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6712       common /przechowalnia/ zapas
6713       integer i,j,ii,jj,iproc,itask(4),nn
6714 c      write (iout,*) "itask",itask
6715       do i=1,2
6716         iproc=itask(i)
6717         if (iproc.gt.0) then
6718           do j=1,num_cont_hb(ii)
6719             jjc=jcont_hb(j,ii)
6720 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6721             if (jjc.eq.jj) then
6722               ncont_sent(iproc)=ncont_sent(iproc)+1
6723               nn=ncont_sent(iproc)
6724               zapas(1,nn,iproc)=ii
6725               zapas(2,nn,iproc)=jjc
6726               zapas(3,nn,iproc)=d_cont(j,ii)
6727               ind=3
6728               do kk=1,3
6729                 ind=ind+1
6730                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6731               enddo
6732               do kk=1,2
6733                 do ll=1,2
6734                   ind=ind+1
6735                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6736                 enddo
6737               enddo
6738               do jj=1,5
6739                 do kk=1,3
6740                   do ll=1,2
6741                     do mm=1,2
6742                       ind=ind+1
6743                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6744                     enddo
6745                   enddo
6746                 enddo
6747               enddo
6748               exit
6749             endif
6750           enddo
6751         endif
6752       enddo
6753       return
6754       end
6755 c------------------------------------------------------------------------------
6756       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6757       implicit real*8 (a-h,o-z)
6758       include 'DIMENSIONS'
6759       include 'COMMON.IOUNITS'
6760       include 'COMMON.DERIV'
6761       include 'COMMON.INTERACT'
6762       include 'COMMON.CONTACTS'
6763       double precision gx(3),gx1(3)
6764       logical lprn
6765       lprn=.false.
6766       eij=facont_hb(jj,i)
6767       ekl=facont_hb(kk,k)
6768       ees0pij=ees0p(jj,i)
6769       ees0pkl=ees0p(kk,k)
6770       ees0mij=ees0m(jj,i)
6771       ees0mkl=ees0m(kk,k)
6772       ekont=eij*ekl
6773       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6774 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6775 C Following 4 lines for diagnostics.
6776 cd    ees0pkl=0.0D0
6777 cd    ees0pij=1.0D0
6778 cd    ees0mkl=0.0D0
6779 cd    ees0mij=1.0D0
6780 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6781 c     & 'Contacts ',i,j,
6782 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6783 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6784 c     & 'gradcorr_long'
6785 C Calculate the multi-body contribution to energy.
6786 c      ecorr=ecorr+ekont*ees
6787 C Calculate multi-body contributions to the gradient.
6788       coeffpees0pij=coeffp*ees0pij
6789       coeffmees0mij=coeffm*ees0mij
6790       coeffpees0pkl=coeffp*ees0pkl
6791       coeffmees0mkl=coeffm*ees0mkl
6792       do ll=1,3
6793 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6794         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6795      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6796      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6797         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6798      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6799      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6800 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6801         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6802      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6803      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6804         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6805      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6806      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6807         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6808      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6809      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6810         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6811         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6812         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6813      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6814      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6815         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6816         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6817 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6818       enddo
6819 c      write (iout,*)
6820 cgrad      do m=i+1,j-1
6821 cgrad        do ll=1,3
6822 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6823 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6824 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6825 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6826 cgrad        enddo
6827 cgrad      enddo
6828 cgrad      do m=k+1,l-1
6829 cgrad        do ll=1,3
6830 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6831 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6832 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6833 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6834 cgrad        enddo
6835 cgrad      enddo
6836 c      write (iout,*) "ehbcorr",ekont*ees
6837       ehbcorr=ekont*ees
6838       return
6839       end
6840 #ifdef MOMENT
6841 C---------------------------------------------------------------------------
6842       subroutine dipole(i,j,jj)
6843       implicit real*8 (a-h,o-z)
6844       include 'DIMENSIONS'
6845       include 'COMMON.IOUNITS'
6846       include 'COMMON.CHAIN'
6847       include 'COMMON.FFIELD'
6848       include 'COMMON.DERIV'
6849       include 'COMMON.INTERACT'
6850       include 'COMMON.CONTACTS'
6851       include 'COMMON.TORSION'
6852       include 'COMMON.VAR'
6853       include 'COMMON.GEO'
6854       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6855      &  auxmat(2,2)
6856       iti1 = itortyp(itype(i+1))
6857       if (j.lt.nres-1) then
6858         itj1 = itortyp(itype(j+1))
6859       else
6860         itj1=ntortyp+1
6861       endif
6862       do iii=1,2
6863         dipi(iii,1)=Ub2(iii,i)
6864         dipderi(iii)=Ub2der(iii,i)
6865         dipi(iii,2)=b1(iii,iti1)
6866         dipj(iii,1)=Ub2(iii,j)
6867         dipderj(iii)=Ub2der(iii,j)
6868         dipj(iii,2)=b1(iii,itj1)
6869       enddo
6870       kkk=0
6871       do iii=1,2
6872         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6873         do jjj=1,2
6874           kkk=kkk+1
6875           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6876         enddo
6877       enddo
6878       do kkk=1,5
6879         do lll=1,3
6880           mmm=0
6881           do iii=1,2
6882             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6883      &        auxvec(1))
6884             do jjj=1,2
6885               mmm=mmm+1
6886               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6887             enddo
6888           enddo
6889         enddo
6890       enddo
6891       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6892       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6893       do iii=1,2
6894         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6895       enddo
6896       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6897       do iii=1,2
6898         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6899       enddo
6900       return
6901       end
6902 #endif
6903 C---------------------------------------------------------------------------
6904       subroutine calc_eello(i,j,k,l,jj,kk)
6905 C
6906 C This subroutine computes matrices and vectors needed to calculate
6907 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6908 C
6909       implicit real*8 (a-h,o-z)
6910       include 'DIMENSIONS'
6911       include 'COMMON.IOUNITS'
6912       include 'COMMON.CHAIN'
6913       include 'COMMON.DERIV'
6914       include 'COMMON.INTERACT'
6915       include 'COMMON.CONTACTS'
6916       include 'COMMON.TORSION'
6917       include 'COMMON.VAR'
6918       include 'COMMON.GEO'
6919       include 'COMMON.FFIELD'
6920       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6921      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6922       logical lprn
6923       common /kutas/ lprn
6924 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6925 cd     & ' jj=',jj,' kk=',kk
6926 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6927 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6928 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6929       do iii=1,2
6930         do jjj=1,2
6931           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6932           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6933         enddo
6934       enddo
6935       call transpose2(aa1(1,1),aa1t(1,1))
6936       call transpose2(aa2(1,1),aa2t(1,1))
6937       do kkk=1,5
6938         do lll=1,3
6939           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6940      &      aa1tder(1,1,lll,kkk))
6941           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6942      &      aa2tder(1,1,lll,kkk))
6943         enddo
6944       enddo
6945       if (l.eq.j+1) then
6946 C parallel orientation of the two CA-CA-CA frames.
6947         if (i.gt.1) then
6948           iti=itortyp(itype(i))
6949         else
6950           iti=ntortyp+1
6951         endif
6952         itk1=itortyp(itype(k+1))
6953         itj=itortyp(itype(j))
6954         if (l.lt.nres-1) then
6955           itl1=itortyp(itype(l+1))
6956         else
6957           itl1=ntortyp+1
6958         endif
6959 C A1 kernel(j+1) A2T
6960 cd        do iii=1,2
6961 cd          write (iout,'(3f10.5,5x,3f10.5)')
6962 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6963 cd        enddo
6964         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6965      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6966      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6967 C Following matrices are needed only for 6-th order cumulants
6968         IF (wcorr6.gt.0.0d0) THEN
6969         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6970      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6971      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6972         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6973      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6974      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6975      &   ADtEAderx(1,1,1,1,1,1))
6976         lprn=.false.
6977         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6978      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6979      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6980      &   ADtEA1derx(1,1,1,1,1,1))
6981         ENDIF
6982 C End 6-th order cumulants
6983 cd        lprn=.false.
6984 cd        if (lprn) then
6985 cd        write (2,*) 'In calc_eello6'
6986 cd        do iii=1,2
6987 cd          write (2,*) 'iii=',iii
6988 cd          do kkk=1,5
6989 cd            write (2,*) 'kkk=',kkk
6990 cd            do jjj=1,2
6991 cd              write (2,'(3(2f10.5),5x)')
6992 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6993 cd            enddo
6994 cd          enddo
6995 cd        enddo
6996 cd        endif
6997         call transpose2(EUgder(1,1,k),auxmat(1,1))
6998         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6999         call transpose2(EUg(1,1,k),auxmat(1,1))
7000         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7001         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7002         do iii=1,2
7003           do kkk=1,5
7004             do lll=1,3
7005               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7006      &          EAEAderx(1,1,lll,kkk,iii,1))
7007             enddo
7008           enddo
7009         enddo
7010 C A1T kernel(i+1) A2
7011         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7012      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7013      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7014 C Following matrices are needed only for 6-th order cumulants
7015         IF (wcorr6.gt.0.0d0) THEN
7016         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7017      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7018      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7019         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7020      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7021      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7022      &   ADtEAderx(1,1,1,1,1,2))
7023         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7024      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7025      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7026      &   ADtEA1derx(1,1,1,1,1,2))
7027         ENDIF
7028 C End 6-th order cumulants
7029         call transpose2(EUgder(1,1,l),auxmat(1,1))
7030         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7031         call transpose2(EUg(1,1,l),auxmat(1,1))
7032         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7033         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7034         do iii=1,2
7035           do kkk=1,5
7036             do lll=1,3
7037               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7038      &          EAEAderx(1,1,lll,kkk,iii,2))
7039             enddo
7040           enddo
7041         enddo
7042 C AEAb1 and AEAb2
7043 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7044 C They are needed only when the fifth- or the sixth-order cumulants are
7045 C indluded.
7046         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7047         call transpose2(AEA(1,1,1),auxmat(1,1))
7048         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7049         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7050         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7051         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7052         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7053         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7054         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7055         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7056         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7057         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7058         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7059         call transpose2(AEA(1,1,2),auxmat(1,1))
7060         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7061         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7062         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7063         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7064         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7065         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7066         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7067         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7068         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7069         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7070         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7071 C Calculate the Cartesian derivatives of the vectors.
7072         do iii=1,2
7073           do kkk=1,5
7074             do lll=1,3
7075               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7076               call matvec2(auxmat(1,1),b1(1,iti),
7077      &          AEAb1derx(1,lll,kkk,iii,1,1))
7078               call matvec2(auxmat(1,1),Ub2(1,i),
7079      &          AEAb2derx(1,lll,kkk,iii,1,1))
7080               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7081      &          AEAb1derx(1,lll,kkk,iii,2,1))
7082               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7083      &          AEAb2derx(1,lll,kkk,iii,2,1))
7084               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7085               call matvec2(auxmat(1,1),b1(1,itj),
7086      &          AEAb1derx(1,lll,kkk,iii,1,2))
7087               call matvec2(auxmat(1,1),Ub2(1,j),
7088      &          AEAb2derx(1,lll,kkk,iii,1,2))
7089               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7090      &          AEAb1derx(1,lll,kkk,iii,2,2))
7091               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7092      &          AEAb2derx(1,lll,kkk,iii,2,2))
7093             enddo
7094           enddo
7095         enddo
7096         ENDIF
7097 C End vectors
7098       else
7099 C Antiparallel orientation of the two CA-CA-CA frames.
7100         if (i.gt.1) then
7101           iti=itortyp(itype(i))
7102         else
7103           iti=ntortyp+1
7104         endif
7105         itk1=itortyp(itype(k+1))
7106         itl=itortyp(itype(l))
7107         itj=itortyp(itype(j))
7108         if (j.lt.nres-1) then
7109           itj1=itortyp(itype(j+1))
7110         else
7111           itj1=ntortyp+1
7112         endif
7113 C A2 kernel(j-1)T A1T
7114         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7115      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7116      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7117 C Following matrices are needed only for 6-th order cumulants
7118         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7119      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7120         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7121      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7122      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7123         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7124      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7125      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7126      &   ADtEAderx(1,1,1,1,1,1))
7127         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7128      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7129      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7130      &   ADtEA1derx(1,1,1,1,1,1))
7131         ENDIF
7132 C End 6-th order cumulants
7133         call transpose2(EUgder(1,1,k),auxmat(1,1))
7134         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7135         call transpose2(EUg(1,1,k),auxmat(1,1))
7136         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7137         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7138         do iii=1,2
7139           do kkk=1,5
7140             do lll=1,3
7141               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7142      &          EAEAderx(1,1,lll,kkk,iii,1))
7143             enddo
7144           enddo
7145         enddo
7146 C A2T kernel(i+1)T A1
7147         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7148      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7149      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7150 C Following matrices are needed only for 6-th order cumulants
7151         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7152      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7153         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7154      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7155      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7156         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7157      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7158      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7159      &   ADtEAderx(1,1,1,1,1,2))
7160         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7161      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7162      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7163      &   ADtEA1derx(1,1,1,1,1,2))
7164         ENDIF
7165 C End 6-th order cumulants
7166         call transpose2(EUgder(1,1,j),auxmat(1,1))
7167         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7168         call transpose2(EUg(1,1,j),auxmat(1,1))
7169         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7170         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7171         do iii=1,2
7172           do kkk=1,5
7173             do lll=1,3
7174               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7175      &          EAEAderx(1,1,lll,kkk,iii,2))
7176             enddo
7177           enddo
7178         enddo
7179 C AEAb1 and AEAb2
7180 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7181 C They are needed only when the fifth- or the sixth-order cumulants are
7182 C indluded.
7183         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7184      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7185         call transpose2(AEA(1,1,1),auxmat(1,1))
7186         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7187         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7188         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7189         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7190         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7191         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7192         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7193         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7194         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7195         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7196         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7197         call transpose2(AEA(1,1,2),auxmat(1,1))
7198         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7199         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7200         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7201         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7202         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7203         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7204         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7205         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7206         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7207         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7208         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7209 C Calculate the Cartesian derivatives of the vectors.
7210         do iii=1,2
7211           do kkk=1,5
7212             do lll=1,3
7213               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7214               call matvec2(auxmat(1,1),b1(1,iti),
7215      &          AEAb1derx(1,lll,kkk,iii,1,1))
7216               call matvec2(auxmat(1,1),Ub2(1,i),
7217      &          AEAb2derx(1,lll,kkk,iii,1,1))
7218               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7219      &          AEAb1derx(1,lll,kkk,iii,2,1))
7220               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7221      &          AEAb2derx(1,lll,kkk,iii,2,1))
7222               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7223               call matvec2(auxmat(1,1),b1(1,itl),
7224      &          AEAb1derx(1,lll,kkk,iii,1,2))
7225               call matvec2(auxmat(1,1),Ub2(1,l),
7226      &          AEAb2derx(1,lll,kkk,iii,1,2))
7227               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7228      &          AEAb1derx(1,lll,kkk,iii,2,2))
7229               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7230      &          AEAb2derx(1,lll,kkk,iii,2,2))
7231             enddo
7232           enddo
7233         enddo
7234         ENDIF
7235 C End vectors
7236       endif
7237       return
7238       end
7239 C---------------------------------------------------------------------------
7240       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7241      &  KK,KKderg,AKA,AKAderg,AKAderx)
7242       implicit none
7243       integer nderg
7244       logical transp
7245       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7246      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7247      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7248       integer iii,kkk,lll
7249       integer jjj,mmm
7250       logical lprn
7251       common /kutas/ lprn
7252       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7253       do iii=1,nderg
7254         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7255      &    AKAderg(1,1,iii))
7256       enddo
7257 cd      if (lprn) write (2,*) 'In kernel'
7258       do kkk=1,5
7259 cd        if (lprn) write (2,*) 'kkk=',kkk
7260         do lll=1,3
7261           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7262      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7263 cd          if (lprn) then
7264 cd            write (2,*) 'lll=',lll
7265 cd            write (2,*) 'iii=1'
7266 cd            do jjj=1,2
7267 cd              write (2,'(3(2f10.5),5x)')
7268 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7269 cd            enddo
7270 cd          endif
7271           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7272      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7273 cd          if (lprn) then
7274 cd            write (2,*) 'lll=',lll
7275 cd            write (2,*) 'iii=2'
7276 cd            do jjj=1,2
7277 cd              write (2,'(3(2f10.5),5x)')
7278 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7279 cd            enddo
7280 cd          endif
7281         enddo
7282       enddo
7283       return
7284       end
7285 C---------------------------------------------------------------------------
7286       double precision function eello4(i,j,k,l,jj,kk)
7287       implicit real*8 (a-h,o-z)
7288       include 'DIMENSIONS'
7289       include 'COMMON.IOUNITS'
7290       include 'COMMON.CHAIN'
7291       include 'COMMON.DERIV'
7292       include 'COMMON.INTERACT'
7293       include 'COMMON.CONTACTS'
7294       include 'COMMON.TORSION'
7295       include 'COMMON.VAR'
7296       include 'COMMON.GEO'
7297       double precision pizda(2,2),ggg1(3),ggg2(3)
7298 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7299 cd        eello4=0.0d0
7300 cd        return
7301 cd      endif
7302 cd      print *,'eello4:',i,j,k,l,jj,kk
7303 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7304 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7305 cold      eij=facont_hb(jj,i)
7306 cold      ekl=facont_hb(kk,k)
7307 cold      ekont=eij*ekl
7308       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7309 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7310       gcorr_loc(k-1)=gcorr_loc(k-1)
7311      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7312       if (l.eq.j+1) then
7313         gcorr_loc(l-1)=gcorr_loc(l-1)
7314      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7315       else
7316         gcorr_loc(j-1)=gcorr_loc(j-1)
7317      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7318       endif
7319       do iii=1,2
7320         do kkk=1,5
7321           do lll=1,3
7322             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7323      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7324 cd            derx(lll,kkk,iii)=0.0d0
7325           enddo
7326         enddo
7327       enddo
7328 cd      gcorr_loc(l-1)=0.0d0
7329 cd      gcorr_loc(j-1)=0.0d0
7330 cd      gcorr_loc(k-1)=0.0d0
7331 cd      eel4=1.0d0
7332 cd      write (iout,*)'Contacts have occurred for peptide groups',
7333 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7334 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7335       if (j.lt.nres-1) then
7336         j1=j+1
7337         j2=j-1
7338       else
7339         j1=j-1
7340         j2=j-2
7341       endif
7342       if (l.lt.nres-1) then
7343         l1=l+1
7344         l2=l-1
7345       else
7346         l1=l-1
7347         l2=l-2
7348       endif
7349       do ll=1,3
7350 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7351 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7352         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7353         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7354 cgrad        ghalf=0.5d0*ggg1(ll)
7355         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7356         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7357         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7358         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7359         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7360         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7361 cgrad        ghalf=0.5d0*ggg2(ll)
7362         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7363         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7364         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7365         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7366         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7367         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7368       enddo
7369 cgrad      do m=i+1,j-1
7370 cgrad        do ll=1,3
7371 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7372 cgrad        enddo
7373 cgrad      enddo
7374 cgrad      do m=k+1,l-1
7375 cgrad        do ll=1,3
7376 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7377 cgrad        enddo
7378 cgrad      enddo
7379 cgrad      do m=i+2,j2
7380 cgrad        do ll=1,3
7381 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7382 cgrad        enddo
7383 cgrad      enddo
7384 cgrad      do m=k+2,l2
7385 cgrad        do ll=1,3
7386 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7387 cgrad        enddo
7388 cgrad      enddo
7389 cd      do iii=1,nres-3
7390 cd        write (2,*) iii,gcorr_loc(iii)
7391 cd      enddo
7392       eello4=ekont*eel4
7393 cd      write (2,*) 'ekont',ekont
7394 cd      write (iout,*) 'eello4',ekont*eel4
7395       return
7396       end
7397 C---------------------------------------------------------------------------
7398       double precision function eello5(i,j,k,l,jj,kk)
7399       implicit real*8 (a-h,o-z)
7400       include 'DIMENSIONS'
7401       include 'COMMON.IOUNITS'
7402       include 'COMMON.CHAIN'
7403       include 'COMMON.DERIV'
7404       include 'COMMON.INTERACT'
7405       include 'COMMON.CONTACTS'
7406       include 'COMMON.TORSION'
7407       include 'COMMON.VAR'
7408       include 'COMMON.GEO'
7409       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7410       double precision ggg1(3),ggg2(3)
7411 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7412 C                                                                              C
7413 C                            Parallel chains                                   C
7414 C                                                                              C
7415 C          o             o                   o             o                   C
7416 C         /l\           / \             \   / \           / \   /              C
7417 C        /   \         /   \             \ /   \         /   \ /               C
7418 C       j| o |l1       | o |              o| o |         | o |o                C
7419 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7420 C      \i/   \         /   \ /             /   \         /   \                 C
7421 C       o    k1             o                                                  C
7422 C         (I)          (II)                (III)          (IV)                 C
7423 C                                                                              C
7424 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7425 C                                                                              C
7426 C                            Antiparallel chains                               C
7427 C                                                                              C
7428 C          o             o                   o             o                   C
7429 C         /j\           / \             \   / \           / \   /              C
7430 C        /   \         /   \             \ /   \         /   \ /               C
7431 C      j1| o |l        | o |              o| o |         | o |o                C
7432 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7433 C      \i/   \         /   \ /             /   \         /   \                 C
7434 C       o     k1            o                                                  C
7435 C         (I)          (II)                (III)          (IV)                 C
7436 C                                                                              C
7437 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7438 C                                                                              C
7439 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7440 C                                                                              C
7441 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7442 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7443 cd        eello5=0.0d0
7444 cd        return
7445 cd      endif
7446 cd      write (iout,*)
7447 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7448 cd     &   ' and',k,l
7449       itk=itortyp(itype(k))
7450       itl=itortyp(itype(l))
7451       itj=itortyp(itype(j))
7452       eello5_1=0.0d0
7453       eello5_2=0.0d0
7454       eello5_3=0.0d0
7455       eello5_4=0.0d0
7456 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7457 cd     &   eel5_3_num,eel5_4_num)
7458       do iii=1,2
7459         do kkk=1,5
7460           do lll=1,3
7461             derx(lll,kkk,iii)=0.0d0
7462           enddo
7463         enddo
7464       enddo
7465 cd      eij=facont_hb(jj,i)
7466 cd      ekl=facont_hb(kk,k)
7467 cd      ekont=eij*ekl
7468 cd      write (iout,*)'Contacts have occurred for peptide groups',
7469 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7470 cd      goto 1111
7471 C Contribution from the graph I.
7472 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7473 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7474       call transpose2(EUg(1,1,k),auxmat(1,1))
7475       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7476       vv(1)=pizda(1,1)-pizda(2,2)
7477       vv(2)=pizda(1,2)+pizda(2,1)
7478       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7479      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7480 C Explicit gradient in virtual-dihedral angles.
7481       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7482      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7483      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7484       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7485       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7486       vv(1)=pizda(1,1)-pizda(2,2)
7487       vv(2)=pizda(1,2)+pizda(2,1)
7488       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7489      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7490      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7491       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7492       vv(1)=pizda(1,1)-pizda(2,2)
7493       vv(2)=pizda(1,2)+pizda(2,1)
7494       if (l.eq.j+1) then
7495         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7496      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7497      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7498       else
7499         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7500      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7501      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7502       endif
7503 C Cartesian gradient
7504       do iii=1,2
7505         do kkk=1,5
7506           do lll=1,3
7507             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7508      &        pizda(1,1))
7509             vv(1)=pizda(1,1)-pizda(2,2)
7510             vv(2)=pizda(1,2)+pizda(2,1)
7511             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7512      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7513      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7514           enddo
7515         enddo
7516       enddo
7517 c      goto 1112
7518 c1111  continue
7519 C Contribution from graph II
7520       call transpose2(EE(1,1,itk),auxmat(1,1))
7521       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7522       vv(1)=pizda(1,1)+pizda(2,2)
7523       vv(2)=pizda(2,1)-pizda(1,2)
7524       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7525      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7526 C Explicit gradient in virtual-dihedral angles.
7527       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7528      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7529       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7530       vv(1)=pizda(1,1)+pizda(2,2)
7531       vv(2)=pizda(2,1)-pizda(1,2)
7532       if (l.eq.j+1) then
7533         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7534      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7535      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7536       else
7537         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7538      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7539      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7540       endif
7541 C Cartesian gradient
7542       do iii=1,2
7543         do kkk=1,5
7544           do lll=1,3
7545             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7546      &        pizda(1,1))
7547             vv(1)=pizda(1,1)+pizda(2,2)
7548             vv(2)=pizda(2,1)-pizda(1,2)
7549             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7550      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7551      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7552           enddo
7553         enddo
7554       enddo
7555 cd      goto 1112
7556 cd1111  continue
7557       if (l.eq.j+1) then
7558 cd        goto 1110
7559 C Parallel orientation
7560 C Contribution from graph III
7561         call transpose2(EUg(1,1,l),auxmat(1,1))
7562         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7563         vv(1)=pizda(1,1)-pizda(2,2)
7564         vv(2)=pizda(1,2)+pizda(2,1)
7565         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7566      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7567 C Explicit gradient in virtual-dihedral angles.
7568         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7569      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7570      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7571         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7572         vv(1)=pizda(1,1)-pizda(2,2)
7573         vv(2)=pizda(1,2)+pizda(2,1)
7574         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7575      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7576      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7577         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7578         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7579         vv(1)=pizda(1,1)-pizda(2,2)
7580         vv(2)=pizda(1,2)+pizda(2,1)
7581         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7582      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7583      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7584 C Cartesian gradient
7585         do iii=1,2
7586           do kkk=1,5
7587             do lll=1,3
7588               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7589      &          pizda(1,1))
7590               vv(1)=pizda(1,1)-pizda(2,2)
7591               vv(2)=pizda(1,2)+pizda(2,1)
7592               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7593      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7594      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7595             enddo
7596           enddo
7597         enddo
7598 cd        goto 1112
7599 C Contribution from graph IV
7600 cd1110    continue
7601         call transpose2(EE(1,1,itl),auxmat(1,1))
7602         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7603         vv(1)=pizda(1,1)+pizda(2,2)
7604         vv(2)=pizda(2,1)-pizda(1,2)
7605         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7606      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7607 C Explicit gradient in virtual-dihedral angles.
7608         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7609      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7610         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7611         vv(1)=pizda(1,1)+pizda(2,2)
7612         vv(2)=pizda(2,1)-pizda(1,2)
7613         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7614      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7615      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7616 C Cartesian gradient
7617         do iii=1,2
7618           do kkk=1,5
7619             do lll=1,3
7620               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7621      &          pizda(1,1))
7622               vv(1)=pizda(1,1)+pizda(2,2)
7623               vv(2)=pizda(2,1)-pizda(1,2)
7624               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7625      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7626      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7627             enddo
7628           enddo
7629         enddo
7630       else
7631 C Antiparallel orientation
7632 C Contribution from graph III
7633 c        goto 1110
7634         call transpose2(EUg(1,1,j),auxmat(1,1))
7635         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7636         vv(1)=pizda(1,1)-pizda(2,2)
7637         vv(2)=pizda(1,2)+pizda(2,1)
7638         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7639      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7640 C Explicit gradient in virtual-dihedral angles.
7641         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7642      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7643      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7644         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7645         vv(1)=pizda(1,1)-pizda(2,2)
7646         vv(2)=pizda(1,2)+pizda(2,1)
7647         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7648      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7649      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7650         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7651         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7652         vv(1)=pizda(1,1)-pizda(2,2)
7653         vv(2)=pizda(1,2)+pizda(2,1)
7654         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7655      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7656      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7657 C Cartesian gradient
7658         do iii=1,2
7659           do kkk=1,5
7660             do lll=1,3
7661               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7662      &          pizda(1,1))
7663               vv(1)=pizda(1,1)-pizda(2,2)
7664               vv(2)=pizda(1,2)+pizda(2,1)
7665               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7666      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7667      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7668             enddo
7669           enddo
7670         enddo
7671 cd        goto 1112
7672 C Contribution from graph IV
7673 1110    continue
7674         call transpose2(EE(1,1,itj),auxmat(1,1))
7675         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7676         vv(1)=pizda(1,1)+pizda(2,2)
7677         vv(2)=pizda(2,1)-pizda(1,2)
7678         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7679      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7680 C Explicit gradient in virtual-dihedral angles.
7681         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7682      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7683         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7684         vv(1)=pizda(1,1)+pizda(2,2)
7685         vv(2)=pizda(2,1)-pizda(1,2)
7686         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7687      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7688      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7689 C Cartesian gradient
7690         do iii=1,2
7691           do kkk=1,5
7692             do lll=1,3
7693               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7694      &          pizda(1,1))
7695               vv(1)=pizda(1,1)+pizda(2,2)
7696               vv(2)=pizda(2,1)-pizda(1,2)
7697               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7698      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7699      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7700             enddo
7701           enddo
7702         enddo
7703       endif
7704 1112  continue
7705       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7706 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7707 cd        write (2,*) 'ijkl',i,j,k,l
7708 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7709 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7710 cd      endif
7711 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7712 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7713 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7714 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7715       if (j.lt.nres-1) then
7716         j1=j+1
7717         j2=j-1
7718       else
7719         j1=j-1
7720         j2=j-2
7721       endif
7722       if (l.lt.nres-1) then
7723         l1=l+1
7724         l2=l-1
7725       else
7726         l1=l-1
7727         l2=l-2
7728       endif
7729 cd      eij=1.0d0
7730 cd      ekl=1.0d0
7731 cd      ekont=1.0d0
7732 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7733 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7734 C        summed up outside the subrouine as for the other subroutines
7735 C        handling long-range interactions. The old code is commented out
7736 C        with "cgrad" to keep track of changes.
7737       do ll=1,3
7738 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7739 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7740         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7741         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7742 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7743 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7744 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7745 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7746 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7747 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7748 c     &   gradcorr5ij,
7749 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7750 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7751 cgrad        ghalf=0.5d0*ggg1(ll)
7752 cd        ghalf=0.0d0
7753         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7754         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7755         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7756         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7757         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7758         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7759 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7760 cgrad        ghalf=0.5d0*ggg2(ll)
7761 cd        ghalf=0.0d0
7762         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7763         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7764         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7765         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7766         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7767         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7768       enddo
7769 cd      goto 1112
7770 cgrad      do m=i+1,j-1
7771 cgrad        do ll=1,3
7772 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7773 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7774 cgrad        enddo
7775 cgrad      enddo
7776 cgrad      do m=k+1,l-1
7777 cgrad        do ll=1,3
7778 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7779 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7780 cgrad        enddo
7781 cgrad      enddo
7782 c1112  continue
7783 cgrad      do m=i+2,j2
7784 cgrad        do ll=1,3
7785 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7786 cgrad        enddo
7787 cgrad      enddo
7788 cgrad      do m=k+2,l2
7789 cgrad        do ll=1,3
7790 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7791 cgrad        enddo
7792 cgrad      enddo
7793 cd      do iii=1,nres-3
7794 cd        write (2,*) iii,g_corr5_loc(iii)
7795 cd      enddo
7796       eello5=ekont*eel5
7797 cd      write (2,*) 'ekont',ekont
7798 cd      write (iout,*) 'eello5',ekont*eel5
7799       return
7800       end
7801 c--------------------------------------------------------------------------
7802       double precision function eello6(i,j,k,l,jj,kk)
7803       implicit real*8 (a-h,o-z)
7804       include 'DIMENSIONS'
7805       include 'COMMON.IOUNITS'
7806       include 'COMMON.CHAIN'
7807       include 'COMMON.DERIV'
7808       include 'COMMON.INTERACT'
7809       include 'COMMON.CONTACTS'
7810       include 'COMMON.TORSION'
7811       include 'COMMON.VAR'
7812       include 'COMMON.GEO'
7813       include 'COMMON.FFIELD'
7814       double precision ggg1(3),ggg2(3)
7815 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7816 cd        eello6=0.0d0
7817 cd        return
7818 cd      endif
7819 cd      write (iout,*)
7820 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7821 cd     &   ' and',k,l
7822       eello6_1=0.0d0
7823       eello6_2=0.0d0
7824       eello6_3=0.0d0
7825       eello6_4=0.0d0
7826       eello6_5=0.0d0
7827       eello6_6=0.0d0
7828 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7829 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7830       do iii=1,2
7831         do kkk=1,5
7832           do lll=1,3
7833             derx(lll,kkk,iii)=0.0d0
7834           enddo
7835         enddo
7836       enddo
7837 cd      eij=facont_hb(jj,i)
7838 cd      ekl=facont_hb(kk,k)
7839 cd      ekont=eij*ekl
7840 cd      eij=1.0d0
7841 cd      ekl=1.0d0
7842 cd      ekont=1.0d0
7843       if (l.eq.j+1) then
7844         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7845         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7846         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7847         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7848         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7849         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7850       else
7851         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7852         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7853         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7854         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7855         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7856           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7857         else
7858           eello6_5=0.0d0
7859         endif
7860         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7861       endif
7862 C If turn contributions are considered, they will be handled separately.
7863       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7864 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7865 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7866 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7867 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7868 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7869 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7870 cd      goto 1112
7871       if (j.lt.nres-1) then
7872         j1=j+1
7873         j2=j-1
7874       else
7875         j1=j-1
7876         j2=j-2
7877       endif
7878       if (l.lt.nres-1) then
7879         l1=l+1
7880         l2=l-1
7881       else
7882         l1=l-1
7883         l2=l-2
7884       endif
7885       do ll=1,3
7886 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7887 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7888 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7889 cgrad        ghalf=0.5d0*ggg1(ll)
7890 cd        ghalf=0.0d0
7891         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7892         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7893         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7894         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7895         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7896         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7897         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7898         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7899 cgrad        ghalf=0.5d0*ggg2(ll)
7900 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7901 cd        ghalf=0.0d0
7902         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7903         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7904         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7905         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7906         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7907         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7908       enddo
7909 cd      goto 1112
7910 cgrad      do m=i+1,j-1
7911 cgrad        do ll=1,3
7912 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7913 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7914 cgrad        enddo
7915 cgrad      enddo
7916 cgrad      do m=k+1,l-1
7917 cgrad        do ll=1,3
7918 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7919 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7920 cgrad        enddo
7921 cgrad      enddo
7922 cgrad1112  continue
7923 cgrad      do m=i+2,j2
7924 cgrad        do ll=1,3
7925 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7926 cgrad        enddo
7927 cgrad      enddo
7928 cgrad      do m=k+2,l2
7929 cgrad        do ll=1,3
7930 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7931 cgrad        enddo
7932 cgrad      enddo
7933 cd      do iii=1,nres-3
7934 cd        write (2,*) iii,g_corr6_loc(iii)
7935 cd      enddo
7936       eello6=ekont*eel6
7937 cd      write (2,*) 'ekont',ekont
7938 cd      write (iout,*) 'eello6',ekont*eel6
7939       return
7940       end
7941 c--------------------------------------------------------------------------
7942       double precision function eello6_graph1(i,j,k,l,imat,swap)
7943       implicit real*8 (a-h,o-z)
7944       include 'DIMENSIONS'
7945       include 'COMMON.IOUNITS'
7946       include 'COMMON.CHAIN'
7947       include 'COMMON.DERIV'
7948       include 'COMMON.INTERACT'
7949       include 'COMMON.CONTACTS'
7950       include 'COMMON.TORSION'
7951       include 'COMMON.VAR'
7952       include 'COMMON.GEO'
7953       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7954       logical swap
7955       logical lprn
7956       common /kutas/ lprn
7957 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7958 C                                                                              C
7959 C      Parallel       Antiparallel                                             C
7960 C                                                                              C
7961 C          o             o                                                     C
7962 C         /l\           /j\                                                    C
7963 C        /   \         /   \                                                   C
7964 C       /| o |         | o |\                                                  C
7965 C     \ j|/k\|  /   \  |/k\|l /                                                C
7966 C      \ /   \ /     \ /   \ /                                                 C
7967 C       o     o       o     o                                                  C
7968 C       i             i                                                        C
7969 C                                                                              C
7970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7971       itk=itortyp(itype(k))
7972       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7973       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7974       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7975       call transpose2(EUgC(1,1,k),auxmat(1,1))
7976       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7977       vv1(1)=pizda1(1,1)-pizda1(2,2)
7978       vv1(2)=pizda1(1,2)+pizda1(2,1)
7979       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7980       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7981       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7982       s5=scalar2(vv(1),Dtobr2(1,i))
7983 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7984       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7985       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7986      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7987      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7988      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7989      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7990      & +scalar2(vv(1),Dtobr2der(1,i)))
7991       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7992       vv1(1)=pizda1(1,1)-pizda1(2,2)
7993       vv1(2)=pizda1(1,2)+pizda1(2,1)
7994       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7995       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7996       if (l.eq.j+1) then
7997         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7998      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7999      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8000      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8001      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8002       else
8003         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8004      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8005      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8006      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8007      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8008       endif
8009       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8010       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8011       vv1(1)=pizda1(1,1)-pizda1(2,2)
8012       vv1(2)=pizda1(1,2)+pizda1(2,1)
8013       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8014      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8015      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8016      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8017       do iii=1,2
8018         if (swap) then
8019           ind=3-iii
8020         else
8021           ind=iii
8022         endif
8023         do kkk=1,5
8024           do lll=1,3
8025             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8026             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8027             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8028             call transpose2(EUgC(1,1,k),auxmat(1,1))
8029             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8030      &        pizda1(1,1))
8031             vv1(1)=pizda1(1,1)-pizda1(2,2)
8032             vv1(2)=pizda1(1,2)+pizda1(2,1)
8033             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8034             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8035      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8036             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8037      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8038             s5=scalar2(vv(1),Dtobr2(1,i))
8039             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8040           enddo
8041         enddo
8042       enddo
8043       return
8044       end
8045 c----------------------------------------------------------------------------
8046       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8047       implicit real*8 (a-h,o-z)
8048       include 'DIMENSIONS'
8049       include 'COMMON.IOUNITS'
8050       include 'COMMON.CHAIN'
8051       include 'COMMON.DERIV'
8052       include 'COMMON.INTERACT'
8053       include 'COMMON.CONTACTS'
8054       include 'COMMON.TORSION'
8055       include 'COMMON.VAR'
8056       include 'COMMON.GEO'
8057       logical swap
8058       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8059      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8060       logical lprn
8061       common /kutas/ lprn
8062 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8063 C                                                                              C
8064 C      Parallel       Antiparallel                                             C
8065 C                                                                              C
8066 C          o             o                                                     C
8067 C     \   /l\           /j\   /                                                C
8068 C      \ /   \         /   \ /                                                 C
8069 C       o| o |         | o |o                                                  C
8070 C     \ j|/k\|      \  |/k\|l                                                  C
8071 C      \ /   \       \ /   \                                                   C
8072 C       o             o                                                        C
8073 C       i             i                                                        C
8074 C                                                                              C
8075 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8076 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8077 C AL 7/4/01 s1 would occur in the sixth-order moment,
8078 C           but not in a cluster cumulant
8079 #ifdef MOMENT
8080       s1=dip(1,jj,i)*dip(1,kk,k)
8081 #endif
8082       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8083       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8084       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8085       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8086       call transpose2(EUg(1,1,k),auxmat(1,1))
8087       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8088       vv(1)=pizda(1,1)-pizda(2,2)
8089       vv(2)=pizda(1,2)+pizda(2,1)
8090       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8091 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8092 #ifdef MOMENT
8093       eello6_graph2=-(s1+s2+s3+s4)
8094 #else
8095       eello6_graph2=-(s2+s3+s4)
8096 #endif
8097 c      eello6_graph2=-s3
8098 C Derivatives in gamma(i-1)
8099       if (i.gt.1) then
8100 #ifdef MOMENT
8101         s1=dipderg(1,jj,i)*dip(1,kk,k)
8102 #endif
8103         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8104         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8105         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8106         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8107 #ifdef MOMENT
8108         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8109 #else
8110         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8111 #endif
8112 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8113       endif
8114 C Derivatives in gamma(k-1)
8115 #ifdef MOMENT
8116       s1=dip(1,jj,i)*dipderg(1,kk,k)
8117 #endif
8118       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8119       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8120       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8121       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8122       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8123       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8124       vv(1)=pizda(1,1)-pizda(2,2)
8125       vv(2)=pizda(1,2)+pizda(2,1)
8126       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8127 #ifdef MOMENT
8128       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8129 #else
8130       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8131 #endif
8132 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8133 C Derivatives in gamma(j-1) or gamma(l-1)
8134       if (j.gt.1) then
8135 #ifdef MOMENT
8136         s1=dipderg(3,jj,i)*dip(1,kk,k)
8137 #endif
8138         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8139         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8140         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8141         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8142         vv(1)=pizda(1,1)-pizda(2,2)
8143         vv(2)=pizda(1,2)+pizda(2,1)
8144         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8145 #ifdef MOMENT
8146         if (swap) then
8147           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8148         else
8149           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8150         endif
8151 #endif
8152         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8153 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8154       endif
8155 C Derivatives in gamma(l-1) or gamma(j-1)
8156       if (l.gt.1) then
8157 #ifdef MOMENT
8158         s1=dip(1,jj,i)*dipderg(3,kk,k)
8159 #endif
8160         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8161         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8162         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8163         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8164         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8165         vv(1)=pizda(1,1)-pizda(2,2)
8166         vv(2)=pizda(1,2)+pizda(2,1)
8167         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8168 #ifdef MOMENT
8169         if (swap) then
8170           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8171         else
8172           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8173         endif
8174 #endif
8175         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8176 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8177       endif
8178 C Cartesian derivatives.
8179       if (lprn) then
8180         write (2,*) 'In eello6_graph2'
8181         do iii=1,2
8182           write (2,*) 'iii=',iii
8183           do kkk=1,5
8184             write (2,*) 'kkk=',kkk
8185             do jjj=1,2
8186               write (2,'(3(2f10.5),5x)')
8187      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8188             enddo
8189           enddo
8190         enddo
8191       endif
8192       do iii=1,2
8193         do kkk=1,5
8194           do lll=1,3
8195 #ifdef MOMENT
8196             if (iii.eq.1) then
8197               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8198             else
8199               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8200             endif
8201 #endif
8202             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8203      &        auxvec(1))
8204             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8205             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8206      &        auxvec(1))
8207             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8208             call transpose2(EUg(1,1,k),auxmat(1,1))
8209             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8210      &        pizda(1,1))
8211             vv(1)=pizda(1,1)-pizda(2,2)
8212             vv(2)=pizda(1,2)+pizda(2,1)
8213             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8214 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8215 #ifdef MOMENT
8216             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8217 #else
8218             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8219 #endif
8220             if (swap) then
8221               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8222             else
8223               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8224             endif
8225           enddo
8226         enddo
8227       enddo
8228       return
8229       end
8230 c----------------------------------------------------------------------------
8231       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8232       implicit real*8 (a-h,o-z)
8233       include 'DIMENSIONS'
8234       include 'COMMON.IOUNITS'
8235       include 'COMMON.CHAIN'
8236       include 'COMMON.DERIV'
8237       include 'COMMON.INTERACT'
8238       include 'COMMON.CONTACTS'
8239       include 'COMMON.TORSION'
8240       include 'COMMON.VAR'
8241       include 'COMMON.GEO'
8242       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8243       logical swap
8244 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8245 C                                                                              C
8246 C      Parallel       Antiparallel                                             C
8247 C                                                                              C
8248 C          o             o                                                     C
8249 C         /l\   /   \   /j\                                                    C
8250 C        /   \ /     \ /   \                                                   C
8251 C       /| o |o       o| o |\                                                  C
8252 C       j|/k\|  /      |/k\|l /                                                C
8253 C        /   \ /       /   \ /                                                 C
8254 C       /     o       /     o                                                  C
8255 C       i             i                                                        C
8256 C                                                                              C
8257 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8258 C
8259 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8260 C           energy moment and not to the cluster cumulant.
8261       iti=itortyp(itype(i))
8262       if (j.lt.nres-1) then
8263         itj1=itortyp(itype(j+1))
8264       else
8265         itj1=ntortyp+1
8266       endif
8267       itk=itortyp(itype(k))
8268       itk1=itortyp(itype(k+1))
8269       if (l.lt.nres-1) then
8270         itl1=itortyp(itype(l+1))
8271       else
8272         itl1=ntortyp+1
8273       endif
8274 #ifdef MOMENT
8275       s1=dip(4,jj,i)*dip(4,kk,k)
8276 #endif
8277       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8278       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8279       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8280       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8281       call transpose2(EE(1,1,itk),auxmat(1,1))
8282       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8283       vv(1)=pizda(1,1)+pizda(2,2)
8284       vv(2)=pizda(2,1)-pizda(1,2)
8285       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8286 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8287 cd     & "sum",-(s2+s3+s4)
8288 #ifdef MOMENT
8289       eello6_graph3=-(s1+s2+s3+s4)
8290 #else
8291       eello6_graph3=-(s2+s3+s4)
8292 #endif
8293 c      eello6_graph3=-s4
8294 C Derivatives in gamma(k-1)
8295       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8296       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8297       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8298       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8299 C Derivatives in gamma(l-1)
8300       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8301       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8302       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8303       vv(1)=pizda(1,1)+pizda(2,2)
8304       vv(2)=pizda(2,1)-pizda(1,2)
8305       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8306       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8307 C Cartesian derivatives.
8308       do iii=1,2
8309         do kkk=1,5
8310           do lll=1,3
8311 #ifdef MOMENT
8312             if (iii.eq.1) then
8313               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8314             else
8315               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8316             endif
8317 #endif
8318             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8319      &        auxvec(1))
8320             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8321             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8322      &        auxvec(1))
8323             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8324             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8325      &        pizda(1,1))
8326             vv(1)=pizda(1,1)+pizda(2,2)
8327             vv(2)=pizda(2,1)-pizda(1,2)
8328             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8329 #ifdef MOMENT
8330             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8331 #else
8332             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8333 #endif
8334             if (swap) then
8335               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8336             else
8337               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8338             endif
8339 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8340           enddo
8341         enddo
8342       enddo
8343       return
8344       end
8345 c----------------------------------------------------------------------------
8346       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8347       implicit real*8 (a-h,o-z)
8348       include 'DIMENSIONS'
8349       include 'COMMON.IOUNITS'
8350       include 'COMMON.CHAIN'
8351       include 'COMMON.DERIV'
8352       include 'COMMON.INTERACT'
8353       include 'COMMON.CONTACTS'
8354       include 'COMMON.TORSION'
8355       include 'COMMON.VAR'
8356       include 'COMMON.GEO'
8357       include 'COMMON.FFIELD'
8358       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8359      & auxvec1(2),auxmat1(2,2)
8360       logical swap
8361 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8362 C                                                                              C
8363 C      Parallel       Antiparallel                                             C
8364 C                                                                              C
8365 C          o             o                                                     C
8366 C         /l\   /   \   /j\                                                    C
8367 C        /   \ /     \ /   \                                                   C
8368 C       /| o |o       o| o |\                                                  C
8369 C     \ j|/k\|      \  |/k\|l                                                  C
8370 C      \ /   \       \ /   \                                                   C
8371 C       o     \       o     \                                                  C
8372 C       i             i                                                        C
8373 C                                                                              C
8374 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8375 C
8376 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8377 C           energy moment and not to the cluster cumulant.
8378 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8379       iti=itortyp(itype(i))
8380       itj=itortyp(itype(j))
8381       if (j.lt.nres-1) then
8382         itj1=itortyp(itype(j+1))
8383       else
8384         itj1=ntortyp+1
8385       endif
8386       itk=itortyp(itype(k))
8387       if (k.lt.nres-1) then
8388         itk1=itortyp(itype(k+1))
8389       else
8390         itk1=ntortyp+1
8391       endif
8392       itl=itortyp(itype(l))
8393       if (l.lt.nres-1) then
8394         itl1=itortyp(itype(l+1))
8395       else
8396         itl1=ntortyp+1
8397       endif
8398 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8399 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8400 cd     & ' itl',itl,' itl1',itl1
8401 #ifdef MOMENT
8402       if (imat.eq.1) then
8403         s1=dip(3,jj,i)*dip(3,kk,k)
8404       else
8405         s1=dip(2,jj,j)*dip(2,kk,l)
8406       endif
8407 #endif
8408       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8409       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8410       if (j.eq.l+1) then
8411         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8412         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8413       else
8414         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8415         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8416       endif
8417       call transpose2(EUg(1,1,k),auxmat(1,1))
8418       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8419       vv(1)=pizda(1,1)-pizda(2,2)
8420       vv(2)=pizda(2,1)+pizda(1,2)
8421       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8422 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8423 #ifdef MOMENT
8424       eello6_graph4=-(s1+s2+s3+s4)
8425 #else
8426       eello6_graph4=-(s2+s3+s4)
8427 #endif
8428 C Derivatives in gamma(i-1)
8429       if (i.gt.1) then
8430 #ifdef MOMENT
8431         if (imat.eq.1) then
8432           s1=dipderg(2,jj,i)*dip(3,kk,k)
8433         else
8434           s1=dipderg(4,jj,j)*dip(2,kk,l)
8435         endif
8436 #endif
8437         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8438         if (j.eq.l+1) then
8439           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8440           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8441         else
8442           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8443           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8444         endif
8445         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8446         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8447 cd          write (2,*) 'turn6 derivatives'
8448 #ifdef MOMENT
8449           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8450 #else
8451           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8452 #endif
8453         else
8454 #ifdef MOMENT
8455           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8456 #else
8457           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8458 #endif
8459         endif
8460       endif
8461 C Derivatives in gamma(k-1)
8462 #ifdef MOMENT
8463       if (imat.eq.1) then
8464         s1=dip(3,jj,i)*dipderg(2,kk,k)
8465       else
8466         s1=dip(2,jj,j)*dipderg(4,kk,l)
8467       endif
8468 #endif
8469       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8470       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8471       if (j.eq.l+1) then
8472         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8473         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8474       else
8475         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8476         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8477       endif
8478       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8479       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8480       vv(1)=pizda(1,1)-pizda(2,2)
8481       vv(2)=pizda(2,1)+pizda(1,2)
8482       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8483       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8484 #ifdef MOMENT
8485         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8486 #else
8487         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8488 #endif
8489       else
8490 #ifdef MOMENT
8491         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8492 #else
8493         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8494 #endif
8495       endif
8496 C Derivatives in gamma(j-1) or gamma(l-1)
8497       if (l.eq.j+1 .and. l.gt.1) then
8498         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8499         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8500         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8501         vv(1)=pizda(1,1)-pizda(2,2)
8502         vv(2)=pizda(2,1)+pizda(1,2)
8503         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8504         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8505       else if (j.gt.1) then
8506         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8507         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8508         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8509         vv(1)=pizda(1,1)-pizda(2,2)
8510         vv(2)=pizda(2,1)+pizda(1,2)
8511         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8512         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8513           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8514         else
8515           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8516         endif
8517       endif
8518 C Cartesian derivatives.
8519       do iii=1,2
8520         do kkk=1,5
8521           do lll=1,3
8522 #ifdef MOMENT
8523             if (iii.eq.1) then
8524               if (imat.eq.1) then
8525                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8526               else
8527                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8528               endif
8529             else
8530               if (imat.eq.1) then
8531                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8532               else
8533                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8534               endif
8535             endif
8536 #endif
8537             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8538      &        auxvec(1))
8539             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8540             if (j.eq.l+1) then
8541               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8542      &          b1(1,itj1),auxvec(1))
8543               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8544             else
8545               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8546      &          b1(1,itl1),auxvec(1))
8547               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8548             endif
8549             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8550      &        pizda(1,1))
8551             vv(1)=pizda(1,1)-pizda(2,2)
8552             vv(2)=pizda(2,1)+pizda(1,2)
8553             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8554             if (swap) then
8555               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8556 #ifdef MOMENT
8557                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8558      &             -(s1+s2+s4)
8559 #else
8560                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8561      &             -(s2+s4)
8562 #endif
8563                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8564               else
8565 #ifdef MOMENT
8566                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8567 #else
8568                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8569 #endif
8570                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8571               endif
8572             else
8573 #ifdef MOMENT
8574               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8575 #else
8576               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8577 #endif
8578               if (l.eq.j+1) then
8579                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8580               else
8581                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8582               endif
8583             endif
8584           enddo
8585         enddo
8586       enddo
8587       return
8588       end
8589 c----------------------------------------------------------------------------
8590       double precision function eello_turn6(i,jj,kk)
8591       implicit real*8 (a-h,o-z)
8592       include 'DIMENSIONS'
8593       include 'COMMON.IOUNITS'
8594       include 'COMMON.CHAIN'
8595       include 'COMMON.DERIV'
8596       include 'COMMON.INTERACT'
8597       include 'COMMON.CONTACTS'
8598       include 'COMMON.TORSION'
8599       include 'COMMON.VAR'
8600       include 'COMMON.GEO'
8601       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8602      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8603      &  ggg1(3),ggg2(3)
8604       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8605      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8606 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8607 C           the respective energy moment and not to the cluster cumulant.
8608       s1=0.0d0
8609       s8=0.0d0
8610       s13=0.0d0
8611 c
8612       eello_turn6=0.0d0
8613       j=i+4
8614       k=i+1
8615       l=i+3
8616       iti=itortyp(itype(i))
8617       itk=itortyp(itype(k))
8618       itk1=itortyp(itype(k+1))
8619       itl=itortyp(itype(l))
8620       itj=itortyp(itype(j))
8621 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8622 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8623 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8624 cd        eello6=0.0d0
8625 cd        return
8626 cd      endif
8627 cd      write (iout,*)
8628 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8629 cd     &   ' and',k,l
8630 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8631       do iii=1,2
8632         do kkk=1,5
8633           do lll=1,3
8634             derx_turn(lll,kkk,iii)=0.0d0
8635           enddo
8636         enddo
8637       enddo
8638 cd      eij=1.0d0
8639 cd      ekl=1.0d0
8640 cd      ekont=1.0d0
8641       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8642 cd      eello6_5=0.0d0
8643 cd      write (2,*) 'eello6_5',eello6_5
8644 #ifdef MOMENT
8645       call transpose2(AEA(1,1,1),auxmat(1,1))
8646       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8647       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8648       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8649 #endif
8650       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8651       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8652       s2 = scalar2(b1(1,itk),vtemp1(1))
8653 #ifdef MOMENT
8654       call transpose2(AEA(1,1,2),atemp(1,1))
8655       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8656       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8657       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8658 #endif
8659       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8660       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8661       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8662 #ifdef MOMENT
8663       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8664       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8665       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8666       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8667       ss13 = scalar2(b1(1,itk),vtemp4(1))
8668       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8669 #endif
8670 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8671 c      s1=0.0d0
8672 c      s2=0.0d0
8673 c      s8=0.0d0
8674 c      s12=0.0d0
8675 c      s13=0.0d0
8676       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8677 C Derivatives in gamma(i+2)
8678       s1d =0.0d0
8679       s8d =0.0d0
8680 #ifdef MOMENT
8681       call transpose2(AEA(1,1,1),auxmatd(1,1))
8682       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8683       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8684       call transpose2(AEAderg(1,1,2),atempd(1,1))
8685       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8686       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8687 #endif
8688       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8689       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8690       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8691 c      s1d=0.0d0
8692 c      s2d=0.0d0
8693 c      s8d=0.0d0
8694 c      s12d=0.0d0
8695 c      s13d=0.0d0
8696       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8697 C Derivatives in gamma(i+3)
8698 #ifdef MOMENT
8699       call transpose2(AEA(1,1,1),auxmatd(1,1))
8700       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8701       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8702       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8703 #endif
8704       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8705       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8706       s2d = scalar2(b1(1,itk),vtemp1d(1))
8707 #ifdef MOMENT
8708       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8709       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8710 #endif
8711       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8712 #ifdef MOMENT
8713       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8714       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8715       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8716 #endif
8717 c      s1d=0.0d0
8718 c      s2d=0.0d0
8719 c      s8d=0.0d0
8720 c      s12d=0.0d0
8721 c      s13d=0.0d0
8722 #ifdef MOMENT
8723       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8724      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8725 #else
8726       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8727      &               -0.5d0*ekont*(s2d+s12d)
8728 #endif
8729 C Derivatives in gamma(i+4)
8730       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8731       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8732       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8733 #ifdef MOMENT
8734       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8735       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8736       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8737 #endif
8738 c      s1d=0.0d0
8739 c      s2d=0.0d0
8740 c      s8d=0.0d0
8741 C      s12d=0.0d0
8742 c      s13d=0.0d0
8743 #ifdef MOMENT
8744       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8745 #else
8746       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8747 #endif
8748 C Derivatives in gamma(i+5)
8749 #ifdef MOMENT
8750       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8751       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8752       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8753 #endif
8754       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8755       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8756       s2d = scalar2(b1(1,itk),vtemp1d(1))
8757 #ifdef MOMENT
8758       call transpose2(AEA(1,1,2),atempd(1,1))
8759       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8760       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8761 #endif
8762       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8763       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8764 #ifdef MOMENT
8765       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8766       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8767       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8768 #endif
8769 c      s1d=0.0d0
8770 c      s2d=0.0d0
8771 c      s8d=0.0d0
8772 c      s12d=0.0d0
8773 c      s13d=0.0d0
8774 #ifdef MOMENT
8775       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8776      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8777 #else
8778       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8779      &               -0.5d0*ekont*(s2d+s12d)
8780 #endif
8781 C Cartesian derivatives
8782       do iii=1,2
8783         do kkk=1,5
8784           do lll=1,3
8785 #ifdef MOMENT
8786             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8787             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8788             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8789 #endif
8790             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8791             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8792      &          vtemp1d(1))
8793             s2d = scalar2(b1(1,itk),vtemp1d(1))
8794 #ifdef MOMENT
8795             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8796             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8797             s8d = -(atempd(1,1)+atempd(2,2))*
8798      &           scalar2(cc(1,1,itl),vtemp2(1))
8799 #endif
8800             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8801      &           auxmatd(1,1))
8802             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8803             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8804 c      s1d=0.0d0
8805 c      s2d=0.0d0
8806 c      s8d=0.0d0
8807 c      s12d=0.0d0
8808 c      s13d=0.0d0
8809 #ifdef MOMENT
8810             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8811      &        - 0.5d0*(s1d+s2d)
8812 #else
8813             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8814      &        - 0.5d0*s2d
8815 #endif
8816 #ifdef MOMENT
8817             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8818      &        - 0.5d0*(s8d+s12d)
8819 #else
8820             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8821      &        - 0.5d0*s12d
8822 #endif
8823           enddo
8824         enddo
8825       enddo
8826 #ifdef MOMENT
8827       do kkk=1,5
8828         do lll=1,3
8829           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8830      &      achuj_tempd(1,1))
8831           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8832           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8833           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8834           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8835           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8836      &      vtemp4d(1))
8837           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8838           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8839           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8840         enddo
8841       enddo
8842 #endif
8843 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8844 cd     &  16*eel_turn6_num
8845 cd      goto 1112
8846       if (j.lt.nres-1) then
8847         j1=j+1
8848         j2=j-1
8849       else
8850         j1=j-1
8851         j2=j-2
8852       endif
8853       if (l.lt.nres-1) then
8854         l1=l+1
8855         l2=l-1
8856       else
8857         l1=l-1
8858         l2=l-2
8859       endif
8860       do ll=1,3
8861 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8862 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8863 cgrad        ghalf=0.5d0*ggg1(ll)
8864 cd        ghalf=0.0d0
8865         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8866         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8867         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8868      &    +ekont*derx_turn(ll,2,1)
8869         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8870         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8871      &    +ekont*derx_turn(ll,4,1)
8872         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8873         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8874         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8875 cgrad        ghalf=0.5d0*ggg2(ll)
8876 cd        ghalf=0.0d0
8877         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8878      &    +ekont*derx_turn(ll,2,2)
8879         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8880         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8881      &    +ekont*derx_turn(ll,4,2)
8882         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8883         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8884         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8885       enddo
8886 cd      goto 1112
8887 cgrad      do m=i+1,j-1
8888 cgrad        do ll=1,3
8889 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8890 cgrad        enddo
8891 cgrad      enddo
8892 cgrad      do m=k+1,l-1
8893 cgrad        do ll=1,3
8894 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8895 cgrad        enddo
8896 cgrad      enddo
8897 cgrad1112  continue
8898 cgrad      do m=i+2,j2
8899 cgrad        do ll=1,3
8900 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8901 cgrad        enddo
8902 cgrad      enddo
8903 cgrad      do m=k+2,l2
8904 cgrad        do ll=1,3
8905 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8906 cgrad        enddo
8907 cgrad      enddo
8908 cd      do iii=1,nres-3
8909 cd        write (2,*) iii,g_corr6_loc(iii)
8910 cd      enddo
8911       eello_turn6=ekont*eel_turn6
8912 cd      write (2,*) 'ekont',ekont
8913 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8914       return
8915       end
8916
8917 C-----------------------------------------------------------------------------
8918       double precision function scalar(u,v)
8919 !DIR$ INLINEALWAYS scalar
8920 #ifndef OSF
8921 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8922 #endif
8923       implicit none
8924       double precision u(3),v(3)
8925 cd      double precision sc
8926 cd      integer i
8927 cd      sc=0.0d0
8928 cd      do i=1,3
8929 cd        sc=sc+u(i)*v(i)
8930 cd      enddo
8931 cd      scalar=sc
8932
8933       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8934       return
8935       end
8936 crc-------------------------------------------------
8937       SUBROUTINE MATVEC2(A1,V1,V2)
8938 !DIR$ INLINEALWAYS MATVEC2
8939 #ifndef OSF
8940 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8941 #endif
8942       implicit real*8 (a-h,o-z)
8943       include 'DIMENSIONS'
8944       DIMENSION A1(2,2),V1(2),V2(2)
8945 c      DO 1 I=1,2
8946 c        VI=0.0
8947 c        DO 3 K=1,2
8948 c    3     VI=VI+A1(I,K)*V1(K)
8949 c        Vaux(I)=VI
8950 c    1 CONTINUE
8951
8952       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8953       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8954
8955       v2(1)=vaux1
8956       v2(2)=vaux2
8957       END
8958 C---------------------------------------
8959       SUBROUTINE MATMAT2(A1,A2,A3)
8960 #ifndef OSF
8961 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8962 #endif
8963       implicit real*8 (a-h,o-z)
8964       include 'DIMENSIONS'
8965       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8966 c      DIMENSION AI3(2,2)
8967 c        DO  J=1,2
8968 c          A3IJ=0.0
8969 c          DO K=1,2
8970 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8971 c          enddo
8972 c          A3(I,J)=A3IJ
8973 c       enddo
8974 c      enddo
8975
8976       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8977       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8978       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8979       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8980
8981       A3(1,1)=AI3_11
8982       A3(2,1)=AI3_21
8983       A3(1,2)=AI3_12
8984       A3(2,2)=AI3_22
8985       END
8986
8987 c-------------------------------------------------------------------------
8988       double precision function scalar2(u,v)
8989 !DIR$ INLINEALWAYS scalar2
8990       implicit none
8991       double precision u(2),v(2)
8992       double precision sc
8993       integer i
8994       scalar2=u(1)*v(1)+u(2)*v(2)
8995       return
8996       end
8997
8998 C-----------------------------------------------------------------------------
8999
9000       subroutine transpose2(a,at)
9001 !DIR$ INLINEALWAYS transpose2
9002 #ifndef OSF
9003 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9004 #endif
9005       implicit none
9006       double precision a(2,2),at(2,2)
9007       at(1,1)=a(1,1)
9008       at(1,2)=a(2,1)
9009       at(2,1)=a(1,2)
9010       at(2,2)=a(2,2)
9011       return
9012       end
9013 c--------------------------------------------------------------------------
9014       subroutine transpose(n,a,at)
9015       implicit none
9016       integer n,i,j
9017       double precision a(n,n),at(n,n)
9018       do i=1,n
9019         do j=1,n
9020           at(j,i)=a(i,j)
9021         enddo
9022       enddo
9023       return
9024       end
9025 C---------------------------------------------------------------------------
9026       subroutine prodmat3(a1,a2,kk,transp,prod)
9027 !DIR$ INLINEALWAYS prodmat3
9028 #ifndef OSF
9029 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9030 #endif
9031       implicit none
9032       integer i,j
9033       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9034       logical transp
9035 crc      double precision auxmat(2,2),prod_(2,2)
9036
9037       if (transp) then
9038 crc        call transpose2(kk(1,1),auxmat(1,1))
9039 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9040 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9041
9042            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9043      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9044            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9045      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9046            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9047      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9048            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9049      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9050
9051       else
9052 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9053 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9054
9055            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9056      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9057            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9058      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9059            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9060      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9061            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9062      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9063
9064       endif
9065 c      call transpose2(a2(1,1),a2t(1,1))
9066
9067 crc      print *,transp
9068 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9069 crc      print *,((prod(i,j),i=1,2),j=1,2)
9070
9071       return
9072       end
9073