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
1424 c      write(iout,*) "Jestem w egb(evdw)"
1425
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=iabs(itype(i))
1435         if (itypi.eq.ntyp1) cycle
1436         itypi1=iabs(itype(i+1))
1437         xi=c(1,nres+i)
1438         yi=c(2,nres+i)
1439         zi=c(3,nres+i)
1440         dxi=dc_norm(1,nres+i)
1441         dyi=dc_norm(2,nres+i)
1442         dzi=dc_norm(3,nres+i)
1443 c        dsci_inv=dsc_inv(itypi)
1444         dsci_inv=vbld_inv(i+nres)
1445 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1446 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1447 C
1448 C Calculate SC interaction energy.
1449 C
1450         do iint=1,nint_gr(i)
1451           do j=istart(i,iint),iend(i,iint)
1452             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1453
1454 c              write(iout,*) "PRZED ZWYKLE", evdwij
1455               call dyn_ssbond_ene(i,j,evdwij)
1456 c              write(iout,*) "PO ZWYKLE", evdwij
1457
1458               evdw=evdw+evdwij
1459               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1460      &                        'evdw',i,j,evdwij,' ss'
1461 C triple bond artifac removal
1462              do k=j+1,iend(i,iint)
1463 C search over all next residues
1464               if (dyn_ss_mask(k)) then
1465 C check if they are cysteins
1466 C              write(iout,*) 'k=',k
1467
1468 c              write(iout,*) "PRZED TRI", evdwij
1469                evdwij_przed_tri=evdwij
1470               call triple_ssbond_ene(i,j,k,evdwij)
1471 c               if(evdwij_przed_tri.ne.evdwij) then
1472 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1473 c               endif
1474
1475 c              write(iout,*) "PO TRI", evdwij
1476 C call the energy function that removes the artifical triple disulfide
1477 C bond the soubroutine is located in ssMD.F
1478               evdw=evdw+evdwij
1479               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1480      &                        'evdw',i,j,evdwij,'tss'
1481               endif!dyn_ss_mask(k)
1482              enddo! k
1483             ELSE
1484             ind=ind+1
1485             itypj=iabs(itype(j))
1486             if (itypj.eq.ntyp1) cycle
1487 c            dscj_inv=dsc_inv(itypj)
1488             dscj_inv=vbld_inv(j+nres)
1489 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1490 c     &       1.0d0/vbld(j+nres)
1491 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1492             sig0ij=sigma(itypi,itypj)
1493             chi1=chi(itypi,itypj)
1494             chi2=chi(itypj,itypi)
1495             chi12=chi1*chi2
1496             chip1=chip(itypi)
1497             chip2=chip(itypj)
1498             chip12=chip1*chip2
1499             alf1=alp(itypi)
1500             alf2=alp(itypj)
1501             alf12=0.5D0*(alf1+alf2)
1502 C For diagnostics only!!!
1503 c           chi1=0.0D0
1504 c           chi2=0.0D0
1505 c           chi12=0.0D0
1506 c           chip1=0.0D0
1507 c           chip2=0.0D0
1508 c           chip12=0.0D0
1509 c           alf1=0.0D0
1510 c           alf2=0.0D0
1511 c           alf12=0.0D0
1512             xj=c(1,nres+j)-xi
1513             yj=c(2,nres+j)-yi
1514             zj=c(3,nres+j)-zi
1515             dxj=dc_norm(1,nres+j)
1516             dyj=dc_norm(2,nres+j)
1517             dzj=dc_norm(3,nres+j)
1518 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1519 c            write (iout,*) "j",j," dc_norm",
1520 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1521             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1522             rij=dsqrt(rrij)
1523 C Calculate angle-dependent terms of energy and contributions to their
1524 C derivatives.
1525             call sc_angular
1526             sigsq=1.0D0/sigsq
1527             sig=sig0ij*dsqrt(sigsq)
1528             rij_shift=1.0D0/rij-sig+sig0ij
1529 c for diagnostics; uncomment
1530 c            rij_shift=1.2*sig0ij
1531 C I hate to put IF's in the loops, but here don't have another choice!!!!
1532             if (rij_shift.le.0.0D0) then
1533               evdw=1.0D20
1534 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1535 cd     &        restyp(itypi),i,restyp(itypj),j,
1536 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1537               return
1538             endif
1539             sigder=-sig*sigsq
1540 c---------------------------------------------------------------
1541             rij_shift=1.0D0/rij_shift
1542             fac=rij_shift**expon
1543             e1=fac*fac*aa(itypi,itypj)
1544             e2=fac*bb(itypi,itypj)
1545             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1546             eps2der=evdwij*eps3rt
1547             eps3der=evdwij*eps2rt
1548 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1549 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1550             evdwij=evdwij*eps2rt*eps3rt
1551             evdw=evdw+evdwij
1552             if (lprn) then
1553             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1554             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1555             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1556      &        restyp(itypi),i,restyp(itypj),j,
1557      &        epsi,sigm,chi1,chi2,chip1,chip2,
1558      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1559      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1560      &        evdwij
1561             endif
1562
1563             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1564      &                        'evdw',i,j,evdwij
1565
1566 C Calculate gradient components.
1567             e1=e1*eps1*eps2rt**2*eps3rt**2
1568             fac=-expon*(e1+evdwij)*rij_shift
1569             sigder=fac*sigder
1570             fac=rij*fac
1571 c            fac=0.0d0
1572 C Calculate the radial part of the gradient
1573             gg(1)=xj*fac
1574             gg(2)=yj*fac
1575             gg(3)=zj*fac
1576 C Calculate angular part of the gradient.
1577             call sc_grad
1578             ENDIF    ! dyn_ss
1579           enddo      ! j
1580         enddo        ! iint
1581       enddo          ! i
1582 c      write (iout,*) "Number of loop steps in EGB:",ind
1583 cccc      energy_dec=.false.
1584       return
1585       end
1586 C-----------------------------------------------------------------------------
1587       subroutine egbv(evdw)
1588 C
1589 C This subroutine calculates the interaction energy of nonbonded side chains
1590 C assuming the Gay-Berne-Vorobjev potential of interaction.
1591 C
1592       implicit real*8 (a-h,o-z)
1593       include 'DIMENSIONS'
1594       include 'COMMON.GEO'
1595       include 'COMMON.VAR'
1596       include 'COMMON.LOCAL'
1597       include 'COMMON.CHAIN'
1598       include 'COMMON.DERIV'
1599       include 'COMMON.NAMES'
1600       include 'COMMON.INTERACT'
1601       include 'COMMON.IOUNITS'
1602       include 'COMMON.CALC'
1603       common /srutu/ icall
1604       logical lprn
1605       evdw=0.0D0
1606 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1607       evdw=0.0D0
1608       lprn=.false.
1609 c     if (icall.eq.0) lprn=.true.
1610       ind=0
1611       do i=iatsc_s,iatsc_e
1612         itypi=iabs(itype(i))
1613         if (itypi.eq.ntyp1) cycle
1614         itypi1=iabs(itype(i+1))
1615         xi=c(1,nres+i)
1616         yi=c(2,nres+i)
1617         zi=c(3,nres+i)
1618         dxi=dc_norm(1,nres+i)
1619         dyi=dc_norm(2,nres+i)
1620         dzi=dc_norm(3,nres+i)
1621 c        dsci_inv=dsc_inv(itypi)
1622         dsci_inv=vbld_inv(i+nres)
1623 C
1624 C Calculate SC interaction energy.
1625 C
1626         do iint=1,nint_gr(i)
1627           do j=istart(i,iint),iend(i,iint)
1628             ind=ind+1
1629             itypj=iabs(itype(j))
1630             if (itypj.eq.ntyp1) cycle
1631 c            dscj_inv=dsc_inv(itypj)
1632             dscj_inv=vbld_inv(j+nres)
1633             sig0ij=sigma(itypi,itypj)
1634             r0ij=r0(itypi,itypj)
1635             chi1=chi(itypi,itypj)
1636             chi2=chi(itypj,itypi)
1637             chi12=chi1*chi2
1638             chip1=chip(itypi)
1639             chip2=chip(itypj)
1640             chip12=chip1*chip2
1641             alf1=alp(itypi)
1642             alf2=alp(itypj)
1643             alf12=0.5D0*(alf1+alf2)
1644 C For diagnostics only!!!
1645 c           chi1=0.0D0
1646 c           chi2=0.0D0
1647 c           chi12=0.0D0
1648 c           chip1=0.0D0
1649 c           chip2=0.0D0
1650 c           chip12=0.0D0
1651 c           alf1=0.0D0
1652 c           alf2=0.0D0
1653 c           alf12=0.0D0
1654             xj=c(1,nres+j)-xi
1655             yj=c(2,nres+j)-yi
1656             zj=c(3,nres+j)-zi
1657             dxj=dc_norm(1,nres+j)
1658             dyj=dc_norm(2,nres+j)
1659             dzj=dc_norm(3,nres+j)
1660             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1661             rij=dsqrt(rrij)
1662 C Calculate angle-dependent terms of energy and contributions to their
1663 C derivatives.
1664             call sc_angular
1665             sigsq=1.0D0/sigsq
1666             sig=sig0ij*dsqrt(sigsq)
1667             rij_shift=1.0D0/rij-sig+r0ij
1668 C I hate to put IF's in the loops, but here don't have another choice!!!!
1669             if (rij_shift.le.0.0D0) then
1670               evdw=1.0D20
1671               return
1672             endif
1673             sigder=-sig*sigsq
1674 c---------------------------------------------------------------
1675             rij_shift=1.0D0/rij_shift
1676             fac=rij_shift**expon
1677             e1=fac*fac*aa(itypi,itypj)
1678             e2=fac*bb(itypi,itypj)
1679             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1680             eps2der=evdwij*eps3rt
1681             eps3der=evdwij*eps2rt
1682             fac_augm=rrij**expon
1683             e_augm=augm(itypi,itypj)*fac_augm
1684             evdwij=evdwij*eps2rt*eps3rt
1685             evdw=evdw+evdwij+e_augm
1686             if (lprn) then
1687             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1688             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1689             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1690      &        restyp(itypi),i,restyp(itypj),j,
1691      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1692      &        chi1,chi2,chip1,chip2,
1693      &        eps1,eps2rt**2,eps3rt**2,
1694      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1695      &        evdwij+e_augm
1696             endif
1697 C Calculate gradient components.
1698             e1=e1*eps1*eps2rt**2*eps3rt**2
1699             fac=-expon*(e1+evdwij)*rij_shift
1700             sigder=fac*sigder
1701             fac=rij*fac-2*expon*rrij*e_augm
1702 C Calculate the radial part of the gradient
1703             gg(1)=xj*fac
1704             gg(2)=yj*fac
1705             gg(3)=zj*fac
1706 C Calculate angular part of the gradient.
1707             call sc_grad
1708           enddo      ! j
1709         enddo        ! iint
1710       enddo          ! i
1711       end
1712 C-----------------------------------------------------------------------------
1713       subroutine sc_angular
1714 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1715 C om12. Called by ebp, egb, and egbv.
1716       implicit none
1717       include 'COMMON.CALC'
1718       include 'COMMON.IOUNITS'
1719       erij(1)=xj*rij
1720       erij(2)=yj*rij
1721       erij(3)=zj*rij
1722       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1723       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1724       om12=dxi*dxj+dyi*dyj+dzi*dzj
1725       chiom12=chi12*om12
1726 C Calculate eps1(om12) and its derivative in om12
1727       faceps1=1.0D0-om12*chiom12
1728       faceps1_inv=1.0D0/faceps1
1729       eps1=dsqrt(faceps1_inv)
1730 C Following variable is eps1*deps1/dom12
1731       eps1_om12=faceps1_inv*chiom12
1732 c diagnostics only
1733 c      faceps1_inv=om12
1734 c      eps1=om12
1735 c      eps1_om12=1.0d0
1736 c      write (iout,*) "om12",om12," eps1",eps1
1737 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1738 C and om12.
1739       om1om2=om1*om2
1740       chiom1=chi1*om1
1741       chiom2=chi2*om2
1742       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1743       sigsq=1.0D0-facsig*faceps1_inv
1744       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1745       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1746       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1747 c diagnostics only
1748 c      sigsq=1.0d0
1749 c      sigsq_om1=0.0d0
1750 c      sigsq_om2=0.0d0
1751 c      sigsq_om12=0.0d0
1752 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1753 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1754 c     &    " eps1",eps1
1755 C Calculate eps2 and its derivatives in om1, om2, and om12.
1756       chipom1=chip1*om1
1757       chipom2=chip2*om2
1758       chipom12=chip12*om12
1759       facp=1.0D0-om12*chipom12
1760       facp_inv=1.0D0/facp
1761       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1762 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1763 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1764 C Following variable is the square root of eps2
1765       eps2rt=1.0D0-facp1*facp_inv
1766 C Following three variables are the derivatives of the square root of eps
1767 C in om1, om2, and om12.
1768       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1769       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1770       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1771 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1772       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1773 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1774 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1775 c     &  " eps2rt_om12",eps2rt_om12
1776 C Calculate whole angle-dependent part of epsilon and contributions
1777 C to its derivatives
1778       return
1779       end
1780 C----------------------------------------------------------------------------
1781       subroutine sc_grad
1782       implicit real*8 (a-h,o-z)
1783       include 'DIMENSIONS'
1784       include 'COMMON.CHAIN'
1785       include 'COMMON.DERIV'
1786       include 'COMMON.CALC'
1787       include 'COMMON.IOUNITS'
1788       double precision dcosom1(3),dcosom2(3)
1789       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1790       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1791       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1792      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1793 c diagnostics only
1794 c      eom1=0.0d0
1795 c      eom2=0.0d0
1796 c      eom12=evdwij*eps1_om12
1797 c end diagnostics
1798 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1799 c     &  " sigder",sigder
1800 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1801 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1802       do k=1,3
1803         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1804         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1805       enddo
1806       do k=1,3
1807         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1808       enddo
1809 c      write (iout,*) "gg",(gg(k),k=1,3)
1810       do k=1,3
1811         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1812      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1813      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1814         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1815      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1816      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1817 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1818 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1819 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1820 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1821       enddo
1822 C
1823 C Calculate the components of the gradient in DC and X
1824 C
1825 cgrad      do k=i,j-1
1826 cgrad        do l=1,3
1827 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1828 cgrad        enddo
1829 cgrad      enddo
1830       do l=1,3
1831         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1832         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1833       enddo
1834       return
1835       end
1836 C-----------------------------------------------------------------------
1837       subroutine e_softsphere(evdw)
1838 C
1839 C This subroutine calculates the interaction energy of nonbonded side chains
1840 C assuming the LJ potential of interaction.
1841 C
1842       implicit real*8 (a-h,o-z)
1843       include 'DIMENSIONS'
1844       parameter (accur=1.0d-10)
1845       include 'COMMON.GEO'
1846       include 'COMMON.VAR'
1847       include 'COMMON.LOCAL'
1848       include 'COMMON.CHAIN'
1849       include 'COMMON.DERIV'
1850       include 'COMMON.INTERACT'
1851       include 'COMMON.TORSION'
1852       include 'COMMON.SBRIDGE'
1853       include 'COMMON.NAMES'
1854       include 'COMMON.IOUNITS'
1855       include 'COMMON.CONTACTS'
1856       dimension gg(3)
1857 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1858       evdw=0.0D0
1859       do i=iatsc_s,iatsc_e
1860         itypi=iabs(itype(i))
1861         if (itypi.eq.ntyp1) cycle
1862         itypi1=iabs(itype(i+1))
1863         xi=c(1,nres+i)
1864         yi=c(2,nres+i)
1865         zi=c(3,nres+i)
1866 C
1867 C Calculate SC interaction energy.
1868 C
1869         do iint=1,nint_gr(i)
1870 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1871 cd   &                  'iend=',iend(i,iint)
1872           do j=istart(i,iint),iend(i,iint)
1873             itypj=iabs(itype(j))
1874             if (itypj.eq.ntyp1) cycle
1875             xj=c(1,nres+j)-xi
1876             yj=c(2,nres+j)-yi
1877             zj=c(3,nres+j)-zi
1878             rij=xj*xj+yj*yj+zj*zj
1879 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1880             r0ij=r0(itypi,itypj)
1881             r0ijsq=r0ij*r0ij
1882 c            print *,i,j,r0ij,dsqrt(rij)
1883             if (rij.lt.r0ijsq) then
1884               evdwij=0.25d0*(rij-r0ijsq)**2
1885               fac=rij-r0ijsq
1886             else
1887               evdwij=0.0d0
1888               fac=0.0d0
1889             endif
1890             evdw=evdw+evdwij
1891 C
1892 C Calculate the components of the gradient in DC and X
1893 C
1894             gg(1)=xj*fac
1895             gg(2)=yj*fac
1896             gg(3)=zj*fac
1897             do k=1,3
1898               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1899               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1900               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1901               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1902             enddo
1903 cgrad            do k=i,j-1
1904 cgrad              do l=1,3
1905 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1906 cgrad              enddo
1907 cgrad            enddo
1908           enddo ! j
1909         enddo ! iint
1910       enddo ! i
1911       return
1912       end
1913 C--------------------------------------------------------------------------
1914       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1915      &              eello_turn4)
1916 C
1917 C Soft-sphere potential of p-p interaction
1918 C
1919       implicit real*8 (a-h,o-z)
1920       include 'DIMENSIONS'
1921       include 'COMMON.CONTROL'
1922       include 'COMMON.IOUNITS'
1923       include 'COMMON.GEO'
1924       include 'COMMON.VAR'
1925       include 'COMMON.LOCAL'
1926       include 'COMMON.CHAIN'
1927       include 'COMMON.DERIV'
1928       include 'COMMON.INTERACT'
1929       include 'COMMON.CONTACTS'
1930       include 'COMMON.TORSION'
1931       include 'COMMON.VECTORS'
1932       include 'COMMON.FFIELD'
1933       dimension ggg(3)
1934 cd      write(iout,*) 'In EELEC_soft_sphere'
1935       ees=0.0D0
1936       evdw1=0.0D0
1937       eel_loc=0.0d0
1938       eello_turn3=0.0d0
1939       eello_turn4=0.0d0
1940       ind=0
1941       do i=iatel_s,iatel_e
1942         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1943         dxi=dc(1,i)
1944         dyi=dc(2,i)
1945         dzi=dc(3,i)
1946         xmedi=c(1,i)+0.5d0*dxi
1947         ymedi=c(2,i)+0.5d0*dyi
1948         zmedi=c(3,i)+0.5d0*dzi
1949         num_conti=0
1950 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1951         do j=ielstart(i),ielend(i)
1952           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1953           ind=ind+1
1954           iteli=itel(i)
1955           itelj=itel(j)
1956           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1957           r0ij=rpp(iteli,itelj)
1958           r0ijsq=r0ij*r0ij
1959           dxj=dc(1,j)
1960           dyj=dc(2,j)
1961           dzj=dc(3,j)
1962           xj=c(1,j)+0.5D0*dxj-xmedi
1963           yj=c(2,j)+0.5D0*dyj-ymedi
1964           zj=c(3,j)+0.5D0*dzj-zmedi
1965           rij=xj*xj+yj*yj+zj*zj
1966           if (rij.lt.r0ijsq) then
1967             evdw1ij=0.25d0*(rij-r0ijsq)**2
1968             fac=rij-r0ijsq
1969           else
1970             evdw1ij=0.0d0
1971             fac=0.0d0
1972           endif
1973           evdw1=evdw1+evdw1ij
1974 C
1975 C Calculate contributions to the Cartesian gradient.
1976 C
1977           ggg(1)=fac*xj
1978           ggg(2)=fac*yj
1979           ggg(3)=fac*zj
1980           do k=1,3
1981             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1982             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1983           enddo
1984 *
1985 * Loop over residues i+1 thru j-1.
1986 *
1987 cgrad          do k=i+1,j-1
1988 cgrad            do l=1,3
1989 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1990 cgrad            enddo
1991 cgrad          enddo
1992         enddo ! j
1993       enddo   ! i
1994 cgrad      do i=nnt,nct-1
1995 cgrad        do k=1,3
1996 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1997 cgrad        enddo
1998 cgrad        do j=i+1,nct-1
1999 cgrad          do k=1,3
2000 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2001 cgrad          enddo
2002 cgrad        enddo
2003 cgrad      enddo
2004       return
2005       end
2006 c------------------------------------------------------------------------------
2007       subroutine vec_and_deriv
2008       implicit real*8 (a-h,o-z)
2009       include 'DIMENSIONS'
2010 #ifdef MPI
2011       include 'mpif.h'
2012 #endif
2013       include 'COMMON.IOUNITS'
2014       include 'COMMON.GEO'
2015       include 'COMMON.VAR'
2016       include 'COMMON.LOCAL'
2017       include 'COMMON.CHAIN'
2018       include 'COMMON.VECTORS'
2019       include 'COMMON.SETUP'
2020       include 'COMMON.TIME1'
2021       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2022 C Compute the local reference systems. For reference system (i), the
2023 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2024 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2025 #ifdef PARVEC
2026       do i=ivec_start,ivec_end
2027 #else
2028       do i=1,nres-1
2029 #endif
2030           if (i.eq.nres-1) then
2031 C Case of the last full residue
2032 C Compute the Z-axis
2033             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2034             costh=dcos(pi-theta(nres))
2035             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2036             do k=1,3
2037               uz(k,i)=fac*uz(k,i)
2038             enddo
2039 C Compute the derivatives of uz
2040             uzder(1,1,1)= 0.0d0
2041             uzder(2,1,1)=-dc_norm(3,i-1)
2042             uzder(3,1,1)= dc_norm(2,i-1)
2043             uzder(1,2,1)= dc_norm(3,i-1)
2044             uzder(2,2,1)= 0.0d0
2045             uzder(3,2,1)=-dc_norm(1,i-1)
2046             uzder(1,3,1)=-dc_norm(2,i-1)
2047             uzder(2,3,1)= dc_norm(1,i-1)
2048             uzder(3,3,1)= 0.0d0
2049             uzder(1,1,2)= 0.0d0
2050             uzder(2,1,2)= dc_norm(3,i)
2051             uzder(3,1,2)=-dc_norm(2,i)
2052             uzder(1,2,2)=-dc_norm(3,i)
2053             uzder(2,2,2)= 0.0d0
2054             uzder(3,2,2)= dc_norm(1,i)
2055             uzder(1,3,2)= dc_norm(2,i)
2056             uzder(2,3,2)=-dc_norm(1,i)
2057             uzder(3,3,2)= 0.0d0
2058 C Compute the Y-axis
2059             facy=fac
2060             do k=1,3
2061               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2062             enddo
2063 C Compute the derivatives of uy
2064             do j=1,3
2065               do k=1,3
2066                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2067      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2068                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2069               enddo
2070               uyder(j,j,1)=uyder(j,j,1)-costh
2071               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2072             enddo
2073             do j=1,2
2074               do k=1,3
2075                 do l=1,3
2076                   uygrad(l,k,j,i)=uyder(l,k,j)
2077                   uzgrad(l,k,j,i)=uzder(l,k,j)
2078                 enddo
2079               enddo
2080             enddo
2081             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2082             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2083             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2084             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2085           else
2086 C Other residues
2087 C Compute the Z-axis
2088             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2089             costh=dcos(pi-theta(i+2))
2090             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2091             do k=1,3
2092               uz(k,i)=fac*uz(k,i)
2093             enddo
2094 C Compute the derivatives of uz
2095             uzder(1,1,1)= 0.0d0
2096             uzder(2,1,1)=-dc_norm(3,i+1)
2097             uzder(3,1,1)= dc_norm(2,i+1)
2098             uzder(1,2,1)= dc_norm(3,i+1)
2099             uzder(2,2,1)= 0.0d0
2100             uzder(3,2,1)=-dc_norm(1,i+1)
2101             uzder(1,3,1)=-dc_norm(2,i+1)
2102             uzder(2,3,1)= dc_norm(1,i+1)
2103             uzder(3,3,1)= 0.0d0
2104             uzder(1,1,2)= 0.0d0
2105             uzder(2,1,2)= dc_norm(3,i)
2106             uzder(3,1,2)=-dc_norm(2,i)
2107             uzder(1,2,2)=-dc_norm(3,i)
2108             uzder(2,2,2)= 0.0d0
2109             uzder(3,2,2)= dc_norm(1,i)
2110             uzder(1,3,2)= dc_norm(2,i)
2111             uzder(2,3,2)=-dc_norm(1,i)
2112             uzder(3,3,2)= 0.0d0
2113 C Compute the Y-axis
2114             facy=fac
2115             do k=1,3
2116               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2117             enddo
2118 C Compute the derivatives of uy
2119             do j=1,3
2120               do k=1,3
2121                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2122      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2123                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2124               enddo
2125               uyder(j,j,1)=uyder(j,j,1)-costh
2126               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2127             enddo
2128             do j=1,2
2129               do k=1,3
2130                 do l=1,3
2131                   uygrad(l,k,j,i)=uyder(l,k,j)
2132                   uzgrad(l,k,j,i)=uzder(l,k,j)
2133                 enddo
2134               enddo
2135             enddo
2136             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2137             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2138             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2139             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2140           endif
2141       enddo
2142       do i=1,nres-1
2143         vbld_inv_temp(1)=vbld_inv(i+1)
2144         if (i.lt.nres-1) then
2145           vbld_inv_temp(2)=vbld_inv(i+2)
2146           else
2147           vbld_inv_temp(2)=vbld_inv(i)
2148           endif
2149         do j=1,2
2150           do k=1,3
2151             do l=1,3
2152               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2153               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2154             enddo
2155           enddo
2156         enddo
2157       enddo
2158 #if defined(PARVEC) && defined(MPI)
2159       if (nfgtasks1.gt.1) then
2160         time00=MPI_Wtime()
2161 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2162 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2163 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2164         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2165      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2166      &   FG_COMM1,IERR)
2167         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2168      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2169      &   FG_COMM1,IERR)
2170         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2171      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2172      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2173         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2174      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2175      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2176         time_gather=time_gather+MPI_Wtime()-time00
2177       endif
2178 c      if (fg_rank.eq.0) then
2179 c        write (iout,*) "Arrays UY and UZ"
2180 c        do i=1,nres-1
2181 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2182 c     &     (uz(k,i),k=1,3)
2183 c        enddo
2184 c      endif
2185 #endif
2186       return
2187       end
2188 C-----------------------------------------------------------------------------
2189       subroutine check_vecgrad
2190       implicit real*8 (a-h,o-z)
2191       include 'DIMENSIONS'
2192       include 'COMMON.IOUNITS'
2193       include 'COMMON.GEO'
2194       include 'COMMON.VAR'
2195       include 'COMMON.LOCAL'
2196       include 'COMMON.CHAIN'
2197       include 'COMMON.VECTORS'
2198       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2199       dimension uyt(3,maxres),uzt(3,maxres)
2200       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2201       double precision delta /1.0d-7/
2202       call vec_and_deriv
2203 cd      do i=1,nres
2204 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2205 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2206 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2207 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2208 cd     &     (dc_norm(if90,i),if90=1,3)
2209 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2210 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2211 cd          write(iout,'(a)')
2212 cd      enddo
2213       do i=1,nres
2214         do j=1,2
2215           do k=1,3
2216             do l=1,3
2217               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2218               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2219             enddo
2220           enddo
2221         enddo
2222       enddo
2223       call vec_and_deriv
2224       do i=1,nres
2225         do j=1,3
2226           uyt(j,i)=uy(j,i)
2227           uzt(j,i)=uz(j,i)
2228         enddo
2229       enddo
2230       do i=1,nres
2231 cd        write (iout,*) 'i=',i
2232         do k=1,3
2233           erij(k)=dc_norm(k,i)
2234         enddo
2235         do j=1,3
2236           do k=1,3
2237             dc_norm(k,i)=erij(k)
2238           enddo
2239           dc_norm(j,i)=dc_norm(j,i)+delta
2240 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2241 c          do k=1,3
2242 c            dc_norm(k,i)=dc_norm(k,i)/fac
2243 c          enddo
2244 c          write (iout,*) (dc_norm(k,i),k=1,3)
2245 c          write (iout,*) (erij(k),k=1,3)
2246           call vec_and_deriv
2247           do k=1,3
2248             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2249             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2250             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2251             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2252           enddo
2253 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2254 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2255 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2256         enddo
2257         do k=1,3
2258           dc_norm(k,i)=erij(k)
2259         enddo
2260 cd        do k=1,3
2261 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2262 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2263 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2264 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2265 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2266 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2267 cd          write (iout,'(a)')
2268 cd        enddo
2269       enddo
2270       return
2271       end
2272 C--------------------------------------------------------------------------
2273       subroutine set_matrices
2274       implicit real*8 (a-h,o-z)
2275       include 'DIMENSIONS'
2276 #ifdef MPI
2277       include "mpif.h"
2278       include "COMMON.SETUP"
2279       integer IERR
2280       integer status(MPI_STATUS_SIZE)
2281 #endif
2282       include 'COMMON.IOUNITS'
2283       include 'COMMON.GEO'
2284       include 'COMMON.VAR'
2285       include 'COMMON.LOCAL'
2286       include 'COMMON.CHAIN'
2287       include 'COMMON.DERIV'
2288       include 'COMMON.INTERACT'
2289       include 'COMMON.CONTACTS'
2290       include 'COMMON.TORSION'
2291       include 'COMMON.VECTORS'
2292       include 'COMMON.FFIELD'
2293       double precision auxvec(2),auxmat(2,2)
2294 C
2295 C Compute the virtual-bond-torsional-angle dependent quantities needed
2296 C to calculate the el-loc multibody terms of various order.
2297 C
2298 #ifdef PARMAT
2299       do i=ivec_start+2,ivec_end+2
2300 #else
2301       do i=3,nres+1
2302 #endif
2303         if (i .lt. nres+1) then
2304           sin1=dsin(phi(i))
2305           cos1=dcos(phi(i))
2306           sintab(i-2)=sin1
2307           costab(i-2)=cos1
2308           obrot(1,i-2)=cos1
2309           obrot(2,i-2)=sin1
2310           sin2=dsin(2*phi(i))
2311           cos2=dcos(2*phi(i))
2312           sintab2(i-2)=sin2
2313           costab2(i-2)=cos2
2314           obrot2(1,i-2)=cos2
2315           obrot2(2,i-2)=sin2
2316           Ug(1,1,i-2)=-cos1
2317           Ug(1,2,i-2)=-sin1
2318           Ug(2,1,i-2)=-sin1
2319           Ug(2,2,i-2)= cos1
2320           Ug2(1,1,i-2)=-cos2
2321           Ug2(1,2,i-2)=-sin2
2322           Ug2(2,1,i-2)=-sin2
2323           Ug2(2,2,i-2)= cos2
2324         else
2325           costab(i-2)=1.0d0
2326           sintab(i-2)=0.0d0
2327           obrot(1,i-2)=1.0d0
2328           obrot(2,i-2)=0.0d0
2329           obrot2(1,i-2)=0.0d0
2330           obrot2(2,i-2)=0.0d0
2331           Ug(1,1,i-2)=1.0d0
2332           Ug(1,2,i-2)=0.0d0
2333           Ug(2,1,i-2)=0.0d0
2334           Ug(2,2,i-2)=1.0d0
2335           Ug2(1,1,i-2)=0.0d0
2336           Ug2(1,2,i-2)=0.0d0
2337           Ug2(2,1,i-2)=0.0d0
2338           Ug2(2,2,i-2)=0.0d0
2339         endif
2340         if (i .gt. 3 .and. i .lt. nres+1) then
2341           obrot_der(1,i-2)=-sin1
2342           obrot_der(2,i-2)= cos1
2343           Ugder(1,1,i-2)= sin1
2344           Ugder(1,2,i-2)=-cos1
2345           Ugder(2,1,i-2)=-cos1
2346           Ugder(2,2,i-2)=-sin1
2347           dwacos2=cos2+cos2
2348           dwasin2=sin2+sin2
2349           obrot2_der(1,i-2)=-dwasin2
2350           obrot2_der(2,i-2)= dwacos2
2351           Ug2der(1,1,i-2)= dwasin2
2352           Ug2der(1,2,i-2)=-dwacos2
2353           Ug2der(2,1,i-2)=-dwacos2
2354           Ug2der(2,2,i-2)=-dwasin2
2355         else
2356           obrot_der(1,i-2)=0.0d0
2357           obrot_der(2,i-2)=0.0d0
2358           Ugder(1,1,i-2)=0.0d0
2359           Ugder(1,2,i-2)=0.0d0
2360           Ugder(2,1,i-2)=0.0d0
2361           Ugder(2,2,i-2)=0.0d0
2362           obrot2_der(1,i-2)=0.0d0
2363           obrot2_der(2,i-2)=0.0d0
2364           Ug2der(1,1,i-2)=0.0d0
2365           Ug2der(1,2,i-2)=0.0d0
2366           Ug2der(2,1,i-2)=0.0d0
2367           Ug2der(2,2,i-2)=0.0d0
2368         endif
2369 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2370         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2371           iti = itortyp(itype(i-2))
2372         else
2373           iti=ntortyp+1
2374         endif
2375 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2376         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2377           iti1 = itortyp(itype(i-1))
2378         else
2379           iti1=ntortyp+1
2380         endif
2381 cd        write (iout,*) '*******i',i,' iti1',iti
2382 cd        write (iout,*) 'b1',b1(:,iti)
2383 cd        write (iout,*) 'b2',b2(:,iti)
2384 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2385 c        if (i .gt. iatel_s+2) then
2386         if (i .gt. nnt+2) then
2387           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2388           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2389           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2390      &    then
2391           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2392           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2393           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2394           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2395           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2396           endif
2397         else
2398           do k=1,2
2399             Ub2(k,i-2)=0.0d0
2400             Ctobr(k,i-2)=0.0d0
2401             Dtobr2(k,i-2)=0.0d0
2402             do l=1,2
2403               EUg(l,k,i-2)=0.0d0
2404               CUg(l,k,i-2)=0.0d0
2405               DUg(l,k,i-2)=0.0d0
2406               DtUg2(l,k,i-2)=0.0d0
2407             enddo
2408           enddo
2409         endif
2410         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2411         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2412         do k=1,2
2413           muder(k,i-2)=Ub2der(k,i-2)
2414         enddo
2415 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2416         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2417           if (itype(i-1).le.ntyp) then
2418             iti1 = itortyp(itype(i-1))
2419           else
2420             iti1=ntortyp+1
2421           endif
2422         else
2423           iti1=ntortyp+1
2424         endif
2425         do k=1,2
2426           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2427         enddo
2428 cd        write (iout,*) 'mu ',mu(:,i-2)
2429 cd        write (iout,*) 'mu1',mu1(:,i-2)
2430 cd        write (iout,*) 'mu2',mu2(:,i-2)
2431         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2432      &  then
2433         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2434         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2435         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2436         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2437         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2438 C Vectors and matrices dependent on a single virtual-bond dihedral.
2439         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2440         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2441         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2442         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2443         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2444         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2445         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2446         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2447         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2448         endif
2449       enddo
2450 C Matrices dependent on two consecutive virtual-bond dihedrals.
2451 C The order of matrices is from left to right.
2452       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2453      &then
2454 c      do i=max0(ivec_start,2),ivec_end
2455       do i=2,nres-1
2456         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2457         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2458         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2459         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2460         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2461         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2462         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2463         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2464       enddo
2465       endif
2466 #if defined(MPI) && defined(PARMAT)
2467 #ifdef DEBUG
2468 c      if (fg_rank.eq.0) then
2469         write (iout,*) "Arrays UG and UGDER before GATHER"
2470         do i=1,nres-1
2471           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2472      &     ((ug(l,k,i),l=1,2),k=1,2),
2473      &     ((ugder(l,k,i),l=1,2),k=1,2)
2474         enddo
2475         write (iout,*) "Arrays UG2 and UG2DER"
2476         do i=1,nres-1
2477           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2478      &     ((ug2(l,k,i),l=1,2),k=1,2),
2479      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2480         enddo
2481         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2482         do i=1,nres-1
2483           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2484      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2485      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2486         enddo
2487         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2488         do i=1,nres-1
2489           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2490      &     costab(i),sintab(i),costab2(i),sintab2(i)
2491         enddo
2492         write (iout,*) "Array MUDER"
2493         do i=1,nres-1
2494           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2495         enddo
2496 c      endif
2497 #endif
2498       if (nfgtasks.gt.1) then
2499         time00=MPI_Wtime()
2500 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2501 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2502 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2503 #ifdef MATGATHER
2504         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2505      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2506      &   FG_COMM1,IERR)
2507         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2508      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2509      &   FG_COMM1,IERR)
2510         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2514      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2515      &   FG_COMM1,IERR)
2516         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2517      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2523      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2524      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2525         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2526      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2527      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2528         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2529      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2530      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2531         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2532      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2533      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2534         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2535      &  then
2536         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2537      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2538      &   FG_COMM1,IERR)
2539         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2540      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2541      &   FG_COMM1,IERR)
2542         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2543      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2544      &   FG_COMM1,IERR)
2545        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2546      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2547      &   FG_COMM1,IERR)
2548         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2549      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2550      &   FG_COMM1,IERR)
2551         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2552      &   ivec_count(fg_rank1),
2553      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2562      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2563      &   FG_COMM1,IERR)
2564         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2568      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2571      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2572      &   FG_COMM1,IERR)
2573         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2574      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2575      &   FG_COMM1,IERR)
2576         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2577      &   ivec_count(fg_rank1),
2578      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2579      &   FG_COMM1,IERR)
2580         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2581      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2582      &   FG_COMM1,IERR)
2583        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2588      &   FG_COMM1,IERR)
2589        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2593      &   ivec_count(fg_rank1),
2594      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2597      &   ivec_count(fg_rank1),
2598      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2599      &   FG_COMM1,IERR)
2600         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2601      &   ivec_count(fg_rank1),
2602      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2603      &   MPI_MAT2,FG_COMM1,IERR)
2604         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2605      &   ivec_count(fg_rank1),
2606      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2607      &   MPI_MAT2,FG_COMM1,IERR)
2608         endif
2609 #else
2610 c Passes matrix info through the ring
2611       isend=fg_rank1
2612       irecv=fg_rank1-1
2613       if (irecv.lt.0) irecv=nfgtasks1-1
2614       iprev=irecv
2615       inext=fg_rank1+1
2616       if (inext.ge.nfgtasks1) inext=0
2617       do i=1,nfgtasks1-1
2618 c        write (iout,*) "isend",isend," irecv",irecv
2619 c        call flush(iout)
2620         lensend=lentyp(isend)
2621         lenrecv=lentyp(irecv)
2622 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2623 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2624 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2625 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2626 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2627 c        write (iout,*) "Gather ROTAT1"
2628 c        call flush(iout)
2629 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2630 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2631 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2632 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2633 c        write (iout,*) "Gather ROTAT2"
2634 c        call flush(iout)
2635         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2636      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2637      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2638      &   iprev,4400+irecv,FG_COMM,status,IERR)
2639 c        write (iout,*) "Gather ROTAT_OLD"
2640 c        call flush(iout)
2641         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2642      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2643      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2644      &   iprev,5500+irecv,FG_COMM,status,IERR)
2645 c        write (iout,*) "Gather PRECOMP11"
2646 c        call flush(iout)
2647         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2648      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2649      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2650      &   iprev,6600+irecv,FG_COMM,status,IERR)
2651 c        write (iout,*) "Gather PRECOMP12"
2652 c        call flush(iout)
2653         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2654      &  then
2655         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2656      &   MPI_ROTAT2(lensend),inext,7700+isend,
2657      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2658      &   iprev,7700+irecv,FG_COMM,status,IERR)
2659 c        write (iout,*) "Gather PRECOMP21"
2660 c        call flush(iout)
2661         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2662      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2663      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2664      &   iprev,8800+irecv,FG_COMM,status,IERR)
2665 c        write (iout,*) "Gather PRECOMP22"
2666 c        call flush(iout)
2667         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2668      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2669      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2670      &   MPI_PRECOMP23(lenrecv),
2671      &   iprev,9900+irecv,FG_COMM,status,IERR)
2672 c        write (iout,*) "Gather PRECOMP23"
2673 c        call flush(iout)
2674         endif
2675         isend=irecv
2676         irecv=irecv-1
2677         if (irecv.lt.0) irecv=nfgtasks1-1
2678       enddo
2679 #endif
2680         time_gather=time_gather+MPI_Wtime()-time00
2681       endif
2682 #ifdef DEBUG
2683 c      if (fg_rank.eq.0) then
2684         write (iout,*) "Arrays UG and UGDER"
2685         do i=1,nres-1
2686           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2687      &     ((ug(l,k,i),l=1,2),k=1,2),
2688      &     ((ugder(l,k,i),l=1,2),k=1,2)
2689         enddo
2690         write (iout,*) "Arrays UG2 and UG2DER"
2691         do i=1,nres-1
2692           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2693      &     ((ug2(l,k,i),l=1,2),k=1,2),
2694      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2695         enddo
2696         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2697         do i=1,nres-1
2698           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2699      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2700      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2701         enddo
2702         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2703         do i=1,nres-1
2704           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2705      &     costab(i),sintab(i),costab2(i),sintab2(i)
2706         enddo
2707         write (iout,*) "Array MUDER"
2708         do i=1,nres-1
2709           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2710         enddo
2711 c      endif
2712 #endif
2713 #endif
2714 cd      do i=1,nres
2715 cd        iti = itortyp(itype(i))
2716 cd        write (iout,*) i
2717 cd        do j=1,2
2718 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2719 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2720 cd        enddo
2721 cd      enddo
2722       return
2723       end
2724 C--------------------------------------------------------------------------
2725       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2726 C
2727 C This subroutine calculates the average interaction energy and its gradient
2728 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2729 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2730 C The potential depends both on the distance of peptide-group centers and on
2731 C the orientation of the CA-CA virtual bonds.
2732 C
2733       implicit real*8 (a-h,o-z)
2734 #ifdef MPI
2735       include 'mpif.h'
2736 #endif
2737       include 'DIMENSIONS'
2738       include 'COMMON.CONTROL'
2739       include 'COMMON.SETUP'
2740       include 'COMMON.IOUNITS'
2741       include 'COMMON.GEO'
2742       include 'COMMON.VAR'
2743       include 'COMMON.LOCAL'
2744       include 'COMMON.CHAIN'
2745       include 'COMMON.DERIV'
2746       include 'COMMON.INTERACT'
2747       include 'COMMON.CONTACTS'
2748       include 'COMMON.TORSION'
2749       include 'COMMON.VECTORS'
2750       include 'COMMON.FFIELD'
2751       include 'COMMON.TIME1'
2752       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2753      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2754       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2755      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2756       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2757      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2758      &    num_conti,j1,j2
2759 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2760 #ifdef MOMENT
2761       double precision scal_el /1.0d0/
2762 #else
2763       double precision scal_el /0.5d0/
2764 #endif
2765 C 12/13/98
2766 C 13-go grudnia roku pamietnego...
2767       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2768      &                   0.0d0,1.0d0,0.0d0,
2769      &                   0.0d0,0.0d0,1.0d0/
2770 cd      write(iout,*) 'In EELEC'
2771 cd      do i=1,nloctyp
2772 cd        write(iout,*) 'Type',i
2773 cd        write(iout,*) 'B1',B1(:,i)
2774 cd        write(iout,*) 'B2',B2(:,i)
2775 cd        write(iout,*) 'CC',CC(:,:,i)
2776 cd        write(iout,*) 'DD',DD(:,:,i)
2777 cd        write(iout,*) 'EE',EE(:,:,i)
2778 cd      enddo
2779 cd      call check_vecgrad
2780 cd      stop
2781       if (icheckgrad.eq.1) then
2782         do i=1,nres-1
2783           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2784           do k=1,3
2785             dc_norm(k,i)=dc(k,i)*fac
2786           enddo
2787 c          write (iout,*) 'i',i,' fac',fac
2788         enddo
2789       endif
2790       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2791      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2792      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2793 c        call vec_and_deriv
2794 #ifdef TIMING
2795         time01=MPI_Wtime()
2796 #endif
2797         call set_matrices
2798 #ifdef TIMING
2799         time_mat=time_mat+MPI_Wtime()-time01
2800 #endif
2801       endif
2802 cd      do i=1,nres-1
2803 cd        write (iout,*) 'i=',i
2804 cd        do k=1,3
2805 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2806 cd        enddo
2807 cd        do k=1,3
2808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2810 cd        enddo
2811 cd      enddo
2812       t_eelecij=0.0d0
2813       ees=0.0D0
2814       evdw1=0.0D0
2815       eel_loc=0.0d0
2816       eello_turn3=0.0d0
2817       eello_turn4=0.0d0
2818       ind=0
2819       do i=1,nres
2820         num_cont_hb(i)=0
2821       enddo
2822 cd      print '(a)','Enter EELEC'
2823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2824       do i=1,nres
2825         gel_loc_loc(i)=0.0d0
2826         gcorr_loc(i)=0.0d0
2827       enddo
2828 c
2829 c
2830 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2831 C
2832 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2833 C
2834       do i=iturn3_start,iturn3_end
2835         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2836      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2837         dxi=dc(1,i)
2838         dyi=dc(2,i)
2839         dzi=dc(3,i)
2840         dx_normi=dc_norm(1,i)
2841         dy_normi=dc_norm(2,i)
2842         dz_normi=dc_norm(3,i)
2843         xmedi=c(1,i)+0.5d0*dxi
2844         ymedi=c(2,i)+0.5d0*dyi
2845         zmedi=c(3,i)+0.5d0*dzi
2846         num_conti=0
2847         call eelecij(i,i+2,ees,evdw1,eel_loc)
2848         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2849         num_cont_hb(i)=num_conti
2850       enddo
2851       do i=iturn4_start,iturn4_end
2852         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2853      &    .or. itype(i+3).eq.ntyp1
2854      &    .or. itype(i+4).eq.ntyp1) cycle
2855         dxi=dc(1,i)
2856         dyi=dc(2,i)
2857         dzi=dc(3,i)
2858         dx_normi=dc_norm(1,i)
2859         dy_normi=dc_norm(2,i)
2860         dz_normi=dc_norm(3,i)
2861         xmedi=c(1,i)+0.5d0*dxi
2862         ymedi=c(2,i)+0.5d0*dyi
2863         zmedi=c(3,i)+0.5d0*dzi
2864         num_conti=num_cont_hb(i)
2865         call eelecij(i,i+3,ees,evdw1,eel_loc)
2866         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2867      &   call eturn4(i,eello_turn4)
2868         num_cont_hb(i)=num_conti
2869       enddo   ! i
2870 c
2871 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2872 c
2873       do i=iatel_s,iatel_e
2874         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2875         dxi=dc(1,i)
2876         dyi=dc(2,i)
2877         dzi=dc(3,i)
2878         dx_normi=dc_norm(1,i)
2879         dy_normi=dc_norm(2,i)
2880         dz_normi=dc_norm(3,i)
2881         xmedi=c(1,i)+0.5d0*dxi
2882         ymedi=c(2,i)+0.5d0*dyi
2883         zmedi=c(3,i)+0.5d0*dzi
2884 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2885         num_conti=num_cont_hb(i)
2886         do j=ielstart(i),ielend(i)
2887 c          write (iout,*) i,j,itype(i),itype(j)
2888           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2889           call eelecij(i,j,ees,evdw1,eel_loc)
2890         enddo ! j
2891         num_cont_hb(i)=num_conti
2892       enddo   ! i
2893 c      write (iout,*) "Number of loop steps in EELEC:",ind
2894 cd      do i=1,nres
2895 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2896 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2897 cd      enddo
2898 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2899 ccc      eel_loc=eel_loc+eello_turn3
2900 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2901       return
2902       end
2903 C-------------------------------------------------------------------------------
2904       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2905       implicit real*8 (a-h,o-z)
2906       include 'DIMENSIONS'
2907 #ifdef MPI
2908       include "mpif.h"
2909 #endif
2910       include 'COMMON.CONTROL'
2911       include 'COMMON.IOUNITS'
2912       include 'COMMON.GEO'
2913       include 'COMMON.VAR'
2914       include 'COMMON.LOCAL'
2915       include 'COMMON.CHAIN'
2916       include 'COMMON.DERIV'
2917       include 'COMMON.INTERACT'
2918       include 'COMMON.CONTACTS'
2919       include 'COMMON.TORSION'
2920       include 'COMMON.VECTORS'
2921       include 'COMMON.FFIELD'
2922       include 'COMMON.TIME1'
2923       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2924      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2925       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2926      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2927       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2928      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2929      &    num_conti,j1,j2
2930 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2931 #ifdef MOMENT
2932       double precision scal_el /1.0d0/
2933 #else
2934       double precision scal_el /0.5d0/
2935 #endif
2936 C 12/13/98
2937 C 13-go grudnia roku pamietnego...
2938       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2939      &                   0.0d0,1.0d0,0.0d0,
2940      &                   0.0d0,0.0d0,1.0d0/
2941 c          time00=MPI_Wtime()
2942 cd      write (iout,*) "eelecij",i,j
2943 c          ind=ind+1
2944           iteli=itel(i)
2945           itelj=itel(j)
2946           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2947           aaa=app(iteli,itelj)
2948           bbb=bpp(iteli,itelj)
2949           ael6i=ael6(iteli,itelj)
2950           ael3i=ael3(iteli,itelj)
2951           dxj=dc(1,j)
2952           dyj=dc(2,j)
2953           dzj=dc(3,j)
2954           dx_normj=dc_norm(1,j)
2955           dy_normj=dc_norm(2,j)
2956           dz_normj=dc_norm(3,j)
2957           xj=c(1,j)+0.5D0*dxj-xmedi
2958           yj=c(2,j)+0.5D0*dyj-ymedi
2959           zj=c(3,j)+0.5D0*dzj-zmedi
2960           rij=xj*xj+yj*yj+zj*zj
2961           rrmij=1.0D0/rij
2962           rij=dsqrt(rij)
2963           rmij=1.0D0/rij
2964           r3ij=rrmij*rmij
2965           r6ij=r3ij*r3ij
2966           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2967           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2968           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2969           fac=cosa-3.0D0*cosb*cosg
2970           ev1=aaa*r6ij*r6ij
2971 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2972           if (j.eq.i+2) ev1=scal_el*ev1
2973           ev2=bbb*r6ij
2974           fac3=ael6i*r6ij
2975           fac4=ael3i*r3ij
2976           evdwij=ev1+ev2
2977           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2978           el2=fac4*fac
2979           eesij=el1+el2
2980 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2981           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2982           ees=ees+eesij
2983           evdw1=evdw1+evdwij
2984 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2985 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2986 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2987 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2988
2989           if (energy_dec) then
2990               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2991      &'evdw1',i,j,evdwij
2992      &,iteli,itelj,aaa,evdw1
2993               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2994           endif
2995
2996 C
2997 C Calculate contributions to the Cartesian gradient.
2998 C
2999 #ifdef SPLITELE
3000           facvdw=-6*rrmij*(ev1+evdwij)
3001           facel=-3*rrmij*(el1+eesij)
3002           fac1=fac
3003           erij(1)=xj*rmij
3004           erij(2)=yj*rmij
3005           erij(3)=zj*rmij
3006 *
3007 * Radial derivatives. First process both termini of the fragment (i,j)
3008 *
3009           ggg(1)=facel*xj
3010           ggg(2)=facel*yj
3011           ggg(3)=facel*zj
3012 c          do k=1,3
3013 c            ghalf=0.5D0*ggg(k)
3014 c            gelc(k,i)=gelc(k,i)+ghalf
3015 c            gelc(k,j)=gelc(k,j)+ghalf
3016 c          enddo
3017 c 9/28/08 AL Gradient compotents will be summed only at the end
3018           do k=1,3
3019             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3020             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3021           enddo
3022 *
3023 * Loop over residues i+1 thru j-1.
3024 *
3025 cgrad          do k=i+1,j-1
3026 cgrad            do l=1,3
3027 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3028 cgrad            enddo
3029 cgrad          enddo
3030           ggg(1)=facvdw*xj
3031           ggg(2)=facvdw*yj
3032           ggg(3)=facvdw*zj
3033 c          do k=1,3
3034 c            ghalf=0.5D0*ggg(k)
3035 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3036 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3037 c          enddo
3038 c 9/28/08 AL Gradient compotents will be summed only at the end
3039           do k=1,3
3040             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3041             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3042           enddo
3043 *
3044 * Loop over residues i+1 thru j-1.
3045 *
3046 cgrad          do k=i+1,j-1
3047 cgrad            do l=1,3
3048 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3049 cgrad            enddo
3050 cgrad          enddo
3051 #else
3052           facvdw=ev1+evdwij
3053           facel=el1+eesij
3054           fac1=fac
3055           fac=-3*rrmij*(facvdw+facvdw+facel)
3056           erij(1)=xj*rmij
3057           erij(2)=yj*rmij
3058           erij(3)=zj*rmij
3059 *
3060 * Radial derivatives. First process both termini of the fragment (i,j)
3061 *
3062           ggg(1)=fac*xj
3063           ggg(2)=fac*yj
3064           ggg(3)=fac*zj
3065 c          do k=1,3
3066 c            ghalf=0.5D0*ggg(k)
3067 c            gelc(k,i)=gelc(k,i)+ghalf
3068 c            gelc(k,j)=gelc(k,j)+ghalf
3069 c          enddo
3070 c 9/28/08 AL Gradient compotents will be summed only at the end
3071           do k=1,3
3072             gelc_long(k,j)=gelc(k,j)+ggg(k)
3073             gelc_long(k,i)=gelc(k,i)-ggg(k)
3074           enddo
3075 *
3076 * Loop over residues i+1 thru j-1.
3077 *
3078 cgrad          do k=i+1,j-1
3079 cgrad            do l=1,3
3080 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3081 cgrad            enddo
3082 cgrad          enddo
3083 c 9/28/08 AL Gradient compotents will be summed only at the end
3084           ggg(1)=facvdw*xj
3085           ggg(2)=facvdw*yj
3086           ggg(3)=facvdw*zj
3087           do k=1,3
3088             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3089             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3090           enddo
3091 #endif
3092 *
3093 * Angular part
3094 *
3095           ecosa=2.0D0*fac3*fac1+fac4
3096           fac4=-3.0D0*fac4
3097           fac3=-6.0D0*fac3
3098           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3099           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3100           do k=1,3
3101             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3102             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3103           enddo
3104 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3105 cd   &          (dcosg(k),k=1,3)
3106           do k=1,3
3107             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3108           enddo
3109 c          do k=1,3
3110 c            ghalf=0.5D0*ggg(k)
3111 c            gelc(k,i)=gelc(k,i)+ghalf
3112 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3113 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3114 c            gelc(k,j)=gelc(k,j)+ghalf
3115 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3116 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3117 c          enddo
3118 cgrad          do k=i+1,j-1
3119 cgrad            do l=1,3
3120 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3121 cgrad            enddo
3122 cgrad          enddo
3123           do k=1,3
3124             gelc(k,i)=gelc(k,i)
3125      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3126      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3127             gelc(k,j)=gelc(k,j)
3128      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3129      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3130             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3131             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3132           enddo
3133           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3134      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3135      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3136 C
3137 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3138 C   energy of a peptide unit is assumed in the form of a second-order
3139 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3140 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3141 C   are computed for EVERY pair of non-contiguous peptide groups.
3142 C
3143           if (j.lt.nres-1) then
3144             j1=j+1
3145             j2=j-1
3146           else
3147             j1=j-1
3148             j2=j-2
3149           endif
3150           kkk=0
3151           do k=1,2
3152             do l=1,2
3153               kkk=kkk+1
3154               muij(kkk)=mu(k,i)*mu(l,j)
3155             enddo
3156           enddo
3157 cd         write (iout,*) 'EELEC: i',i,' j',j
3158 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3159 cd          write(iout,*) 'muij',muij
3160           ury=scalar(uy(1,i),erij)
3161           urz=scalar(uz(1,i),erij)
3162           vry=scalar(uy(1,j),erij)
3163           vrz=scalar(uz(1,j),erij)
3164           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3165           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3166           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3167           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3168           fac=dsqrt(-ael6i)*r3ij
3169           a22=a22*fac
3170           a23=a23*fac
3171           a32=a32*fac
3172           a33=a33*fac
3173 cd          write (iout,'(4i5,4f10.5)')
3174 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3175 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3176 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3177 cd     &      uy(:,j),uz(:,j)
3178 cd          write (iout,'(4f10.5)')
3179 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3180 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3181 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3182 cd           write (iout,'(9f10.5/)')
3183 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3184 C Derivatives of the elements of A in virtual-bond vectors
3185           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3186           do k=1,3
3187             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3188             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3189             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3190             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3191             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3192             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3193             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3194             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3195             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3196             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3197             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3198             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3199           enddo
3200 C Compute radial contributions to the gradient
3201           facr=-3.0d0*rrmij
3202           a22der=a22*facr
3203           a23der=a23*facr
3204           a32der=a32*facr
3205           a33der=a33*facr
3206           agg(1,1)=a22der*xj
3207           agg(2,1)=a22der*yj
3208           agg(3,1)=a22der*zj
3209           agg(1,2)=a23der*xj
3210           agg(2,2)=a23der*yj
3211           agg(3,2)=a23der*zj
3212           agg(1,3)=a32der*xj
3213           agg(2,3)=a32der*yj
3214           agg(3,3)=a32der*zj
3215           agg(1,4)=a33der*xj
3216           agg(2,4)=a33der*yj
3217           agg(3,4)=a33der*zj
3218 C Add the contributions coming from er
3219           fac3=-3.0d0*fac
3220           do k=1,3
3221             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3222             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3223             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3224             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3225           enddo
3226           do k=1,3
3227 C Derivatives in DC(i)
3228 cgrad            ghalf1=0.5d0*agg(k,1)
3229 cgrad            ghalf2=0.5d0*agg(k,2)
3230 cgrad            ghalf3=0.5d0*agg(k,3)
3231 cgrad            ghalf4=0.5d0*agg(k,4)
3232             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3233      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3234             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3235      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3236             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3237      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3238             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3239      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3240 C Derivatives in DC(i+1)
3241             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3242      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3243             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3244      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3245             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3246      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3247             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3248      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3249 C Derivatives in DC(j)
3250             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3251      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3252             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3253      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3254             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3255      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3256             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3257      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3258 C Derivatives in DC(j+1) or DC(nres-1)
3259             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3260      &      -3.0d0*vryg(k,3)*ury)
3261             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3262      &      -3.0d0*vrzg(k,3)*ury)
3263             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3264      &      -3.0d0*vryg(k,3)*urz)
3265             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3266      &      -3.0d0*vrzg(k,3)*urz)
3267 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3268 cgrad              do l=1,4
3269 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3270 cgrad              enddo
3271 cgrad            endif
3272           enddo
3273           acipa(1,1)=a22
3274           acipa(1,2)=a23
3275           acipa(2,1)=a32
3276           acipa(2,2)=a33
3277           a22=-a22
3278           a23=-a23
3279           do l=1,2
3280             do k=1,3
3281               agg(k,l)=-agg(k,l)
3282               aggi(k,l)=-aggi(k,l)
3283               aggi1(k,l)=-aggi1(k,l)
3284               aggj(k,l)=-aggj(k,l)
3285               aggj1(k,l)=-aggj1(k,l)
3286             enddo
3287           enddo
3288           if (j.lt.nres-1) then
3289             a22=-a22
3290             a32=-a32
3291             do l=1,3,2
3292               do k=1,3
3293                 agg(k,l)=-agg(k,l)
3294                 aggi(k,l)=-aggi(k,l)
3295                 aggi1(k,l)=-aggi1(k,l)
3296                 aggj(k,l)=-aggj(k,l)
3297                 aggj1(k,l)=-aggj1(k,l)
3298               enddo
3299             enddo
3300           else
3301             a22=-a22
3302             a23=-a23
3303             a32=-a32
3304             a33=-a33
3305             do l=1,4
3306               do k=1,3
3307                 agg(k,l)=-agg(k,l)
3308                 aggi(k,l)=-aggi(k,l)
3309                 aggi1(k,l)=-aggi1(k,l)
3310                 aggj(k,l)=-aggj(k,l)
3311                 aggj1(k,l)=-aggj1(k,l)
3312               enddo
3313             enddo
3314           endif
3315           ENDIF ! WCORR
3316           IF (wel_loc.gt.0.0d0) THEN
3317 C Contribution to the local-electrostatic energy coming from the i-j pair
3318           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3319      &     +a33*muij(4)
3320 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3321
3322           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3323      &            'eelloc',i,j,eel_loc_ij
3324 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3325
3326           eel_loc=eel_loc+eel_loc_ij
3327 C Partial derivatives in virtual-bond dihedral angles gamma
3328           if (i.gt.1)
3329      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3330      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3331      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3332           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3333      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3334      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3335 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3336           do l=1,3
3337             ggg(l)=agg(l,1)*muij(1)+
3338      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3339             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3340             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3341 cgrad            ghalf=0.5d0*ggg(l)
3342 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3343 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3344           enddo
3345 cgrad          do k=i+1,j2
3346 cgrad            do l=1,3
3347 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3348 cgrad            enddo
3349 cgrad          enddo
3350 C Remaining derivatives of eello
3351           do l=1,3
3352             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3353      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3354             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3355      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3356             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3357      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3358             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3359      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3360           enddo
3361           ENDIF
3362 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3363 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3364           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3365      &       .and. num_conti.le.maxconts) then
3366 c            write (iout,*) i,j," entered corr"
3367 C
3368 C Calculate the contact function. The ith column of the array JCONT will
3369 C contain the numbers of atoms that make contacts with the atom I (of numbers
3370 C greater than I). The arrays FACONT and GACONT will contain the values of
3371 C the contact function and its derivative.
3372 c           r0ij=1.02D0*rpp(iteli,itelj)
3373 c           r0ij=1.11D0*rpp(iteli,itelj)
3374             r0ij=2.20D0*rpp(iteli,itelj)
3375 c           r0ij=1.55D0*rpp(iteli,itelj)
3376             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3377             if (fcont.gt.0.0D0) then
3378               num_conti=num_conti+1
3379               if (num_conti.gt.maxconts) then
3380                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3381      &                         ' will skip next contacts for this conf.'
3382               else
3383                 jcont_hb(num_conti,i)=j
3384 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3385 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3386                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3387      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3388 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3389 C  terms.
3390                 d_cont(num_conti,i)=rij
3391 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3392 C     --- Electrostatic-interaction matrix ---
3393                 a_chuj(1,1,num_conti,i)=a22
3394                 a_chuj(1,2,num_conti,i)=a23
3395                 a_chuj(2,1,num_conti,i)=a32
3396                 a_chuj(2,2,num_conti,i)=a33
3397 C     --- Gradient of rij
3398                 do kkk=1,3
3399                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3400                 enddo
3401                 kkll=0
3402                 do k=1,2
3403                   do l=1,2
3404                     kkll=kkll+1
3405                     do m=1,3
3406                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3407                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3408                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3409                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3410                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3411                     enddo
3412                   enddo
3413                 enddo
3414                 ENDIF
3415                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3416 C Calculate contact energies
3417                 cosa4=4.0D0*cosa
3418                 wij=cosa-3.0D0*cosb*cosg
3419                 cosbg1=cosb+cosg
3420                 cosbg2=cosb-cosg
3421 c               fac3=dsqrt(-ael6i)/r0ij**3
3422                 fac3=dsqrt(-ael6i)*r3ij
3423 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3424                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3425                 if (ees0tmp.gt.0) then
3426                   ees0pij=dsqrt(ees0tmp)
3427                 else
3428                   ees0pij=0
3429                 endif
3430 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3431                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3432                 if (ees0tmp.gt.0) then
3433                   ees0mij=dsqrt(ees0tmp)
3434                 else
3435                   ees0mij=0
3436                 endif
3437 c               ees0mij=0.0D0
3438                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3439                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3440 C Diagnostics. Comment out or remove after debugging!
3441 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3442 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3443 c               ees0m(num_conti,i)=0.0D0
3444 C End diagnostics.
3445 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3446 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3447 C Angular derivatives of the contact function
3448                 ees0pij1=fac3/ees0pij
3449                 ees0mij1=fac3/ees0mij
3450                 fac3p=-3.0D0*fac3*rrmij
3451                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3452                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3453 c               ees0mij1=0.0D0
3454                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3455                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3456                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3457                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3458                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3459                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3460                 ecosap=ecosa1+ecosa2
3461                 ecosbp=ecosb1+ecosb2
3462                 ecosgp=ecosg1+ecosg2
3463                 ecosam=ecosa1-ecosa2
3464                 ecosbm=ecosb1-ecosb2
3465                 ecosgm=ecosg1-ecosg2
3466 C Diagnostics
3467 c               ecosap=ecosa1
3468 c               ecosbp=ecosb1
3469 c               ecosgp=ecosg1
3470 c               ecosam=0.0D0
3471 c               ecosbm=0.0D0
3472 c               ecosgm=0.0D0
3473 C End diagnostics
3474                 facont_hb(num_conti,i)=fcont
3475                 fprimcont=fprimcont/rij
3476 cd              facont_hb(num_conti,i)=1.0D0
3477 C Following line is for diagnostics.
3478 cd              fprimcont=0.0D0
3479                 do k=1,3
3480                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3481                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3482                 enddo
3483                 do k=1,3
3484                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3485                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3486                 enddo
3487                 gggp(1)=gggp(1)+ees0pijp*xj
3488                 gggp(2)=gggp(2)+ees0pijp*yj
3489                 gggp(3)=gggp(3)+ees0pijp*zj
3490                 gggm(1)=gggm(1)+ees0mijp*xj
3491                 gggm(2)=gggm(2)+ees0mijp*yj
3492                 gggm(3)=gggm(3)+ees0mijp*zj
3493 C Derivatives due to the contact function
3494                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3495                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3496                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3497                 do k=1,3
3498 c
3499 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3500 c          following the change of gradient-summation algorithm.
3501 c
3502 cgrad                  ghalfp=0.5D0*gggp(k)
3503 cgrad                  ghalfm=0.5D0*gggm(k)
3504                   gacontp_hb1(k,num_conti,i)=!ghalfp
3505      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3506      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3507                   gacontp_hb2(k,num_conti,i)=!ghalfp
3508      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3509      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3510                   gacontp_hb3(k,num_conti,i)=gggp(k)
3511                   gacontm_hb1(k,num_conti,i)=!ghalfm
3512      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3513      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3514                   gacontm_hb2(k,num_conti,i)=!ghalfm
3515      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3516      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3517                   gacontm_hb3(k,num_conti,i)=gggm(k)
3518                 enddo
3519 C Diagnostics. Comment out or remove after debugging!
3520 cdiag           do k=1,3
3521 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3522 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3523 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3524 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3525 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3526 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3527 cdiag           enddo
3528               ENDIF ! wcorr
3529               endif  ! num_conti.le.maxconts
3530             endif  ! fcont.gt.0
3531           endif    ! j.gt.i+1
3532           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3533             do k=1,4
3534               do l=1,3
3535                 ghalf=0.5d0*agg(l,k)
3536                 aggi(l,k)=aggi(l,k)+ghalf
3537                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3538                 aggj(l,k)=aggj(l,k)+ghalf
3539               enddo
3540             enddo
3541             if (j.eq.nres-1 .and. i.lt.j-2) then
3542               do k=1,4
3543                 do l=1,3
3544                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3545                 enddo
3546               enddo
3547             endif
3548           endif
3549 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3550       return
3551       end
3552 C-----------------------------------------------------------------------------
3553       subroutine eturn3(i,eello_turn3)
3554 C Third- and fourth-order contributions from turns
3555       implicit real*8 (a-h,o-z)
3556       include 'DIMENSIONS'
3557       include 'COMMON.IOUNITS'
3558       include 'COMMON.GEO'
3559       include 'COMMON.VAR'
3560       include 'COMMON.LOCAL'
3561       include 'COMMON.CHAIN'
3562       include 'COMMON.DERIV'
3563       include 'COMMON.INTERACT'
3564       include 'COMMON.CONTACTS'
3565       include 'COMMON.TORSION'
3566       include 'COMMON.VECTORS'
3567       include 'COMMON.FFIELD'
3568       include 'COMMON.CONTROL'
3569       dimension ggg(3)
3570       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3571      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3572      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3573       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3574      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3575       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3576      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3577      &    num_conti,j1,j2
3578       j=i+2
3579 c      write (iout,*) "eturn3",i,j,j1,j2
3580       a_temp(1,1)=a22
3581       a_temp(1,2)=a23
3582       a_temp(2,1)=a32
3583       a_temp(2,2)=a33
3584 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3585 C
3586 C               Third-order contributions
3587 C
3588 C                 (i+2)o----(i+3)
3589 C                      | |
3590 C                      | |
3591 C                 (i+1)o----i
3592 C
3593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3594 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3595         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3596         call transpose2(auxmat(1,1),auxmat1(1,1))
3597         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3598         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3599         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3600      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3601 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3602 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3603 cd     &    ' eello_turn3_num',4*eello_turn3_num
3604 C Derivatives in gamma(i)
3605         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3606         call transpose2(auxmat2(1,1),auxmat3(1,1))
3607         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3608         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3609 C Derivatives in gamma(i+1)
3610         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3611         call transpose2(auxmat2(1,1),auxmat3(1,1))
3612         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3613         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3614      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3615 C Cartesian derivatives
3616         do l=1,3
3617 c            ghalf1=0.5d0*agg(l,1)
3618 c            ghalf2=0.5d0*agg(l,2)
3619 c            ghalf3=0.5d0*agg(l,3)
3620 c            ghalf4=0.5d0*agg(l,4)
3621           a_temp(1,1)=aggi(l,1)!+ghalf1
3622           a_temp(1,2)=aggi(l,2)!+ghalf2
3623           a_temp(2,1)=aggi(l,3)!+ghalf3
3624           a_temp(2,2)=aggi(l,4)!+ghalf4
3625           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3626           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3627      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3628           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3629           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3630           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3631           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3632           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3633           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3634      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3635           a_temp(1,1)=aggj(l,1)!+ghalf1
3636           a_temp(1,2)=aggj(l,2)!+ghalf2
3637           a_temp(2,1)=aggj(l,3)!+ghalf3
3638           a_temp(2,2)=aggj(l,4)!+ghalf4
3639           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3640           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3641      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3642           a_temp(1,1)=aggj1(l,1)
3643           a_temp(1,2)=aggj1(l,2)
3644           a_temp(2,1)=aggj1(l,3)
3645           a_temp(2,2)=aggj1(l,4)
3646           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3647           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3648      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3649         enddo
3650       return
3651       end
3652 C-------------------------------------------------------------------------------
3653       subroutine eturn4(i,eello_turn4)
3654 C Third- and fourth-order contributions from turns
3655       implicit real*8 (a-h,o-z)
3656       include 'DIMENSIONS'
3657       include 'COMMON.IOUNITS'
3658       include 'COMMON.GEO'
3659       include 'COMMON.VAR'
3660       include 'COMMON.LOCAL'
3661       include 'COMMON.CHAIN'
3662       include 'COMMON.DERIV'
3663       include 'COMMON.INTERACT'
3664       include 'COMMON.CONTACTS'
3665       include 'COMMON.TORSION'
3666       include 'COMMON.VECTORS'
3667       include 'COMMON.FFIELD'
3668       include 'COMMON.CONTROL'
3669       dimension ggg(3)
3670       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3671      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3672      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3673       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3674      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3675       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3676      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3677      &    num_conti,j1,j2
3678       j=i+3
3679 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3680 C
3681 C               Fourth-order contributions
3682 C
3683 C                 (i+3)o----(i+4)
3684 C                     /  |
3685 C               (i+2)o   |
3686 C                     \  |
3687 C                 (i+1)o----i
3688 C
3689 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3690 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3691 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3692         a_temp(1,1)=a22
3693         a_temp(1,2)=a23
3694         a_temp(2,1)=a32
3695         a_temp(2,2)=a33
3696         iti1=itortyp(itype(i+1))
3697         iti2=itortyp(itype(i+2))
3698         iti3=itortyp(itype(i+3))
3699 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3700         call transpose2(EUg(1,1,i+1),e1t(1,1))
3701         call transpose2(Eug(1,1,i+2),e2t(1,1))
3702         call transpose2(Eug(1,1,i+3),e3t(1,1))
3703         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3704         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3705         s1=scalar2(b1(1,iti2),auxvec(1))
3706         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3707         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3708         s2=scalar2(b1(1,iti1),auxvec(1))
3709         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3710         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3711         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3712         eello_turn4=eello_turn4-(s1+s2+s3)
3713         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3714      &      'eturn4',i,j,-(s1+s2+s3)
3715 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3716 cd     &    ' eello_turn4_num',8*eello_turn4_num
3717 C Derivatives in gamma(i)
3718         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3719         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3720         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3721         s1=scalar2(b1(1,iti2),auxvec(1))
3722         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3723         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3724         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3725 C Derivatives in gamma(i+1)
3726         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3727         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3728         s2=scalar2(b1(1,iti1),auxvec(1))
3729         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3730         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3731         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3732         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3733 C Derivatives in gamma(i+2)
3734         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3735         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3736         s1=scalar2(b1(1,iti2),auxvec(1))
3737         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3738         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3739         s2=scalar2(b1(1,iti1),auxvec(1))
3740         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3741         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3742         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3743         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3744 C Cartesian derivatives
3745 C Derivatives of this turn contributions in DC(i+2)
3746         if (j.lt.nres-1) then
3747           do l=1,3
3748             a_temp(1,1)=agg(l,1)
3749             a_temp(1,2)=agg(l,2)
3750             a_temp(2,1)=agg(l,3)
3751             a_temp(2,2)=agg(l,4)
3752             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3753             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3754             s1=scalar2(b1(1,iti2),auxvec(1))
3755             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3756             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3757             s2=scalar2(b1(1,iti1),auxvec(1))
3758             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3759             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3760             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3761             ggg(l)=-(s1+s2+s3)
3762             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3763           enddo
3764         endif
3765 C Remaining derivatives of this turn contribution
3766         do l=1,3
3767           a_temp(1,1)=aggi(l,1)
3768           a_temp(1,2)=aggi(l,2)
3769           a_temp(2,1)=aggi(l,3)
3770           a_temp(2,2)=aggi(l,4)
3771           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3772           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3773           s1=scalar2(b1(1,iti2),auxvec(1))
3774           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3775           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3776           s2=scalar2(b1(1,iti1),auxvec(1))
3777           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3778           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3779           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3780           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3781           a_temp(1,1)=aggi1(l,1)
3782           a_temp(1,2)=aggi1(l,2)
3783           a_temp(2,1)=aggi1(l,3)
3784           a_temp(2,2)=aggi1(l,4)
3785           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3786           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3787           s1=scalar2(b1(1,iti2),auxvec(1))
3788           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3789           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3790           s2=scalar2(b1(1,iti1),auxvec(1))
3791           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3792           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3793           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3794           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3795           a_temp(1,1)=aggj(l,1)
3796           a_temp(1,2)=aggj(l,2)
3797           a_temp(2,1)=aggj(l,3)
3798           a_temp(2,2)=aggj(l,4)
3799           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3800           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3801           s1=scalar2(b1(1,iti2),auxvec(1))
3802           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3803           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3804           s2=scalar2(b1(1,iti1),auxvec(1))
3805           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3806           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3807           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3808           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3809           a_temp(1,1)=aggj1(l,1)
3810           a_temp(1,2)=aggj1(l,2)
3811           a_temp(2,1)=aggj1(l,3)
3812           a_temp(2,2)=aggj1(l,4)
3813           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3814           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3815           s1=scalar2(b1(1,iti2),auxvec(1))
3816           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3817           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3818           s2=scalar2(b1(1,iti1),auxvec(1))
3819           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3820           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3821           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3822 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3823           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3824         enddo
3825       return
3826       end
3827 C-----------------------------------------------------------------------------
3828       subroutine vecpr(u,v,w)
3829       implicit real*8(a-h,o-z)
3830       dimension u(3),v(3),w(3)
3831       w(1)=u(2)*v(3)-u(3)*v(2)
3832       w(2)=-u(1)*v(3)+u(3)*v(1)
3833       w(3)=u(1)*v(2)-u(2)*v(1)
3834       return
3835       end
3836 C-----------------------------------------------------------------------------
3837       subroutine unormderiv(u,ugrad,unorm,ungrad)
3838 C This subroutine computes the derivatives of a normalized vector u, given
3839 C the derivatives computed without normalization conditions, ugrad. Returns
3840 C ungrad.
3841       implicit none
3842       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3843       double precision vec(3)
3844       double precision scalar
3845       integer i,j
3846 c      write (2,*) 'ugrad',ugrad
3847 c      write (2,*) 'u',u
3848       do i=1,3
3849         vec(i)=scalar(ugrad(1,i),u(1))
3850       enddo
3851 c      write (2,*) 'vec',vec
3852       do i=1,3
3853         do j=1,3
3854           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3855         enddo
3856       enddo
3857 c      write (2,*) 'ungrad',ungrad
3858       return
3859       end
3860 C-----------------------------------------------------------------------------
3861       subroutine escp_soft_sphere(evdw2,evdw2_14)
3862 C
3863 C This subroutine calculates the excluded-volume interaction energy between
3864 C peptide-group centers and side chains and its gradient in virtual-bond and
3865 C side-chain vectors.
3866 C
3867       implicit real*8 (a-h,o-z)
3868       include 'DIMENSIONS'
3869       include 'COMMON.GEO'
3870       include 'COMMON.VAR'
3871       include 'COMMON.LOCAL'
3872       include 'COMMON.CHAIN'
3873       include 'COMMON.DERIV'
3874       include 'COMMON.INTERACT'
3875       include 'COMMON.FFIELD'
3876       include 'COMMON.IOUNITS'
3877       include 'COMMON.CONTROL'
3878       dimension ggg(3)
3879       evdw2=0.0D0
3880       evdw2_14=0.0d0
3881       r0_scp=4.5d0
3882 cd    print '(a)','Enter ESCP'
3883 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3884       do i=iatscp_s,iatscp_e
3885         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3886         iteli=itel(i)
3887         xi=0.5D0*(c(1,i)+c(1,i+1))
3888         yi=0.5D0*(c(2,i)+c(2,i+1))
3889         zi=0.5D0*(c(3,i)+c(3,i+1))
3890
3891         do iint=1,nscp_gr(i)
3892
3893         do j=iscpstart(i,iint),iscpend(i,iint)
3894           if (itype(j).eq.ntyp1) cycle
3895           itypj=iabs(itype(j))
3896 C Uncomment following three lines for SC-p interactions
3897 c         xj=c(1,nres+j)-xi
3898 c         yj=c(2,nres+j)-yi
3899 c         zj=c(3,nres+j)-zi
3900 C Uncomment following three lines for Ca-p interactions
3901           xj=c(1,j)-xi
3902           yj=c(2,j)-yi
3903           zj=c(3,j)-zi
3904           rij=xj*xj+yj*yj+zj*zj
3905           r0ij=r0_scp
3906           r0ijsq=r0ij*r0ij
3907           if (rij.lt.r0ijsq) then
3908             evdwij=0.25d0*(rij-r0ijsq)**2
3909             fac=rij-r0ijsq
3910           else
3911             evdwij=0.0d0
3912             fac=0.0d0
3913           endif
3914           evdw2=evdw2+evdwij
3915 C
3916 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3917 C
3918           ggg(1)=xj*fac
3919           ggg(2)=yj*fac
3920           ggg(3)=zj*fac
3921 cgrad          if (j.lt.i) then
3922 cd          write (iout,*) 'j<i'
3923 C Uncomment following three lines for SC-p interactions
3924 c           do k=1,3
3925 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3926 c           enddo
3927 cgrad          else
3928 cd          write (iout,*) 'j>i'
3929 cgrad            do k=1,3
3930 cgrad              ggg(k)=-ggg(k)
3931 C Uncomment following line for SC-p interactions
3932 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3933 cgrad            enddo
3934 cgrad          endif
3935 cgrad          do k=1,3
3936 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3937 cgrad          enddo
3938 cgrad          kstart=min0(i+1,j)
3939 cgrad          kend=max0(i-1,j-1)
3940 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3941 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3942 cgrad          do k=kstart,kend
3943 cgrad            do l=1,3
3944 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3945 cgrad            enddo
3946 cgrad          enddo
3947           do k=1,3
3948             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3949             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3950           enddo
3951         enddo
3952
3953         enddo ! iint
3954       enddo ! i
3955       return
3956       end
3957 C-----------------------------------------------------------------------------
3958       subroutine escp(evdw2,evdw2_14)
3959 C
3960 C This subroutine calculates the excluded-volume interaction energy between
3961 C peptide-group centers and side chains and its gradient in virtual-bond and
3962 C side-chain vectors.
3963 C
3964       implicit real*8 (a-h,o-z)
3965       include 'DIMENSIONS'
3966       include 'COMMON.GEO'
3967       include 'COMMON.VAR'
3968       include 'COMMON.LOCAL'
3969       include 'COMMON.CHAIN'
3970       include 'COMMON.DERIV'
3971       include 'COMMON.INTERACT'
3972       include 'COMMON.FFIELD'
3973       include 'COMMON.IOUNITS'
3974       include 'COMMON.CONTROL'
3975       dimension ggg(3)
3976       evdw2=0.0D0
3977       evdw2_14=0.0d0
3978 cd    print '(a)','Enter ESCP'
3979 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3980       do i=iatscp_s,iatscp_e
3981         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3982         iteli=itel(i)
3983         xi=0.5D0*(c(1,i)+c(1,i+1))
3984         yi=0.5D0*(c(2,i)+c(2,i+1))
3985         zi=0.5D0*(c(3,i)+c(3,i+1))
3986
3987         do iint=1,nscp_gr(i)
3988
3989         do j=iscpstart(i,iint),iscpend(i,iint)
3990           itypj=iabs(itype(j))
3991           if (itypj.eq.ntyp1) cycle
3992 C Uncomment following three lines for SC-p interactions
3993 c         xj=c(1,nres+j)-xi
3994 c         yj=c(2,nres+j)-yi
3995 c         zj=c(3,nres+j)-zi
3996 C Uncomment following three lines for Ca-p interactions
3997           xj=c(1,j)-xi
3998           yj=c(2,j)-yi
3999           zj=c(3,j)-zi
4000           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4001           fac=rrij**expon2
4002           e1=fac*fac*aad(itypj,iteli)
4003           e2=fac*bad(itypj,iteli)
4004           if (iabs(j-i) .le. 2) then
4005             e1=scal14*e1
4006             e2=scal14*e2
4007             evdw2_14=evdw2_14+e1+e2
4008           endif
4009           evdwij=e1+e2
4010           evdw2=evdw2+evdwij
4011           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4012      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4013      &       bad(itypj,iteli)
4014 C
4015 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4016 C
4017           fac=-(evdwij+e1)*rrij
4018           ggg(1)=xj*fac
4019           ggg(2)=yj*fac
4020           ggg(3)=zj*fac
4021 cgrad          if (j.lt.i) then
4022 cd          write (iout,*) 'j<i'
4023 C Uncomment following three lines for SC-p interactions
4024 c           do k=1,3
4025 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4026 c           enddo
4027 cgrad          else
4028 cd          write (iout,*) 'j>i'
4029 cgrad            do k=1,3
4030 cgrad              ggg(k)=-ggg(k)
4031 C Uncomment following line for SC-p interactions
4032 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4033 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4034 cgrad            enddo
4035 cgrad          endif
4036 cgrad          do k=1,3
4037 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4038 cgrad          enddo
4039 cgrad          kstart=min0(i+1,j)
4040 cgrad          kend=max0(i-1,j-1)
4041 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4042 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4043 cgrad          do k=kstart,kend
4044 cgrad            do l=1,3
4045 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4046 cgrad            enddo
4047 cgrad          enddo
4048           do k=1,3
4049             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4050             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4051           enddo
4052         enddo
4053
4054         enddo ! iint
4055       enddo ! i
4056       do i=1,nct
4057         do j=1,3
4058           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4059           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4060           gradx_scp(j,i)=expon*gradx_scp(j,i)
4061         enddo
4062       enddo
4063 C******************************************************************************
4064 C
4065 C                              N O T E !!!
4066 C
4067 C To save time the factor EXPON has been extracted from ALL components
4068 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4069 C use!
4070 C
4071 C******************************************************************************
4072       return
4073       end
4074 C--------------------------------------------------------------------------
4075       subroutine edis(ehpb)
4076 C
4077 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4078 C
4079       implicit real*8 (a-h,o-z)
4080       include 'DIMENSIONS'
4081       include 'COMMON.SBRIDGE'
4082       include 'COMMON.CHAIN'
4083       include 'COMMON.DERIV'
4084       include 'COMMON.VAR'
4085       include 'COMMON.INTERACT'
4086       include 'COMMON.IOUNITS'
4087       dimension ggg(3)
4088       ehpb=0.0D0
4089 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4090 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4091       if (link_end.eq.0) return
4092       do i=link_start,link_end
4093 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4094 C CA-CA distance used in regularization of structure.
4095         ii=ihpb(i)
4096         jj=jhpb(i)
4097 C iii and jjj point to the residues for which the distance is assigned.
4098         if (ii.gt.nres) then
4099           iii=ii-nres
4100           jjj=jj-nres
4101         else
4102           iii=ii
4103           jjj=jj
4104         endif
4105 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4106 c     &    dhpb(i),dhpb1(i),forcon(i)
4107 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4108 C    distance and angle dependent SS bond potential.
4109 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4110 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4111         if (.not.dyn_ss .and. i.le.nss) then
4112 C 15/02/13 CC dynamic SSbond - additional check
4113          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4114      & iabs(itype(jjj)).eq.1) then
4115           call ssbond_ene(iii,jjj,eij)
4116           ehpb=ehpb+2*eij
4117          endif
4118 cd          write (iout,*) "eij",eij
4119         else
4120 C Calculate the distance between the two points and its difference from the
4121 C target distance.
4122           dd=dist(ii,jj)
4123             rdis=dd-dhpb(i)
4124 C Get the force constant corresponding to this distance.
4125             waga=forcon(i)
4126 C Calculate the contribution to energy.
4127             ehpb=ehpb+waga*rdis*rdis
4128 C
4129 C Evaluate gradient.
4130 C
4131             fac=waga*rdis/dd
4132 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4133 cd   &   ' waga=',waga,' fac=',fac
4134             do j=1,3
4135               ggg(j)=fac*(c(j,jj)-c(j,ii))
4136             enddo
4137 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4138 C If this is a SC-SC distance, we need to calculate the contributions to the
4139 C Cartesian gradient in the SC vectors (ghpbx).
4140           if (iii.lt.ii) then
4141           do j=1,3
4142             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4143             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4144           enddo
4145           endif
4146 cgrad        do j=iii,jjj-1
4147 cgrad          do k=1,3
4148 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4149 cgrad          enddo
4150 cgrad        enddo
4151           do k=1,3
4152             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4153             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4154           enddo
4155         endif
4156       enddo
4157       ehpb=0.5D0*ehpb
4158       return
4159       end
4160 C--------------------------------------------------------------------------
4161       subroutine ssbond_ene(i,j,eij)
4162 C
4163 C Calculate the distance and angle dependent SS-bond potential energy
4164 C using a free-energy function derived based on RHF/6-31G** ab initio
4165 C calculations of diethyl disulfide.
4166 C
4167 C A. Liwo and U. Kozlowska, 11/24/03
4168 C
4169       implicit real*8 (a-h,o-z)
4170       include 'DIMENSIONS'
4171       include 'COMMON.SBRIDGE'
4172       include 'COMMON.CHAIN'
4173       include 'COMMON.DERIV'
4174       include 'COMMON.LOCAL'
4175       include 'COMMON.INTERACT'
4176       include 'COMMON.VAR'
4177       include 'COMMON.IOUNITS'
4178       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4179       itypi=iabs(itype(i))
4180       xi=c(1,nres+i)
4181       yi=c(2,nres+i)
4182       zi=c(3,nres+i)
4183       dxi=dc_norm(1,nres+i)
4184       dyi=dc_norm(2,nres+i)
4185       dzi=dc_norm(3,nres+i)
4186 c      dsci_inv=dsc_inv(itypi)
4187       dsci_inv=vbld_inv(nres+i)
4188       itypj=iabs(itype(j))
4189 c      dscj_inv=dsc_inv(itypj)
4190       dscj_inv=vbld_inv(nres+j)
4191       xj=c(1,nres+j)-xi
4192       yj=c(2,nres+j)-yi
4193       zj=c(3,nres+j)-zi
4194       dxj=dc_norm(1,nres+j)
4195       dyj=dc_norm(2,nres+j)
4196       dzj=dc_norm(3,nres+j)
4197       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4198       rij=dsqrt(rrij)
4199       erij(1)=xj*rij
4200       erij(2)=yj*rij
4201       erij(3)=zj*rij
4202       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4203       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4204       om12=dxi*dxj+dyi*dyj+dzi*dzj
4205       do k=1,3
4206         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4207         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4208       enddo
4209       rij=1.0d0/rij
4210       deltad=rij-d0cm
4211       deltat1=1.0d0-om1
4212       deltat2=1.0d0+om2
4213       deltat12=om2-om1+2.0d0
4214       cosphi=om12-om1*om2
4215       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4216      &  +akct*deltad*deltat12
4217      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4218 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4219 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4220 c     &  " deltat12",deltat12," eij",eij
4221       ed=2*akcm*deltad+akct*deltat12
4222       pom1=akct*deltad
4223       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4224       eom1=-2*akth*deltat1-pom1-om2*pom2
4225       eom2= 2*akth*deltat2+pom1-om1*pom2
4226       eom12=pom2
4227       do k=1,3
4228         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4229         ghpbx(k,i)=ghpbx(k,i)-ggk
4230      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4231      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4232         ghpbx(k,j)=ghpbx(k,j)+ggk
4233      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4234      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4235         ghpbc(k,i)=ghpbc(k,i)-ggk
4236         ghpbc(k,j)=ghpbc(k,j)+ggk
4237       enddo
4238 C
4239 C Calculate the components of the gradient in DC and X
4240 C
4241 cgrad      do k=i,j-1
4242 cgrad        do l=1,3
4243 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4244 cgrad        enddo
4245 cgrad      enddo
4246       return
4247       end
4248 C--------------------------------------------------------------------------
4249       subroutine ebond(estr)
4250 c
4251 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4252 c
4253       implicit real*8 (a-h,o-z)
4254       include 'DIMENSIONS'
4255       include 'COMMON.LOCAL'
4256       include 'COMMON.GEO'
4257       include 'COMMON.INTERACT'
4258       include 'COMMON.DERIV'
4259       include 'COMMON.VAR'
4260       include 'COMMON.CHAIN'
4261       include 'COMMON.IOUNITS'
4262       include 'COMMON.NAMES'
4263       include 'COMMON.FFIELD'
4264       include 'COMMON.CONTROL'
4265       include 'COMMON.SETUP'
4266       double precision u(3),ud(3)
4267       estr=0.0d0
4268       estr1=0.0d0
4269       do i=ibondp_start,ibondp_end
4270         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4271           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4272           do j=1,3
4273           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4274      &      *dc(j,i-1)/vbld(i)
4275           enddo
4276           if (energy_dec) write(iout,*)
4277      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4278         else
4279         diff = vbld(i)-vbldp0
4280         if (energy_dec) write (iout,*)
4281      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4282         estr=estr+diff*diff
4283         do j=1,3
4284           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4285         enddo
4286 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4287         endif
4288       enddo
4289       estr=0.5d0*AKP*estr+estr1
4290 c
4291 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4292 c
4293       do i=ibond_start,ibond_end
4294         iti=iabs(itype(i))
4295         if (iti.ne.10 .and. iti.ne.ntyp1) then
4296           nbi=nbondterm(iti)
4297           if (nbi.eq.1) then
4298             diff=vbld(i+nres)-vbldsc0(1,iti)
4299             if (energy_dec) write (iout,*)
4300      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4301      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4302             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4303             do j=1,3
4304               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4305             enddo
4306           else
4307             do j=1,nbi
4308               diff=vbld(i+nres)-vbldsc0(j,iti)
4309               ud(j)=aksc(j,iti)*diff
4310               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4311             enddo
4312             uprod=u(1)
4313             do j=2,nbi
4314               uprod=uprod*u(j)
4315             enddo
4316             usum=0.0d0
4317             usumsqder=0.0d0
4318             do j=1,nbi
4319               uprod1=1.0d0
4320               uprod2=1.0d0
4321               do k=1,nbi
4322                 if (k.ne.j) then
4323                   uprod1=uprod1*u(k)
4324                   uprod2=uprod2*u(k)*u(k)
4325                 endif
4326               enddo
4327               usum=usum+uprod1
4328               usumsqder=usumsqder+ud(j)*uprod2
4329             enddo
4330             estr=estr+uprod/usum
4331             do j=1,3
4332              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4333             enddo
4334           endif
4335         endif
4336       enddo
4337       return
4338       end
4339 #ifdef CRYST_THETA
4340 C--------------------------------------------------------------------------
4341       subroutine ebend(etheta)
4342 C
4343 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4344 C angles gamma and its derivatives in consecutive thetas and gammas.
4345 C
4346       implicit real*8 (a-h,o-z)
4347       include 'DIMENSIONS'
4348       include 'COMMON.LOCAL'
4349       include 'COMMON.GEO'
4350       include 'COMMON.INTERACT'
4351       include 'COMMON.DERIV'
4352       include 'COMMON.VAR'
4353       include 'COMMON.CHAIN'
4354       include 'COMMON.IOUNITS'
4355       include 'COMMON.NAMES'
4356       include 'COMMON.FFIELD'
4357       include 'COMMON.CONTROL'
4358       common /calcthet/ term1,term2,termm,diffak,ratak,
4359      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4360      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4361       double precision y(2),z(2)
4362       delta=0.02d0*pi
4363 c      time11=dexp(-2*time)
4364 c      time12=1.0d0
4365       etheta=0.0D0
4366 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4367       do i=ithet_start,ithet_end
4368         if (itype(i-1).eq.ntyp1) cycle
4369 C Zero the energy function and its derivative at 0 or pi.
4370         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4371         it=itype(i-1)
4372         ichir1=isign(1,itype(i-2))
4373         ichir2=isign(1,itype(i))
4374          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4375          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4376          if (itype(i-1).eq.10) then
4377           itype1=isign(10,itype(i-2))
4378           ichir11=isign(1,itype(i-2))
4379           ichir12=isign(1,itype(i-2))
4380           itype2=isign(10,itype(i))
4381           ichir21=isign(1,itype(i))
4382           ichir22=isign(1,itype(i))
4383          endif
4384
4385         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4386 #ifdef OSF
4387           phii=phi(i)
4388           if (phii.ne.phii) phii=150.0
4389 #else
4390           phii=phi(i)
4391 #endif
4392           y(1)=dcos(phii)
4393           y(2)=dsin(phii)
4394         else
4395           y(1)=0.0D0
4396           y(2)=0.0D0
4397         endif
4398         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4399 #ifdef OSF
4400           phii1=phi(i+1)
4401           if (phii1.ne.phii1) phii1=150.0
4402           phii1=pinorm(phii1)
4403           z(1)=cos(phii1)
4404 #else
4405           phii1=phi(i+1)
4406           z(1)=dcos(phii1)
4407 #endif
4408           z(2)=dsin(phii1)
4409         else
4410           z(1)=0.0D0
4411           z(2)=0.0D0
4412         endif
4413 C Calculate the "mean" value of theta from the part of the distribution
4414 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4415 C In following comments this theta will be referred to as t_c.
4416         thet_pred_mean=0.0d0
4417         do k=1,2
4418             athetk=athet(k,it,ichir1,ichir2)
4419             bthetk=bthet(k,it,ichir1,ichir2)
4420           if (it.eq.10) then
4421              athetk=athet(k,itype1,ichir11,ichir12)
4422              bthetk=bthet(k,itype2,ichir21,ichir22)
4423           endif
4424          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4425         enddo
4426         dthett=thet_pred_mean*ssd
4427         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4428 C Derivatives of the "mean" values in gamma1 and gamma2.
4429         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4430      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4431          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4432      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4433          if (it.eq.10) then
4434       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4435      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4436         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4437      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4438          endif
4439         if (theta(i).gt.pi-delta) then
4440           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4441      &         E_tc0)
4442           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4443           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4444           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4445      &        E_theta)
4446           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4447      &        E_tc)
4448         else if (theta(i).lt.delta) then
4449           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4450           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4451           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4452      &        E_theta)
4453           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4454           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4455      &        E_tc)
4456         else
4457           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4458      &        E_theta,E_tc)
4459         endif
4460         etheta=etheta+ethetai
4461         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4462      &      'ebend',i,ethetai
4463         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4464         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4465         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4466       enddo
4467 C Ufff.... We've done all this!!!
4468       return
4469       end
4470 C---------------------------------------------------------------------------
4471       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4472      &     E_tc)
4473       implicit real*8 (a-h,o-z)
4474       include 'DIMENSIONS'
4475       include 'COMMON.LOCAL'
4476       include 'COMMON.IOUNITS'
4477       common /calcthet/ term1,term2,termm,diffak,ratak,
4478      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4479      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4480 C Calculate the contributions to both Gaussian lobes.
4481 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4482 C The "polynomial part" of the "standard deviation" of this part of
4483 C the distribution.
4484         sig=polthet(3,it)
4485         do j=2,0,-1
4486           sig=sig*thet_pred_mean+polthet(j,it)
4487         enddo
4488 C Derivative of the "interior part" of the "standard deviation of the"
4489 C gamma-dependent Gaussian lobe in t_c.
4490         sigtc=3*polthet(3,it)
4491         do j=2,1,-1
4492           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4493         enddo
4494         sigtc=sig*sigtc
4495 C Set the parameters of both Gaussian lobes of the distribution.
4496 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4497         fac=sig*sig+sigc0(it)
4498         sigcsq=fac+fac
4499         sigc=1.0D0/sigcsq
4500 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4501         sigsqtc=-4.0D0*sigcsq*sigtc
4502 c       print *,i,sig,sigtc,sigsqtc
4503 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4504         sigtc=-sigtc/(fac*fac)
4505 C Following variable is sigma(t_c)**(-2)
4506         sigcsq=sigcsq*sigcsq
4507         sig0i=sig0(it)
4508         sig0inv=1.0D0/sig0i**2
4509         delthec=thetai-thet_pred_mean
4510         delthe0=thetai-theta0i
4511         term1=-0.5D0*sigcsq*delthec*delthec
4512         term2=-0.5D0*sig0inv*delthe0*delthe0
4513 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4514 C NaNs in taking the logarithm. We extract the largest exponent which is added
4515 C to the energy (this being the log of the distribution) at the end of energy
4516 C term evaluation for this virtual-bond angle.
4517         if (term1.gt.term2) then
4518           termm=term1
4519           term2=dexp(term2-termm)
4520           term1=1.0d0
4521         else
4522           termm=term2
4523           term1=dexp(term1-termm)
4524           term2=1.0d0
4525         endif
4526 C The ratio between the gamma-independent and gamma-dependent lobes of
4527 C the distribution is a Gaussian function of thet_pred_mean too.
4528         diffak=gthet(2,it)-thet_pred_mean
4529         ratak=diffak/gthet(3,it)**2
4530         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4531 C Let's differentiate it in thet_pred_mean NOW.
4532         aktc=ak*ratak
4533 C Now put together the distribution terms to make complete distribution.
4534         termexp=term1+ak*term2
4535         termpre=sigc+ak*sig0i
4536 C Contribution of the bending energy from this theta is just the -log of
4537 C the sum of the contributions from the two lobes and the pre-exponential
4538 C factor. Simple enough, isn't it?
4539         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4540 C NOW the derivatives!!!
4541 C 6/6/97 Take into account the deformation.
4542         E_theta=(delthec*sigcsq*term1
4543      &       +ak*delthe0*sig0inv*term2)/termexp
4544         E_tc=((sigtc+aktc*sig0i)/termpre
4545      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4546      &       aktc*term2)/termexp)
4547       return
4548       end
4549 c-----------------------------------------------------------------------------
4550       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4551       implicit real*8 (a-h,o-z)
4552       include 'DIMENSIONS'
4553       include 'COMMON.LOCAL'
4554       include 'COMMON.IOUNITS'
4555       common /calcthet/ term1,term2,termm,diffak,ratak,
4556      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4557      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4558       delthec=thetai-thet_pred_mean
4559       delthe0=thetai-theta0i
4560 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4561       t3 = thetai-thet_pred_mean
4562       t6 = t3**2
4563       t9 = term1
4564       t12 = t3*sigcsq
4565       t14 = t12+t6*sigsqtc
4566       t16 = 1.0d0
4567       t21 = thetai-theta0i
4568       t23 = t21**2
4569       t26 = term2
4570       t27 = t21*t26
4571       t32 = termexp
4572       t40 = t32**2
4573       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4574      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4575      & *(-t12*t9-ak*sig0inv*t27)
4576       return
4577       end
4578 #else
4579 C--------------------------------------------------------------------------
4580       subroutine ebend(etheta)
4581 C
4582 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4583 C angles gamma and its derivatives in consecutive thetas and gammas.
4584 C ab initio-derived potentials from
4585 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4586 C
4587       implicit real*8 (a-h,o-z)
4588       include 'DIMENSIONS'
4589       include 'COMMON.LOCAL'
4590       include 'COMMON.GEO'
4591       include 'COMMON.INTERACT'
4592       include 'COMMON.DERIV'
4593       include 'COMMON.VAR'
4594       include 'COMMON.CHAIN'
4595       include 'COMMON.IOUNITS'
4596       include 'COMMON.NAMES'
4597       include 'COMMON.FFIELD'
4598       include 'COMMON.CONTROL'
4599       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4600      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4601      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4602      & sinph1ph2(maxdouble,maxdouble)
4603       logical lprn /.false./, lprn1 /.false./
4604       etheta=0.0D0
4605       do i=ithet_start,ithet_end
4606         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4607      &(itype(i).eq.ntyp1)) cycle
4608 C        print *,i,theta(i)
4609         if (iabs(itype(i+1)).eq.20) iblock=2
4610         if (iabs(itype(i+1)).ne.20) iblock=1
4611         dethetai=0.0d0
4612         dephii=0.0d0
4613         dephii1=0.0d0
4614         theti2=0.5d0*theta(i)
4615         ityp2=ithetyp((itype(i-1)))
4616         do k=1,nntheterm
4617           coskt(k)=dcos(k*theti2)
4618           sinkt(k)=dsin(k*theti2)
4619         enddo
4620 C        print *,ethetai
4621
4622         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4623 #ifdef OSF
4624           phii=phi(i)
4625           if (phii.ne.phii) phii=150.0
4626 #else
4627           phii=phi(i)
4628 #endif
4629           ityp1=ithetyp((itype(i-2)))
4630 C propagation of chirality for glycine type
4631           do k=1,nsingle
4632             cosph1(k)=dcos(k*phii)
4633             sinph1(k)=dsin(k*phii)
4634           enddo
4635         else
4636           phii=0.0d0
4637           do k=1,nsingle
4638           ityp1=ithetyp((itype(i-2)))
4639             cosph1(k)=0.0d0
4640             sinph1(k)=0.0d0
4641           enddo
4642         endif
4643         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4644 #ifdef OSF
4645           phii1=phi(i+1)
4646           if (phii1.ne.phii1) phii1=150.0
4647           phii1=pinorm(phii1)
4648 #else
4649           phii1=phi(i+1)
4650 #endif
4651           ityp3=ithetyp((itype(i)))
4652           do k=1,nsingle
4653             cosph2(k)=dcos(k*phii1)
4654             sinph2(k)=dsin(k*phii1)
4655           enddo
4656         else
4657           phii1=0.0d0
4658           ityp3=ithetyp((itype(i)))
4659           do k=1,nsingle
4660             cosph2(k)=0.0d0
4661             sinph2(k)=0.0d0
4662           enddo
4663         endif
4664         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4665         do k=1,ndouble
4666           do l=1,k-1
4667             ccl=cosph1(l)*cosph2(k-l)
4668             ssl=sinph1(l)*sinph2(k-l)
4669             scl=sinph1(l)*cosph2(k-l)
4670             csl=cosph1(l)*sinph2(k-l)
4671             cosph1ph2(l,k)=ccl-ssl
4672             cosph1ph2(k,l)=ccl+ssl
4673             sinph1ph2(l,k)=scl+csl
4674             sinph1ph2(k,l)=scl-csl
4675           enddo
4676         enddo
4677         if (lprn) then
4678         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4679      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4680         write (iout,*) "coskt and sinkt"
4681         do k=1,nntheterm
4682           write (iout,*) k,coskt(k),sinkt(k)
4683         enddo
4684         endif
4685         do k=1,ntheterm
4686           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4687           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4688      &      *coskt(k)
4689           if (lprn)
4690      &    write (iout,*) "k",k,"
4691      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4692      &     " ethetai",ethetai
4693         enddo
4694         if (lprn) then
4695         write (iout,*) "cosph and sinph"
4696         do k=1,nsingle
4697           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4698         enddo
4699         write (iout,*) "cosph1ph2 and sinph2ph2"
4700         do k=2,ndouble
4701           do l=1,k-1
4702             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4703      &         sinph1ph2(l,k),sinph1ph2(k,l)
4704           enddo
4705         enddo
4706         write(iout,*) "ethetai",ethetai
4707         endif
4708 C       print *,ethetai
4709         do m=1,ntheterm2
4710           do k=1,nsingle
4711             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4712      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4713      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4714      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4715             ethetai=ethetai+sinkt(m)*aux
4716             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4717             dephii=dephii+k*sinkt(m)*(
4718      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4719      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4720             dephii1=dephii1+k*sinkt(m)*(
4721      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4722      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4723             if (lprn)
4724      &      write (iout,*) "m",m," k",k," bbthet",
4725      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4726      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4727      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4728      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4729 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4730           enddo
4731         enddo
4732 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4733 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4734 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4735 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4736         if (lprn)
4737      &  write(iout,*) "ethetai",ethetai
4738 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4739         do m=1,ntheterm3
4740           do k=2,ndouble
4741             do l=1,k-1
4742               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4743      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4744      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4745      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4746               ethetai=ethetai+sinkt(m)*aux
4747               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4748               dephii=dephii+l*sinkt(m)*(
4749      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4750      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4751      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4752      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4753               dephii1=dephii1+(k-l)*sinkt(m)*(
4754      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4755      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4756      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4757      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4758               if (lprn) then
4759               write (iout,*) "m",m," k",k," l",l," ffthet",
4760      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4761      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4762      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4763      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4764      &            " ethetai",ethetai
4765               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4766      &            cosph1ph2(k,l)*sinkt(m),
4767      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4768               endif
4769             enddo
4770           enddo
4771         enddo
4772 10      continue
4773 c        lprn1=.true.
4774 C        print *,ethetai
4775         if (lprn1)
4776      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4777      &   i,theta(i)*rad2deg,phii*rad2deg,
4778      &   phii1*rad2deg,ethetai
4779 c        lprn1=.false.
4780         etheta=etheta+ethetai
4781         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4782         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4783         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4784       enddo
4785       return
4786       end
4787 #endif
4788 #ifdef CRYST_SC
4789 c-----------------------------------------------------------------------------
4790       subroutine esc(escloc)
4791 C Calculate the local energy of a side chain and its derivatives in the
4792 C corresponding virtual-bond valence angles THETA and the spherical angles
4793 C ALPHA and OMEGA.
4794       implicit real*8 (a-h,o-z)
4795       include 'DIMENSIONS'
4796       include 'COMMON.GEO'
4797       include 'COMMON.LOCAL'
4798       include 'COMMON.VAR'
4799       include 'COMMON.INTERACT'
4800       include 'COMMON.DERIV'
4801       include 'COMMON.CHAIN'
4802       include 'COMMON.IOUNITS'
4803       include 'COMMON.NAMES'
4804       include 'COMMON.FFIELD'
4805       include 'COMMON.CONTROL'
4806       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4807      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4808       common /sccalc/ time11,time12,time112,theti,it,nlobit
4809       delta=0.02d0*pi
4810       escloc=0.0D0
4811 c     write (iout,'(a)') 'ESC'
4812       do i=loc_start,loc_end
4813         it=itype(i)
4814         if (it.eq.ntyp1) cycle
4815         if (it.eq.10) goto 1
4816         nlobit=nlob(iabs(it))
4817 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4818 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4819         theti=theta(i+1)-pipol
4820         x(1)=dtan(theti)
4821         x(2)=alph(i)
4822         x(3)=omeg(i)
4823
4824         if (x(2).gt.pi-delta) then
4825           xtemp(1)=x(1)
4826           xtemp(2)=pi-delta
4827           xtemp(3)=x(3)
4828           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4829           xtemp(2)=pi
4830           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4831           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4832      &        escloci,dersc(2))
4833           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4834      &        ddersc0(1),dersc(1))
4835           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4836      &        ddersc0(3),dersc(3))
4837           xtemp(2)=pi-delta
4838           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4839           xtemp(2)=pi
4840           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4841           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4842      &            dersc0(2),esclocbi,dersc02)
4843           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4844      &            dersc12,dersc01)
4845           call splinthet(x(2),0.5d0*delta,ss,ssd)
4846           dersc0(1)=dersc01
4847           dersc0(2)=dersc02
4848           dersc0(3)=0.0d0
4849           do k=1,3
4850             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4851           enddo
4852           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4853 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4854 c    &             esclocbi,ss,ssd
4855           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4856 c         escloci=esclocbi
4857 c         write (iout,*) escloci
4858         else if (x(2).lt.delta) then
4859           xtemp(1)=x(1)
4860           xtemp(2)=delta
4861           xtemp(3)=x(3)
4862           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4863           xtemp(2)=0.0d0
4864           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4865           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4866      &        escloci,dersc(2))
4867           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4868      &        ddersc0(1),dersc(1))
4869           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4870      &        ddersc0(3),dersc(3))
4871           xtemp(2)=delta
4872           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4873           xtemp(2)=0.0d0
4874           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4875           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4876      &            dersc0(2),esclocbi,dersc02)
4877           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4878      &            dersc12,dersc01)
4879           dersc0(1)=dersc01
4880           dersc0(2)=dersc02
4881           dersc0(3)=0.0d0
4882           call splinthet(x(2),0.5d0*delta,ss,ssd)
4883           do k=1,3
4884             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4885           enddo
4886           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4887 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4888 c    &             esclocbi,ss,ssd
4889           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4890 c         write (iout,*) escloci
4891         else
4892           call enesc(x,escloci,dersc,ddummy,.false.)
4893         endif
4894
4895         escloc=escloc+escloci
4896         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4897      &     'escloc',i,escloci
4898 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4899
4900         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4901      &   wscloc*dersc(1)
4902         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4903         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4904     1   continue
4905       enddo
4906       return
4907       end
4908 C---------------------------------------------------------------------------
4909       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4910       implicit real*8 (a-h,o-z)
4911       include 'DIMENSIONS'
4912       include 'COMMON.GEO'
4913       include 'COMMON.LOCAL'
4914       include 'COMMON.IOUNITS'
4915       common /sccalc/ time11,time12,time112,theti,it,nlobit
4916       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4917       double precision contr(maxlob,-1:1)
4918       logical mixed
4919 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4920         escloc_i=0.0D0
4921         do j=1,3
4922           dersc(j)=0.0D0
4923           if (mixed) ddersc(j)=0.0d0
4924         enddo
4925         x3=x(3)
4926
4927 C Because of periodicity of the dependence of the SC energy in omega we have
4928 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4929 C To avoid underflows, first compute & store the exponents.
4930
4931         do iii=-1,1
4932
4933           x(3)=x3+iii*dwapi
4934
4935           do j=1,nlobit
4936             do k=1,3
4937               z(k)=x(k)-censc(k,j,it)
4938             enddo
4939             do k=1,3
4940               Axk=0.0D0
4941               do l=1,3
4942                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4943               enddo
4944               Ax(k,j,iii)=Axk
4945             enddo
4946             expfac=0.0D0
4947             do k=1,3
4948               expfac=expfac+Ax(k,j,iii)*z(k)
4949             enddo
4950             contr(j,iii)=expfac
4951           enddo ! j
4952
4953         enddo ! iii
4954
4955         x(3)=x3
4956 C As in the case of ebend, we want to avoid underflows in exponentiation and
4957 C subsequent NaNs and INFs in energy calculation.
4958 C Find the largest exponent
4959         emin=contr(1,-1)
4960         do iii=-1,1
4961           do j=1,nlobit
4962             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4963           enddo
4964         enddo
4965         emin=0.5D0*emin
4966 cd      print *,'it=',it,' emin=',emin
4967
4968 C Compute the contribution to SC energy and derivatives
4969         do iii=-1,1
4970
4971           do j=1,nlobit
4972 #ifdef OSF
4973             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4974             if(adexp.ne.adexp) adexp=1.0
4975             expfac=dexp(adexp)
4976 #else
4977             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4978 #endif
4979 cd          print *,'j=',j,' expfac=',expfac
4980             escloc_i=escloc_i+expfac
4981             do k=1,3
4982               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4983             enddo
4984             if (mixed) then
4985               do k=1,3,2
4986                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4987      &            +gaussc(k,2,j,it))*expfac
4988               enddo
4989             endif
4990           enddo
4991
4992         enddo ! iii
4993
4994         dersc(1)=dersc(1)/cos(theti)**2
4995         ddersc(1)=ddersc(1)/cos(theti)**2
4996         ddersc(3)=ddersc(3)
4997
4998         escloci=-(dlog(escloc_i)-emin)
4999         do j=1,3
5000           dersc(j)=dersc(j)/escloc_i
5001         enddo
5002         if (mixed) then
5003           do j=1,3,2
5004             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5005           enddo
5006         endif
5007       return
5008       end
5009 C------------------------------------------------------------------------------
5010       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5011       implicit real*8 (a-h,o-z)
5012       include 'DIMENSIONS'
5013       include 'COMMON.GEO'
5014       include 'COMMON.LOCAL'
5015       include 'COMMON.IOUNITS'
5016       common /sccalc/ time11,time12,time112,theti,it,nlobit
5017       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5018       double precision contr(maxlob)
5019       logical mixed
5020
5021       escloc_i=0.0D0
5022
5023       do j=1,3
5024         dersc(j)=0.0D0
5025       enddo
5026
5027       do j=1,nlobit
5028         do k=1,2
5029           z(k)=x(k)-censc(k,j,it)
5030         enddo
5031         z(3)=dwapi
5032         do k=1,3
5033           Axk=0.0D0
5034           do l=1,3
5035             Axk=Axk+gaussc(l,k,j,it)*z(l)
5036           enddo
5037           Ax(k,j)=Axk
5038         enddo
5039         expfac=0.0D0
5040         do k=1,3
5041           expfac=expfac+Ax(k,j)*z(k)
5042         enddo
5043         contr(j)=expfac
5044       enddo ! j
5045
5046 C As in the case of ebend, we want to avoid underflows in exponentiation and
5047 C subsequent NaNs and INFs in energy calculation.
5048 C Find the largest exponent
5049       emin=contr(1)
5050       do j=1,nlobit
5051         if (emin.gt.contr(j)) emin=contr(j)
5052       enddo
5053       emin=0.5D0*emin
5054
5055 C Compute the contribution to SC energy and derivatives
5056
5057       dersc12=0.0d0
5058       do j=1,nlobit
5059         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5060         escloc_i=escloc_i+expfac
5061         do k=1,2
5062           dersc(k)=dersc(k)+Ax(k,j)*expfac
5063         enddo
5064         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5065      &            +gaussc(1,2,j,it))*expfac
5066         dersc(3)=0.0d0
5067       enddo
5068
5069       dersc(1)=dersc(1)/cos(theti)**2
5070       dersc12=dersc12/cos(theti)**2
5071       escloci=-(dlog(escloc_i)-emin)
5072       do j=1,2
5073         dersc(j)=dersc(j)/escloc_i
5074       enddo
5075       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5076       return
5077       end
5078 #else
5079 c----------------------------------------------------------------------------------
5080       subroutine esc(escloc)
5081 C Calculate the local energy of a side chain and its derivatives in the
5082 C corresponding virtual-bond valence angles THETA and the spherical angles
5083 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5084 C added by Urszula Kozlowska. 07/11/2007
5085 C
5086       implicit real*8 (a-h,o-z)
5087       include 'DIMENSIONS'
5088       include 'COMMON.GEO'
5089       include 'COMMON.LOCAL'
5090       include 'COMMON.VAR'
5091       include 'COMMON.SCROT'
5092       include 'COMMON.INTERACT'
5093       include 'COMMON.DERIV'
5094       include 'COMMON.CHAIN'
5095       include 'COMMON.IOUNITS'
5096       include 'COMMON.NAMES'
5097       include 'COMMON.FFIELD'
5098       include 'COMMON.CONTROL'
5099       include 'COMMON.VECTORS'
5100       double precision x_prime(3),y_prime(3),z_prime(3)
5101      &    , sumene,dsc_i,dp2_i,x(65),
5102      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5103      &    de_dxx,de_dyy,de_dzz,de_dt
5104       double precision s1_t,s1_6_t,s2_t,s2_6_t
5105       double precision
5106      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5107      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5108      & dt_dCi(3),dt_dCi1(3)
5109       common /sccalc/ time11,time12,time112,theti,it,nlobit
5110       delta=0.02d0*pi
5111       escloc=0.0D0
5112       do i=loc_start,loc_end
5113         if (itype(i).eq.ntyp1) cycle
5114         costtab(i+1) =dcos(theta(i+1))
5115         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5116         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5117         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5118         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5119         cosfac=dsqrt(cosfac2)
5120         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5121         sinfac=dsqrt(sinfac2)
5122         it=iabs(itype(i))
5123         if (it.eq.10) goto 1
5124 c
5125 C  Compute the axes of tghe local cartesian coordinates system; store in
5126 c   x_prime, y_prime and z_prime
5127 c
5128         do j=1,3
5129           x_prime(j) = 0.00
5130           y_prime(j) = 0.00
5131           z_prime(j) = 0.00
5132         enddo
5133 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5134 C     &   dc_norm(3,i+nres)
5135         do j = 1,3
5136           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5137           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5138         enddo
5139         do j = 1,3
5140           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5141         enddo
5142 c       write (2,*) "i",i
5143 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5144 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5145 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5146 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5147 c      & " xy",scalar(x_prime(1),y_prime(1)),
5148 c      & " xz",scalar(x_prime(1),z_prime(1)),
5149 c      & " yy",scalar(y_prime(1),y_prime(1)),
5150 c      & " yz",scalar(y_prime(1),z_prime(1)),
5151 c      & " zz",scalar(z_prime(1),z_prime(1))
5152 c
5153 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5154 C to local coordinate system. Store in xx, yy, zz.
5155 c
5156         xx=0.0d0
5157         yy=0.0d0
5158         zz=0.0d0
5159         do j = 1,3
5160           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5161           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5162           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5163         enddo
5164
5165         xxtab(i)=xx
5166         yytab(i)=yy
5167         zztab(i)=zz
5168 C
5169 C Compute the energy of the ith side cbain
5170 C
5171 c        write (2,*) "xx",xx," yy",yy," zz",zz
5172         it=iabs(itype(i))
5173         do j = 1,65
5174           x(j) = sc_parmin(j,it)
5175         enddo
5176 #ifdef CHECK_COORD
5177 Cc diagnostics - remove later
5178         xx1 = dcos(alph(2))
5179         yy1 = dsin(alph(2))*dcos(omeg(2))
5180         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5181         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5182      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5183      &    xx1,yy1,zz1
5184 C,"  --- ", xx_w,yy_w,zz_w
5185 c end diagnostics
5186 #endif
5187         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5188      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5189      &   + x(10)*yy*zz
5190         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5191      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5192      & + x(20)*yy*zz
5193         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5194      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5195      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5196      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5197      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5198      &  +x(40)*xx*yy*zz
5199         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5200      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5201      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5202      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5203      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5204      &  +x(60)*xx*yy*zz
5205         dsc_i   = 0.743d0+x(61)
5206         dp2_i   = 1.9d0+x(62)
5207         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5208      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5209         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5210      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5211         s1=(1+x(63))/(0.1d0 + dscp1)
5212         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5213         s2=(1+x(65))/(0.1d0 + dscp2)
5214         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5215         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5216      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5217 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5218 c     &   sumene4,
5219 c     &   dscp1,dscp2,sumene
5220 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5221         escloc = escloc + sumene
5222 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5223 c     & ,zz,xx,yy
5224 c#define DEBUG
5225 #ifdef DEBUG
5226 C
5227 C This section to check the numerical derivatives of the energy of ith side
5228 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5229 C #define DEBUG in the code to turn it on.
5230 C
5231         write (2,*) "sumene               =",sumene
5232         aincr=1.0d-7
5233         xxsave=xx
5234         xx=xx+aincr
5235         write (2,*) xx,yy,zz
5236         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5237         de_dxx_num=(sumenep-sumene)/aincr
5238         xx=xxsave
5239         write (2,*) "xx+ sumene from enesc=",sumenep
5240         yysave=yy
5241         yy=yy+aincr
5242         write (2,*) xx,yy,zz
5243         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5244         de_dyy_num=(sumenep-sumene)/aincr
5245         yy=yysave
5246         write (2,*) "yy+ sumene from enesc=",sumenep
5247         zzsave=zz
5248         zz=zz+aincr
5249         write (2,*) xx,yy,zz
5250         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5251         de_dzz_num=(sumenep-sumene)/aincr
5252         zz=zzsave
5253         write (2,*) "zz+ sumene from enesc=",sumenep
5254         costsave=cost2tab(i+1)
5255         sintsave=sint2tab(i+1)
5256         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5257         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5258         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5259         de_dt_num=(sumenep-sumene)/aincr
5260         write (2,*) " t+ sumene from enesc=",sumenep
5261         cost2tab(i+1)=costsave
5262         sint2tab(i+1)=sintsave
5263 C End of diagnostics section.
5264 #endif
5265 C
5266 C Compute the gradient of esc
5267 C
5268 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5269         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5270         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5271         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5272         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5273         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5274         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5275         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5276         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5277         pom1=(sumene3*sint2tab(i+1)+sumene1)
5278      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5279         pom2=(sumene4*cost2tab(i+1)+sumene2)
5280      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5281         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5282         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5283      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5284      &  +x(40)*yy*zz
5285         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5286         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5287      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5288      &  +x(60)*yy*zz
5289         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5290      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5291      &        +(pom1+pom2)*pom_dx
5292 #ifdef DEBUG
5293         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5294 #endif
5295 C
5296         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5297         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5298      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5299      &  +x(40)*xx*zz
5300         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5301         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5302      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5303      &  +x(59)*zz**2 +x(60)*xx*zz
5304         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5305      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5306      &        +(pom1-pom2)*pom_dy
5307 #ifdef DEBUG
5308         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5309 #endif
5310 C
5311         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5312      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5313      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5314      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5315      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5316      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5317      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5318      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5319 #ifdef DEBUG
5320         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5321 #endif
5322 C
5323         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5324      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5325      &  +pom1*pom_dt1+pom2*pom_dt2
5326 #ifdef DEBUG
5327         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5328 #endif
5329 c#undef DEBUG
5330 c
5331 C
5332        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5333        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5334        cosfac2xx=cosfac2*xx
5335        sinfac2yy=sinfac2*yy
5336        do k = 1,3
5337          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5338      &      vbld_inv(i+1)
5339          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5340      &      vbld_inv(i)
5341          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5342          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5343 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5344 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5345 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5346 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5347          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5348          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5349          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5350          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5351          dZZ_Ci1(k)=0.0d0
5352          dZZ_Ci(k)=0.0d0
5353          do j=1,3
5354            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5355      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5356            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5357      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5358          enddo
5359
5360          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5361          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5362          dZZ_XYZ(k)=vbld_inv(i+nres)*
5363      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5364 c
5365          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5366          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5367        enddo
5368
5369        do k=1,3
5370          dXX_Ctab(k,i)=dXX_Ci(k)
5371          dXX_C1tab(k,i)=dXX_Ci1(k)
5372          dYY_Ctab(k,i)=dYY_Ci(k)
5373          dYY_C1tab(k,i)=dYY_Ci1(k)
5374          dZZ_Ctab(k,i)=dZZ_Ci(k)
5375          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5376          dXX_XYZtab(k,i)=dXX_XYZ(k)
5377          dYY_XYZtab(k,i)=dYY_XYZ(k)
5378          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5379        enddo
5380
5381        do k = 1,3
5382 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5383 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5384 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5385 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5386 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5387 c     &    dt_dci(k)
5388 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5389 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5390          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5391      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5392          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5393      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5394          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5395      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5396        enddo
5397 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5398 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5399
5400 C to check gradient call subroutine check_grad
5401
5402     1 continue
5403       enddo
5404       return
5405       end
5406 c------------------------------------------------------------------------------
5407       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5408       implicit none
5409       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5410      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5411       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5412      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5413      &   + x(10)*yy*zz
5414       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5415      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5416      & + x(20)*yy*zz
5417       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5418      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5419      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5420      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5421      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5422      &  +x(40)*xx*yy*zz
5423       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5424      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5425      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5426      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5427      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5428      &  +x(60)*xx*yy*zz
5429       dsc_i   = 0.743d0+x(61)
5430       dp2_i   = 1.9d0+x(62)
5431       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5432      &          *(xx*cost2+yy*sint2))
5433       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5434      &          *(xx*cost2-yy*sint2))
5435       s1=(1+x(63))/(0.1d0 + dscp1)
5436       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5437       s2=(1+x(65))/(0.1d0 + dscp2)
5438       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5439       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5440      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5441       enesc=sumene
5442       return
5443       end
5444 #endif
5445 c------------------------------------------------------------------------------
5446       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5447 C
5448 C This procedure calculates two-body contact function g(rij) and its derivative:
5449 C
5450 C           eps0ij                                     !       x < -1
5451 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5452 C            0                                         !       x > 1
5453 C
5454 C where x=(rij-r0ij)/delta
5455 C
5456 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5457 C
5458       implicit none
5459       double precision rij,r0ij,eps0ij,fcont,fprimcont
5460       double precision x,x2,x4,delta
5461 c     delta=0.02D0*r0ij
5462 c      delta=0.2D0*r0ij
5463       x=(rij-r0ij)/delta
5464       if (x.lt.-1.0D0) then
5465         fcont=eps0ij
5466         fprimcont=0.0D0
5467       else if (x.le.1.0D0) then
5468         x2=x*x
5469         x4=x2*x2
5470         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5471         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5472       else
5473         fcont=0.0D0
5474         fprimcont=0.0D0
5475       endif
5476       return
5477       end
5478 c------------------------------------------------------------------------------
5479       subroutine splinthet(theti,delta,ss,ssder)
5480       implicit real*8 (a-h,o-z)
5481       include 'DIMENSIONS'
5482       include 'COMMON.VAR'
5483       include 'COMMON.GEO'
5484       thetup=pi-delta
5485       thetlow=delta
5486       if (theti.gt.pipol) then
5487         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5488       else
5489         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5490         ssder=-ssder
5491       endif
5492       return
5493       end
5494 c------------------------------------------------------------------------------
5495       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5496       implicit none
5497       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5498       double precision ksi,ksi2,ksi3,a1,a2,a3
5499       a1=fprim0*delta/(f1-f0)
5500       a2=3.0d0-2.0d0*a1
5501       a3=a1-2.0d0
5502       ksi=(x-x0)/delta
5503       ksi2=ksi*ksi
5504       ksi3=ksi2*ksi
5505       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5506       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5507       return
5508       end
5509 c------------------------------------------------------------------------------
5510       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5511       implicit none
5512       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5513       double precision ksi,ksi2,ksi3,a1,a2,a3
5514       ksi=(x-x0)/delta
5515       ksi2=ksi*ksi
5516       ksi3=ksi2*ksi
5517       a1=fprim0x*delta
5518       a2=3*(f1x-f0x)-2*fprim0x*delta
5519       a3=fprim0x*delta-2*(f1x-f0x)
5520       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5521       return
5522       end
5523 C-----------------------------------------------------------------------------
5524 #ifdef CRYST_TOR
5525 C-----------------------------------------------------------------------------
5526       subroutine etor(etors,edihcnstr)
5527       implicit real*8 (a-h,o-z)
5528       include 'DIMENSIONS'
5529       include 'COMMON.VAR'
5530       include 'COMMON.GEO'
5531       include 'COMMON.LOCAL'
5532       include 'COMMON.TORSION'
5533       include 'COMMON.INTERACT'
5534       include 'COMMON.DERIV'
5535       include 'COMMON.CHAIN'
5536       include 'COMMON.NAMES'
5537       include 'COMMON.IOUNITS'
5538       include 'COMMON.FFIELD'
5539       include 'COMMON.TORCNSTR'
5540       include 'COMMON.CONTROL'
5541       logical lprn
5542 C Set lprn=.true. for debugging
5543       lprn=.false.
5544 c      lprn=.true.
5545       etors=0.0D0
5546       do i=iphi_start,iphi_end
5547       etors_ii=0.0D0
5548         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5549      &      .or. itype(i).eq.ntyp1) cycle
5550         itori=itortyp(itype(i-2))
5551         itori1=itortyp(itype(i-1))
5552         phii=phi(i)
5553         gloci=0.0D0
5554 C Proline-Proline pair is a special case...
5555         if (itori.eq.3 .and. itori1.eq.3) then
5556           if (phii.gt.-dwapi3) then
5557             cosphi=dcos(3*phii)
5558             fac=1.0D0/(1.0D0-cosphi)
5559             etorsi=v1(1,3,3)*fac
5560             etorsi=etorsi+etorsi
5561             etors=etors+etorsi-v1(1,3,3)
5562             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5563             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5564           endif
5565           do j=1,3
5566             v1ij=v1(j+1,itori,itori1)
5567             v2ij=v2(j+1,itori,itori1)
5568             cosphi=dcos(j*phii)
5569             sinphi=dsin(j*phii)
5570             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5571             if (energy_dec) etors_ii=etors_ii+
5572      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5573             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5574           enddo
5575         else
5576           do j=1,nterm_old
5577             v1ij=v1(j,itori,itori1)
5578             v2ij=v2(j,itori,itori1)
5579             cosphi=dcos(j*phii)
5580             sinphi=dsin(j*phii)
5581             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5582             if (energy_dec) etors_ii=etors_ii+
5583      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5584             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5585           enddo
5586         endif
5587         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5588              'etor',i,etors_ii
5589         if (lprn)
5590      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5591      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5592      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5593         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5594 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5595       enddo
5596 ! 6/20/98 - dihedral angle constraints
5597       edihcnstr=0.0d0
5598       do i=1,ndih_constr
5599         itori=idih_constr(i)
5600         phii=phi(itori)
5601         difi=phii-phi0(i)
5602         if (difi.gt.drange(i)) then
5603           difi=difi-drange(i)
5604           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5605           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5606         else if (difi.lt.-drange(i)) then
5607           difi=difi+drange(i)
5608           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5609           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5610         endif
5611 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5612 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5613       enddo
5614 !      write (iout,*) 'edihcnstr',edihcnstr
5615       return
5616       end
5617 c------------------------------------------------------------------------------
5618       subroutine etor_d(etors_d)
5619       etors_d=0.0d0
5620       return
5621       end
5622 c----------------------------------------------------------------------------
5623 #else
5624       subroutine etor(etors,edihcnstr)
5625       implicit real*8 (a-h,o-z)
5626       include 'DIMENSIONS'
5627       include 'COMMON.VAR'
5628       include 'COMMON.GEO'
5629       include 'COMMON.LOCAL'
5630       include 'COMMON.TORSION'
5631       include 'COMMON.INTERACT'
5632       include 'COMMON.DERIV'
5633       include 'COMMON.CHAIN'
5634       include 'COMMON.NAMES'
5635       include 'COMMON.IOUNITS'
5636       include 'COMMON.FFIELD'
5637       include 'COMMON.TORCNSTR'
5638       include 'COMMON.CONTROL'
5639       logical lprn
5640 C Set lprn=.true. for debugging
5641       lprn=.false.
5642 c     lprn=.true.
5643       etors=0.0D0
5644       do i=iphi_start,iphi_end
5645         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5646      &       .or. itype(i).eq.ntyp1) cycle
5647         etors_ii=0.0D0
5648          if (iabs(itype(i)).eq.20) then
5649          iblock=2
5650          else
5651          iblock=1
5652          endif
5653         itori=itortyp(itype(i-2))
5654         itori1=itortyp(itype(i-1))
5655         phii=phi(i)
5656         gloci=0.0D0
5657 C Regular cosine and sine terms
5658         do j=1,nterm(itori,itori1,iblock)
5659           v1ij=v1(j,itori,itori1,iblock)
5660           v2ij=v2(j,itori,itori1,iblock)
5661           cosphi=dcos(j*phii)
5662           sinphi=dsin(j*phii)
5663           etors=etors+v1ij*cosphi+v2ij*sinphi
5664           if (energy_dec) etors_ii=etors_ii+
5665      &                v1ij*cosphi+v2ij*sinphi
5666           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5667         enddo
5668 C Lorentz terms
5669 C                         v1
5670 C  E = SUM ----------------------------------- - v1
5671 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5672 C
5673         cosphi=dcos(0.5d0*phii)
5674         sinphi=dsin(0.5d0*phii)
5675         do j=1,nlor(itori,itori1,iblock)
5676           vl1ij=vlor1(j,itori,itori1)
5677           vl2ij=vlor2(j,itori,itori1)
5678           vl3ij=vlor3(j,itori,itori1)
5679           pom=vl2ij*cosphi+vl3ij*sinphi
5680           pom1=1.0d0/(pom*pom+1.0d0)
5681           etors=etors+vl1ij*pom1
5682           if (energy_dec) etors_ii=etors_ii+
5683      &                vl1ij*pom1
5684           pom=-pom*pom1*pom1
5685           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5686         enddo
5687 C Subtract the constant term
5688         etors=etors-v0(itori,itori1,iblock)
5689           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5690      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5691         if (lprn)
5692      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5693      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5694      &  (v1(j,itori,itori1,iblock),j=1,6),
5695      &  (v2(j,itori,itori1,iblock),j=1,6)
5696         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5697 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5698       enddo
5699 ! 6/20/98 - dihedral angle constraints
5700       edihcnstr=0.0d0
5701 c      do i=1,ndih_constr
5702       do i=idihconstr_start,idihconstr_end
5703         itori=idih_constr(i)
5704         phii=phi(itori)
5705         difi=pinorm(phii-phi0(i))
5706         if (difi.gt.drange(i)) then
5707           difi=difi-drange(i)
5708           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5709           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5710         else if (difi.lt.-drange(i)) then
5711           difi=difi+drange(i)
5712           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5713           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5714         else
5715           difi=0.0
5716         endif
5717 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5718 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5719 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5720       enddo
5721 cd       write (iout,*) 'edihcnstr',edihcnstr
5722       return
5723       end
5724 c----------------------------------------------------------------------------
5725       subroutine etor_d(etors_d)
5726 C 6/23/01 Compute double torsional energy
5727       implicit real*8 (a-h,o-z)
5728       include 'DIMENSIONS'
5729       include 'COMMON.VAR'
5730       include 'COMMON.GEO'
5731       include 'COMMON.LOCAL'
5732       include 'COMMON.TORSION'
5733       include 'COMMON.INTERACT'
5734       include 'COMMON.DERIV'
5735       include 'COMMON.CHAIN'
5736       include 'COMMON.NAMES'
5737       include 'COMMON.IOUNITS'
5738       include 'COMMON.FFIELD'
5739       include 'COMMON.TORCNSTR'
5740       logical lprn
5741 C Set lprn=.true. for debugging
5742       lprn=.false.
5743 c     lprn=.true.
5744       etors_d=0.0D0
5745 c      write(iout,*) "a tu??"
5746       do i=iphid_start,iphid_end
5747         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5748      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5749         itori=itortyp(itype(i-2))
5750         itori1=itortyp(itype(i-1))
5751         itori2=itortyp(itype(i))
5752         phii=phi(i)
5753         phii1=phi(i+1)
5754         gloci1=0.0D0
5755         gloci2=0.0D0
5756         iblock=1
5757         if (iabs(itype(i+1)).eq.20) iblock=2
5758
5759 C Regular cosine and sine terms
5760         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5761           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5762           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5763           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5764           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5765           cosphi1=dcos(j*phii)
5766           sinphi1=dsin(j*phii)
5767           cosphi2=dcos(j*phii1)
5768           sinphi2=dsin(j*phii1)
5769           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5770      &     v2cij*cosphi2+v2sij*sinphi2
5771           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5772           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5773         enddo
5774         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5775           do l=1,k-1
5776             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5777             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5778             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5779             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5780             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5781             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5782             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5783             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5784             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5785      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5786             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5787      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5788             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5789      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5790           enddo
5791         enddo
5792         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5793         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5794       enddo
5795       return
5796       end
5797 #endif
5798 c------------------------------------------------------------------------------
5799       subroutine eback_sc_corr(esccor)
5800 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5801 c        conformational states; temporarily implemented as differences
5802 c        between UNRES torsional potentials (dependent on three types of
5803 c        residues) and the torsional potentials dependent on all 20 types
5804 c        of residues computed from AM1  energy surfaces of terminally-blocked
5805 c        amino-acid residues.
5806       implicit real*8 (a-h,o-z)
5807       include 'DIMENSIONS'
5808       include 'COMMON.VAR'
5809       include 'COMMON.GEO'
5810       include 'COMMON.LOCAL'
5811       include 'COMMON.TORSION'
5812       include 'COMMON.SCCOR'
5813       include 'COMMON.INTERACT'
5814       include 'COMMON.DERIV'
5815       include 'COMMON.CHAIN'
5816       include 'COMMON.NAMES'
5817       include 'COMMON.IOUNITS'
5818       include 'COMMON.FFIELD'
5819       include 'COMMON.CONTROL'
5820       logical lprn
5821 C Set lprn=.true. for debugging
5822       lprn=.false.
5823 c      lprn=.true.
5824 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5825       esccor=0.0D0
5826       do i=itau_start,itau_end
5827         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5828         esccor_ii=0.0D0
5829         isccori=isccortyp(itype(i-2))
5830         isccori1=isccortyp(itype(i-1))
5831 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5832         phii=phi(i)
5833         do intertyp=1,3 !intertyp
5834 cc Added 09 May 2012 (Adasko)
5835 cc  Intertyp means interaction type of backbone mainchain correlation:
5836 c   1 = SC...Ca...Ca...Ca
5837 c   2 = Ca...Ca...Ca...SC
5838 c   3 = SC...Ca...Ca...SCi
5839         gloci=0.0D0
5840         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5841      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5842      &      (itype(i-1).eq.ntyp1)))
5843      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5844      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5845      &     .or.(itype(i).eq.ntyp1)))
5846      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5847      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5848      &      (itype(i-3).eq.ntyp1)))) cycle
5849         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5850         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5851      & cycle
5852        do j=1,nterm_sccor(isccori,isccori1)
5853           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5854           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5855           cosphi=dcos(j*tauangle(intertyp,i))
5856           sinphi=dsin(j*tauangle(intertyp,i))
5857           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5858           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5859         enddo
5860 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5861         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5862         if (lprn)
5863      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5864      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5865      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5866      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5867         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5868        enddo !intertyp
5869       enddo
5870
5871       return
5872       end
5873 c----------------------------------------------------------------------------
5874       subroutine multibody(ecorr)
5875 C This subroutine calculates multi-body contributions to energy following
5876 C the idea of Skolnick et al. If side chains I and J make a contact and
5877 C at the same time side chains I+1 and J+1 make a contact, an extra
5878 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5879       implicit real*8 (a-h,o-z)
5880       include 'DIMENSIONS'
5881       include 'COMMON.IOUNITS'
5882       include 'COMMON.DERIV'
5883       include 'COMMON.INTERACT'
5884       include 'COMMON.CONTACTS'
5885       double precision gx(3),gx1(3)
5886       logical lprn
5887
5888 C Set lprn=.true. for debugging
5889       lprn=.false.
5890
5891       if (lprn) then
5892         write (iout,'(a)') 'Contact function values:'
5893         do i=nnt,nct-2
5894           write (iout,'(i2,20(1x,i2,f10.5))')
5895      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5896         enddo
5897       endif
5898       ecorr=0.0D0
5899       do i=nnt,nct
5900         do j=1,3
5901           gradcorr(j,i)=0.0D0
5902           gradxorr(j,i)=0.0D0
5903         enddo
5904       enddo
5905       do i=nnt,nct-2
5906
5907         DO ISHIFT = 3,4
5908
5909         i1=i+ishift
5910         num_conti=num_cont(i)
5911         num_conti1=num_cont(i1)
5912         do jj=1,num_conti
5913           j=jcont(jj,i)
5914           do kk=1,num_conti1
5915             j1=jcont(kk,i1)
5916             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5917 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5918 cd   &                   ' ishift=',ishift
5919 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5920 C The system gains extra energy.
5921               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5922             endif   ! j1==j+-ishift
5923           enddo     ! kk
5924         enddo       ! jj
5925
5926         ENDDO ! ISHIFT
5927
5928       enddo         ! i
5929       return
5930       end
5931 c------------------------------------------------------------------------------
5932       double precision function esccorr(i,j,k,l,jj,kk)
5933       implicit real*8 (a-h,o-z)
5934       include 'DIMENSIONS'
5935       include 'COMMON.IOUNITS'
5936       include 'COMMON.DERIV'
5937       include 'COMMON.INTERACT'
5938       include 'COMMON.CONTACTS'
5939       double precision gx(3),gx1(3)
5940       logical lprn
5941       lprn=.false.
5942       eij=facont(jj,i)
5943       ekl=facont(kk,k)
5944 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5945 C Calculate the multi-body contribution to energy.
5946 C Calculate multi-body contributions to the gradient.
5947 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5948 cd   & k,l,(gacont(m,kk,k),m=1,3)
5949       do m=1,3
5950         gx(m) =ekl*gacont(m,jj,i)
5951         gx1(m)=eij*gacont(m,kk,k)
5952         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5953         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5954         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5955         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5956       enddo
5957       do m=i,j-1
5958         do ll=1,3
5959           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5960         enddo
5961       enddo
5962       do m=k,l-1
5963         do ll=1,3
5964           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5965         enddo
5966       enddo
5967       esccorr=-eij*ekl
5968       return
5969       end
5970 c------------------------------------------------------------------------------
5971       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5972 C This subroutine calculates multi-body contributions to hydrogen-bonding
5973       implicit real*8 (a-h,o-z)
5974       include 'DIMENSIONS'
5975       include 'COMMON.IOUNITS'
5976 #ifdef MPI
5977       include "mpif.h"
5978       parameter (max_cont=maxconts)
5979       parameter (max_dim=26)
5980       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5981       double precision zapas(max_dim,maxconts,max_fg_procs),
5982      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5983       common /przechowalnia/ zapas
5984       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5985      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5986 #endif
5987       include 'COMMON.SETUP'
5988       include 'COMMON.FFIELD'
5989       include 'COMMON.DERIV'
5990       include 'COMMON.INTERACT'
5991       include 'COMMON.CONTACTS'
5992       include 'COMMON.CONTROL'
5993       include 'COMMON.LOCAL'
5994       double precision gx(3),gx1(3),time00
5995       logical lprn,ldone
5996
5997 C Set lprn=.true. for debugging
5998       lprn=.false.
5999 #ifdef MPI
6000       n_corr=0
6001       n_corr1=0
6002       if (nfgtasks.le.1) goto 30
6003       if (lprn) then
6004         write (iout,'(a)') 'Contact function values before RECEIVE:'
6005         do i=nnt,nct-2
6006           write (iout,'(2i3,50(1x,i2,f5.2))')
6007      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6008      &    j=1,num_cont_hb(i))
6009         enddo
6010       endif
6011       call flush(iout)
6012       do i=1,ntask_cont_from
6013         ncont_recv(i)=0
6014       enddo
6015       do i=1,ntask_cont_to
6016         ncont_sent(i)=0
6017       enddo
6018 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6019 c     & ntask_cont_to
6020 C Make the list of contacts to send to send to other procesors
6021 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6022 c      call flush(iout)
6023       do i=iturn3_start,iturn3_end
6024 c        write (iout,*) "make contact list turn3",i," num_cont",
6025 c     &    num_cont_hb(i)
6026         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6027       enddo
6028       do i=iturn4_start,iturn4_end
6029 c        write (iout,*) "make contact list turn4",i," num_cont",
6030 c     &   num_cont_hb(i)
6031         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6032       enddo
6033       do ii=1,nat_sent
6034         i=iat_sent(ii)
6035 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6036 c     &    num_cont_hb(i)
6037         do j=1,num_cont_hb(i)
6038         do k=1,4
6039           jjc=jcont_hb(j,i)
6040           iproc=iint_sent_local(k,jjc,ii)
6041 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6042           if (iproc.gt.0) then
6043             ncont_sent(iproc)=ncont_sent(iproc)+1
6044             nn=ncont_sent(iproc)
6045             zapas(1,nn,iproc)=i
6046             zapas(2,nn,iproc)=jjc
6047             zapas(3,nn,iproc)=facont_hb(j,i)
6048             zapas(4,nn,iproc)=ees0p(j,i)
6049             zapas(5,nn,iproc)=ees0m(j,i)
6050             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6051             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6052             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6053             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6054             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6055             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6056             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6057             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6058             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6059             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6060             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6061             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6062             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6063             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6064             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6065             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6066             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6067             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6068             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6069             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6070             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6071           endif
6072         enddo
6073         enddo
6074       enddo
6075       if (lprn) then
6076       write (iout,*)
6077      &  "Numbers of contacts to be sent to other processors",
6078      &  (ncont_sent(i),i=1,ntask_cont_to)
6079       write (iout,*) "Contacts sent"
6080       do ii=1,ntask_cont_to
6081         nn=ncont_sent(ii)
6082         iproc=itask_cont_to(ii)
6083         write (iout,*) nn," contacts to processor",iproc,
6084      &   " of CONT_TO_COMM group"
6085         do i=1,nn
6086           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6087         enddo
6088       enddo
6089       call flush(iout)
6090       endif
6091       CorrelType=477
6092       CorrelID=fg_rank+1
6093       CorrelType1=478
6094       CorrelID1=nfgtasks+fg_rank+1
6095       ireq=0
6096 C Receive the numbers of needed contacts from other processors
6097       do ii=1,ntask_cont_from
6098         iproc=itask_cont_from(ii)
6099         ireq=ireq+1
6100         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6101      &    FG_COMM,req(ireq),IERR)
6102       enddo
6103 c      write (iout,*) "IRECV ended"
6104 c      call flush(iout)
6105 C Send the number of contacts needed by other processors
6106       do ii=1,ntask_cont_to
6107         iproc=itask_cont_to(ii)
6108         ireq=ireq+1
6109         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6110      &    FG_COMM,req(ireq),IERR)
6111       enddo
6112 c      write (iout,*) "ISEND ended"
6113 c      write (iout,*) "number of requests (nn)",ireq
6114       call flush(iout)
6115       if (ireq.gt.0)
6116      &  call MPI_Waitall(ireq,req,status_array,ierr)
6117 c      write (iout,*)
6118 c     &  "Numbers of contacts to be received from other processors",
6119 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6120 c      call flush(iout)
6121 C Receive contacts
6122       ireq=0
6123       do ii=1,ntask_cont_from
6124         iproc=itask_cont_from(ii)
6125         nn=ncont_recv(ii)
6126 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6127 c     &   " of CONT_TO_COMM group"
6128         call flush(iout)
6129         if (nn.gt.0) then
6130           ireq=ireq+1
6131           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6132      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6133 c          write (iout,*) "ireq,req",ireq,req(ireq)
6134         endif
6135       enddo
6136 C Send the contacts to processors that need them
6137       do ii=1,ntask_cont_to
6138         iproc=itask_cont_to(ii)
6139         nn=ncont_sent(ii)
6140 c        write (iout,*) nn," contacts to processor",iproc,
6141 c     &   " of CONT_TO_COMM group"
6142         if (nn.gt.0) then
6143           ireq=ireq+1
6144           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6145      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6146 c          write (iout,*) "ireq,req",ireq,req(ireq)
6147 c          do i=1,nn
6148 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6149 c          enddo
6150         endif
6151       enddo
6152 c      write (iout,*) "number of requests (contacts)",ireq
6153 c      write (iout,*) "req",(req(i),i=1,4)
6154 c      call flush(iout)
6155       if (ireq.gt.0)
6156      & call MPI_Waitall(ireq,req,status_array,ierr)
6157       do iii=1,ntask_cont_from
6158         iproc=itask_cont_from(iii)
6159         nn=ncont_recv(iii)
6160         if (lprn) then
6161         write (iout,*) "Received",nn," contacts from processor",iproc,
6162      &   " of CONT_FROM_COMM group"
6163         call flush(iout)
6164         do i=1,nn
6165           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6166         enddo
6167         call flush(iout)
6168         endif
6169         do i=1,nn
6170           ii=zapas_recv(1,i,iii)
6171 c Flag the received contacts to prevent double-counting
6172           jj=-zapas_recv(2,i,iii)
6173 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6174 c          call flush(iout)
6175           nnn=num_cont_hb(ii)+1
6176           num_cont_hb(ii)=nnn
6177           jcont_hb(nnn,ii)=jj
6178           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6179           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6180           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6181           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6182           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6183           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6184           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6185           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6186           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6187           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6188           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6189           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6190           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6191           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6192           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6193           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6194           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6195           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6196           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6197           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6198           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6199           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6200           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6201           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6202         enddo
6203       enddo
6204       call flush(iout)
6205       if (lprn) then
6206         write (iout,'(a)') 'Contact function values after receive:'
6207         do i=nnt,nct-2
6208           write (iout,'(2i3,50(1x,i3,f5.2))')
6209      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6210      &    j=1,num_cont_hb(i))
6211         enddo
6212         call flush(iout)
6213       endif
6214    30 continue
6215 #endif
6216       if (lprn) then
6217         write (iout,'(a)') 'Contact function values:'
6218         do i=nnt,nct-2
6219           write (iout,'(2i3,50(1x,i3,f5.2))')
6220      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6221      &    j=1,num_cont_hb(i))
6222         enddo
6223       endif
6224       ecorr=0.0D0
6225 C Remove the loop below after debugging !!!
6226       do i=nnt,nct
6227         do j=1,3
6228           gradcorr(j,i)=0.0D0
6229           gradxorr(j,i)=0.0D0
6230         enddo
6231       enddo
6232 C Calculate the local-electrostatic correlation terms
6233       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6234         i1=i+1
6235         num_conti=num_cont_hb(i)
6236         num_conti1=num_cont_hb(i+1)
6237         do jj=1,num_conti
6238           j=jcont_hb(jj,i)
6239           jp=iabs(j)
6240           do kk=1,num_conti1
6241             j1=jcont_hb(kk,i1)
6242             jp1=iabs(j1)
6243 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6244 c     &         ' jj=',jj,' kk=',kk
6245             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6246      &          .or. j.lt.0 .and. j1.gt.0) .and.
6247      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6248 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6249 C The system gains extra energy.
6250               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6251               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6252      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6253               n_corr=n_corr+1
6254             else if (j1.eq.j) then
6255 C Contacts I-J and I-(J+1) occur simultaneously.
6256 C The system loses extra energy.
6257 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6258             endif
6259           enddo ! kk
6260           do kk=1,num_conti
6261             j1=jcont_hb(kk,i)
6262 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6263 c    &         ' jj=',jj,' kk=',kk
6264             if (j1.eq.j+1) then
6265 C Contacts I-J and (I+1)-J occur simultaneously.
6266 C The system loses extra energy.
6267 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6268             endif ! j1==j+1
6269           enddo ! kk
6270         enddo ! jj
6271       enddo ! i
6272       return
6273       end
6274 c------------------------------------------------------------------------------
6275       subroutine add_hb_contact(ii,jj,itask)
6276       implicit real*8 (a-h,o-z)
6277       include "DIMENSIONS"
6278       include "COMMON.IOUNITS"
6279       integer max_cont
6280       integer max_dim
6281       parameter (max_cont=maxconts)
6282       parameter (max_dim=26)
6283       include "COMMON.CONTACTS"
6284       double precision zapas(max_dim,maxconts,max_fg_procs),
6285      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6286       common /przechowalnia/ zapas
6287       integer i,j,ii,jj,iproc,itask(4),nn
6288 c      write (iout,*) "itask",itask
6289       do i=1,2
6290         iproc=itask(i)
6291         if (iproc.gt.0) then
6292           do j=1,num_cont_hb(ii)
6293             jjc=jcont_hb(j,ii)
6294 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6295             if (jjc.eq.jj) then
6296               ncont_sent(iproc)=ncont_sent(iproc)+1
6297               nn=ncont_sent(iproc)
6298               zapas(1,nn,iproc)=ii
6299               zapas(2,nn,iproc)=jjc
6300               zapas(3,nn,iproc)=facont_hb(j,ii)
6301               zapas(4,nn,iproc)=ees0p(j,ii)
6302               zapas(5,nn,iproc)=ees0m(j,ii)
6303               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6304               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6305               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6306               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6307               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6308               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6309               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6310               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6311               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6312               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6313               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6314               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6315               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6316               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6317               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6318               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6319               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6320               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6321               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6322               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6323               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6324               exit
6325             endif
6326           enddo
6327         endif
6328       enddo
6329       return
6330       end
6331 c------------------------------------------------------------------------------
6332       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6333      &  n_corr1)
6334 C This subroutine calculates multi-body contributions to hydrogen-bonding
6335       implicit real*8 (a-h,o-z)
6336       include 'DIMENSIONS'
6337       include 'COMMON.IOUNITS'
6338 #ifdef MPI
6339       include "mpif.h"
6340       parameter (max_cont=maxconts)
6341       parameter (max_dim=70)
6342       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6343       double precision zapas(max_dim,maxconts,max_fg_procs),
6344      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6345       common /przechowalnia/ zapas
6346       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6347      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6348 #endif
6349       include 'COMMON.SETUP'
6350       include 'COMMON.FFIELD'
6351       include 'COMMON.DERIV'
6352       include 'COMMON.LOCAL'
6353       include 'COMMON.INTERACT'
6354       include 'COMMON.CONTACTS'
6355       include 'COMMON.CHAIN'
6356       include 'COMMON.CONTROL'
6357       double precision gx(3),gx1(3)
6358       integer num_cont_hb_old(maxres)
6359       logical lprn,ldone
6360       double precision eello4,eello5,eelo6,eello_turn6
6361       external eello4,eello5,eello6,eello_turn6
6362 C Set lprn=.true. for debugging
6363       lprn=.false.
6364       eturn6=0.0d0
6365 #ifdef MPI
6366       do i=1,nres
6367         num_cont_hb_old(i)=num_cont_hb(i)
6368       enddo
6369       n_corr=0
6370       n_corr1=0
6371       if (nfgtasks.le.1) goto 30
6372       if (lprn) then
6373         write (iout,'(a)') 'Contact function values before RECEIVE:'
6374         do i=nnt,nct-2
6375           write (iout,'(2i3,50(1x,i2,f5.2))')
6376      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6377      &    j=1,num_cont_hb(i))
6378         enddo
6379       endif
6380       call flush(iout)
6381       do i=1,ntask_cont_from
6382         ncont_recv(i)=0
6383       enddo
6384       do i=1,ntask_cont_to
6385         ncont_sent(i)=0
6386       enddo
6387 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6388 c     & ntask_cont_to
6389 C Make the list of contacts to send to send to other procesors
6390       do i=iturn3_start,iturn3_end
6391 c        write (iout,*) "make contact list turn3",i," num_cont",
6392 c     &    num_cont_hb(i)
6393         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6394       enddo
6395       do i=iturn4_start,iturn4_end
6396 c        write (iout,*) "make contact list turn4",i," num_cont",
6397 c     &   num_cont_hb(i)
6398         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6399       enddo
6400       do ii=1,nat_sent
6401         i=iat_sent(ii)
6402 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6403 c     &    num_cont_hb(i)
6404         do j=1,num_cont_hb(i)
6405         do k=1,4
6406           jjc=jcont_hb(j,i)
6407           iproc=iint_sent_local(k,jjc,ii)
6408 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6409           if (iproc.ne.0) then
6410             ncont_sent(iproc)=ncont_sent(iproc)+1
6411             nn=ncont_sent(iproc)
6412             zapas(1,nn,iproc)=i
6413             zapas(2,nn,iproc)=jjc
6414             zapas(3,nn,iproc)=d_cont(j,i)
6415             ind=3
6416             do kk=1,3
6417               ind=ind+1
6418               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6419             enddo
6420             do kk=1,2
6421               do ll=1,2
6422                 ind=ind+1
6423                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6424               enddo
6425             enddo
6426             do jj=1,5
6427               do kk=1,3
6428                 do ll=1,2
6429                   do mm=1,2
6430                     ind=ind+1
6431                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6432                   enddo
6433                 enddo
6434               enddo
6435             enddo
6436           endif
6437         enddo
6438         enddo
6439       enddo
6440       if (lprn) then
6441       write (iout,*)
6442      &  "Numbers of contacts to be sent to other processors",
6443      &  (ncont_sent(i),i=1,ntask_cont_to)
6444       write (iout,*) "Contacts sent"
6445       do ii=1,ntask_cont_to
6446         nn=ncont_sent(ii)
6447         iproc=itask_cont_to(ii)
6448         write (iout,*) nn," contacts to processor",iproc,
6449      &   " of CONT_TO_COMM group"
6450         do i=1,nn
6451           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6452         enddo
6453       enddo
6454       call flush(iout)
6455       endif
6456       CorrelType=477
6457       CorrelID=fg_rank+1
6458       CorrelType1=478
6459       CorrelID1=nfgtasks+fg_rank+1
6460       ireq=0
6461 C Receive the numbers of needed contacts from other processors
6462       do ii=1,ntask_cont_from
6463         iproc=itask_cont_from(ii)
6464         ireq=ireq+1
6465         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6466      &    FG_COMM,req(ireq),IERR)
6467       enddo
6468 c      write (iout,*) "IRECV ended"
6469 c      call flush(iout)
6470 C Send the number of contacts needed by other processors
6471       do ii=1,ntask_cont_to
6472         iproc=itask_cont_to(ii)
6473         ireq=ireq+1
6474         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6475      &    FG_COMM,req(ireq),IERR)
6476       enddo
6477 c      write (iout,*) "ISEND ended"
6478 c      write (iout,*) "number of requests (nn)",ireq
6479       call flush(iout)
6480       if (ireq.gt.0)
6481      &  call MPI_Waitall(ireq,req,status_array,ierr)
6482 c      write (iout,*)
6483 c     &  "Numbers of contacts to be received from other processors",
6484 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6485 c      call flush(iout)
6486 C Receive contacts
6487       ireq=0
6488       do ii=1,ntask_cont_from
6489         iproc=itask_cont_from(ii)
6490         nn=ncont_recv(ii)
6491 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6492 c     &   " of CONT_TO_COMM group"
6493         call flush(iout)
6494         if (nn.gt.0) then
6495           ireq=ireq+1
6496           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6497      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6498 c          write (iout,*) "ireq,req",ireq,req(ireq)
6499         endif
6500       enddo
6501 C Send the contacts to processors that need them
6502       do ii=1,ntask_cont_to
6503         iproc=itask_cont_to(ii)
6504         nn=ncont_sent(ii)
6505 c        write (iout,*) nn," contacts to processor",iproc,
6506 c     &   " of CONT_TO_COMM group"
6507         if (nn.gt.0) then
6508           ireq=ireq+1
6509           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6510      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6511 c          write (iout,*) "ireq,req",ireq,req(ireq)
6512 c          do i=1,nn
6513 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6514 c          enddo
6515         endif
6516       enddo
6517 c      write (iout,*) "number of requests (contacts)",ireq
6518 c      write (iout,*) "req",(req(i),i=1,4)
6519 c      call flush(iout)
6520       if (ireq.gt.0)
6521      & call MPI_Waitall(ireq,req,status_array,ierr)
6522       do iii=1,ntask_cont_from
6523         iproc=itask_cont_from(iii)
6524         nn=ncont_recv(iii)
6525         if (lprn) then
6526         write (iout,*) "Received",nn," contacts from processor",iproc,
6527      &   " of CONT_FROM_COMM group"
6528         call flush(iout)
6529         do i=1,nn
6530           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6531         enddo
6532         call flush(iout)
6533         endif
6534         do i=1,nn
6535           ii=zapas_recv(1,i,iii)
6536 c Flag the received contacts to prevent double-counting
6537           jj=-zapas_recv(2,i,iii)
6538 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6539 c          call flush(iout)
6540           nnn=num_cont_hb(ii)+1
6541           num_cont_hb(ii)=nnn
6542           jcont_hb(nnn,ii)=jj
6543           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6544           ind=3
6545           do kk=1,3
6546             ind=ind+1
6547             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6548           enddo
6549           do kk=1,2
6550             do ll=1,2
6551               ind=ind+1
6552               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6553             enddo
6554           enddo
6555           do jj=1,5
6556             do kk=1,3
6557               do ll=1,2
6558                 do mm=1,2
6559                   ind=ind+1
6560                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6561                 enddo
6562               enddo
6563             enddo
6564           enddo
6565         enddo
6566       enddo
6567       call flush(iout)
6568       if (lprn) then
6569         write (iout,'(a)') 'Contact function values after receive:'
6570         do i=nnt,nct-2
6571           write (iout,'(2i3,50(1x,i3,5f6.3))')
6572      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6573      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6574         enddo
6575         call flush(iout)
6576       endif
6577    30 continue
6578 #endif
6579       if (lprn) then
6580         write (iout,'(a)') 'Contact function values:'
6581         do i=nnt,nct-2
6582           write (iout,'(2i3,50(1x,i2,5f6.3))')
6583      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6584      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6585         enddo
6586       endif
6587       ecorr=0.0D0
6588       ecorr5=0.0d0
6589       ecorr6=0.0d0
6590 C Remove the loop below after debugging !!!
6591       do i=nnt,nct
6592         do j=1,3
6593           gradcorr(j,i)=0.0D0
6594           gradxorr(j,i)=0.0D0
6595         enddo
6596       enddo
6597 C Calculate the dipole-dipole interaction energies
6598       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6599       do i=iatel_s,iatel_e+1
6600         num_conti=num_cont_hb(i)
6601         do jj=1,num_conti
6602           j=jcont_hb(jj,i)
6603 #ifdef MOMENT
6604           call dipole(i,j,jj)
6605 #endif
6606         enddo
6607       enddo
6608       endif
6609 C Calculate the local-electrostatic correlation terms
6610 c                write (iout,*) "gradcorr5 in eello5 before loop"
6611 c                do iii=1,nres
6612 c                  write (iout,'(i5,3f10.5)')
6613 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6614 c                enddo
6615       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6616 c        write (iout,*) "corr loop i",i
6617         i1=i+1
6618         num_conti=num_cont_hb(i)
6619         num_conti1=num_cont_hb(i+1)
6620         do jj=1,num_conti
6621           j=jcont_hb(jj,i)
6622           jp=iabs(j)
6623           do kk=1,num_conti1
6624             j1=jcont_hb(kk,i1)
6625             jp1=iabs(j1)
6626 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6627 c     &         ' jj=',jj,' kk=',kk
6628 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6629             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6630      &          .or. j.lt.0 .and. j1.gt.0) .and.
6631      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6632 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6633 C The system gains extra energy.
6634               n_corr=n_corr+1
6635               sqd1=dsqrt(d_cont(jj,i))
6636               sqd2=dsqrt(d_cont(kk,i1))
6637               sred_geom = sqd1*sqd2
6638               IF (sred_geom.lt.cutoff_corr) THEN
6639                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6640      &            ekont,fprimcont)
6641 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6642 cd     &         ' jj=',jj,' kk=',kk
6643                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6644                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6645                 do l=1,3
6646                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6647                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6648                 enddo
6649                 n_corr1=n_corr1+1
6650 cd               write (iout,*) 'sred_geom=',sred_geom,
6651 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6652 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6653 cd               write (iout,*) "g_contij",g_contij
6654 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6655 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6656                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6657                 if (wcorr4.gt.0.0d0)
6658      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6659                   if (energy_dec.and.wcorr4.gt.0.0d0)
6660      1                 write (iout,'(a6,4i5,0pf7.3)')
6661      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6662 c                write (iout,*) "gradcorr5 before eello5"
6663 c                do iii=1,nres
6664 c                  write (iout,'(i5,3f10.5)')
6665 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6666 c                enddo
6667                 if (wcorr5.gt.0.0d0)
6668      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6669 c                write (iout,*) "gradcorr5 after eello5"
6670 c                do iii=1,nres
6671 c                  write (iout,'(i5,3f10.5)')
6672 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6673 c                enddo
6674                   if (energy_dec.and.wcorr5.gt.0.0d0)
6675      1                 write (iout,'(a6,4i5,0pf7.3)')
6676      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6677 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6678 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6679                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6680      &               .or. wturn6.eq.0.0d0))then
6681 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6682                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6683                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6684      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6685 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6686 cd     &            'ecorr6=',ecorr6
6687 cd                write (iout,'(4e15.5)') sred_geom,
6688 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6689 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6690 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6691                 else if (wturn6.gt.0.0d0
6692      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6693 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6694                   eturn6=eturn6+eello_turn6(i,jj,kk)
6695                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6696      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6697 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6698                 endif
6699               ENDIF
6700 1111          continue
6701             endif
6702           enddo ! kk
6703         enddo ! jj
6704       enddo ! i
6705       do i=1,nres
6706         num_cont_hb(i)=num_cont_hb_old(i)
6707       enddo
6708 c                write (iout,*) "gradcorr5 in eello5"
6709 c                do iii=1,nres
6710 c                  write (iout,'(i5,3f10.5)')
6711 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6712 c                enddo
6713       return
6714       end
6715 c------------------------------------------------------------------------------
6716       subroutine add_hb_contact_eello(ii,jj,itask)
6717       implicit real*8 (a-h,o-z)
6718       include "DIMENSIONS"
6719       include "COMMON.IOUNITS"
6720       integer max_cont
6721       integer max_dim
6722       parameter (max_cont=maxconts)
6723       parameter (max_dim=70)
6724       include "COMMON.CONTACTS"
6725       double precision zapas(max_dim,maxconts,max_fg_procs),
6726      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6727       common /przechowalnia/ zapas
6728       integer i,j,ii,jj,iproc,itask(4),nn
6729 c      write (iout,*) "itask",itask
6730       do i=1,2
6731         iproc=itask(i)
6732         if (iproc.gt.0) then
6733           do j=1,num_cont_hb(ii)
6734             jjc=jcont_hb(j,ii)
6735 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6736             if (jjc.eq.jj) then
6737               ncont_sent(iproc)=ncont_sent(iproc)+1
6738               nn=ncont_sent(iproc)
6739               zapas(1,nn,iproc)=ii
6740               zapas(2,nn,iproc)=jjc
6741               zapas(3,nn,iproc)=d_cont(j,ii)
6742               ind=3
6743               do kk=1,3
6744                 ind=ind+1
6745                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6746               enddo
6747               do kk=1,2
6748                 do ll=1,2
6749                   ind=ind+1
6750                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6751                 enddo
6752               enddo
6753               do jj=1,5
6754                 do kk=1,3
6755                   do ll=1,2
6756                     do mm=1,2
6757                       ind=ind+1
6758                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6759                     enddo
6760                   enddo
6761                 enddo
6762               enddo
6763               exit
6764             endif
6765           enddo
6766         endif
6767       enddo
6768       return
6769       end
6770 c------------------------------------------------------------------------------
6771       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6772       implicit real*8 (a-h,o-z)
6773       include 'DIMENSIONS'
6774       include 'COMMON.IOUNITS'
6775       include 'COMMON.DERIV'
6776       include 'COMMON.INTERACT'
6777       include 'COMMON.CONTACTS'
6778       double precision gx(3),gx1(3)
6779       logical lprn
6780       lprn=.false.
6781       eij=facont_hb(jj,i)
6782       ekl=facont_hb(kk,k)
6783       ees0pij=ees0p(jj,i)
6784       ees0pkl=ees0p(kk,k)
6785       ees0mij=ees0m(jj,i)
6786       ees0mkl=ees0m(kk,k)
6787       ekont=eij*ekl
6788       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6789 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6790 C Following 4 lines for diagnostics.
6791 cd    ees0pkl=0.0D0
6792 cd    ees0pij=1.0D0
6793 cd    ees0mkl=0.0D0
6794 cd    ees0mij=1.0D0
6795 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6796 c     & 'Contacts ',i,j,
6797 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6798 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6799 c     & 'gradcorr_long'
6800 C Calculate the multi-body contribution to energy.
6801 c      ecorr=ecorr+ekont*ees
6802 C Calculate multi-body contributions to the gradient.
6803       coeffpees0pij=coeffp*ees0pij
6804       coeffmees0mij=coeffm*ees0mij
6805       coeffpees0pkl=coeffp*ees0pkl
6806       coeffmees0mkl=coeffm*ees0mkl
6807       do ll=1,3
6808 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6809         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6810      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6811      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6812         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6813      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6814      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6815 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6816         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6817      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6818      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6819         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6820      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6821      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6822         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6823      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6824      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6825         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6826         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6827         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6828      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6829      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6830         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6831         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6832 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6833       enddo
6834 c      write (iout,*)
6835 cgrad      do m=i+1,j-1
6836 cgrad        do ll=1,3
6837 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6838 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6839 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6840 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6841 cgrad        enddo
6842 cgrad      enddo
6843 cgrad      do m=k+1,l-1
6844 cgrad        do ll=1,3
6845 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6846 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6847 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6848 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6849 cgrad        enddo
6850 cgrad      enddo
6851 c      write (iout,*) "ehbcorr",ekont*ees
6852       ehbcorr=ekont*ees
6853       return
6854       end
6855 #ifdef MOMENT
6856 C---------------------------------------------------------------------------
6857       subroutine dipole(i,j,jj)
6858       implicit real*8 (a-h,o-z)
6859       include 'DIMENSIONS'
6860       include 'COMMON.IOUNITS'
6861       include 'COMMON.CHAIN'
6862       include 'COMMON.FFIELD'
6863       include 'COMMON.DERIV'
6864       include 'COMMON.INTERACT'
6865       include 'COMMON.CONTACTS'
6866       include 'COMMON.TORSION'
6867       include 'COMMON.VAR'
6868       include 'COMMON.GEO'
6869       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6870      &  auxmat(2,2)
6871       iti1 = itortyp(itype(i+1))
6872       if (j.lt.nres-1) then
6873         itj1 = itortyp(itype(j+1))
6874       else
6875         itj1=ntortyp+1
6876       endif
6877       do iii=1,2
6878         dipi(iii,1)=Ub2(iii,i)
6879         dipderi(iii)=Ub2der(iii,i)
6880         dipi(iii,2)=b1(iii,iti1)
6881         dipj(iii,1)=Ub2(iii,j)
6882         dipderj(iii)=Ub2der(iii,j)
6883         dipj(iii,2)=b1(iii,itj1)
6884       enddo
6885       kkk=0
6886       do iii=1,2
6887         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6888         do jjj=1,2
6889           kkk=kkk+1
6890           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6891         enddo
6892       enddo
6893       do kkk=1,5
6894         do lll=1,3
6895           mmm=0
6896           do iii=1,2
6897             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6898      &        auxvec(1))
6899             do jjj=1,2
6900               mmm=mmm+1
6901               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6902             enddo
6903           enddo
6904         enddo
6905       enddo
6906       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6907       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6908       do iii=1,2
6909         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6910       enddo
6911       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6912       do iii=1,2
6913         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6914       enddo
6915       return
6916       end
6917 #endif
6918 C---------------------------------------------------------------------------
6919       subroutine calc_eello(i,j,k,l,jj,kk)
6920 C
6921 C This subroutine computes matrices and vectors needed to calculate
6922 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6923 C
6924       implicit real*8 (a-h,o-z)
6925       include 'DIMENSIONS'
6926       include 'COMMON.IOUNITS'
6927       include 'COMMON.CHAIN'
6928       include 'COMMON.DERIV'
6929       include 'COMMON.INTERACT'
6930       include 'COMMON.CONTACTS'
6931       include 'COMMON.TORSION'
6932       include 'COMMON.VAR'
6933       include 'COMMON.GEO'
6934       include 'COMMON.FFIELD'
6935       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6936      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6937       logical lprn
6938       common /kutas/ lprn
6939 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6940 cd     & ' jj=',jj,' kk=',kk
6941 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6942 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6943 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6944       do iii=1,2
6945         do jjj=1,2
6946           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6947           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6948         enddo
6949       enddo
6950       call transpose2(aa1(1,1),aa1t(1,1))
6951       call transpose2(aa2(1,1),aa2t(1,1))
6952       do kkk=1,5
6953         do lll=1,3
6954           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6955      &      aa1tder(1,1,lll,kkk))
6956           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6957      &      aa2tder(1,1,lll,kkk))
6958         enddo
6959       enddo
6960       if (l.eq.j+1) then
6961 C parallel orientation of the two CA-CA-CA frames.
6962         if (i.gt.1) then
6963           iti=itortyp(itype(i))
6964         else
6965           iti=ntortyp+1
6966         endif
6967         itk1=itortyp(itype(k+1))
6968         itj=itortyp(itype(j))
6969         if (l.lt.nres-1) then
6970           itl1=itortyp(itype(l+1))
6971         else
6972           itl1=ntortyp+1
6973         endif
6974 C A1 kernel(j+1) A2T
6975 cd        do iii=1,2
6976 cd          write (iout,'(3f10.5,5x,3f10.5)')
6977 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6978 cd        enddo
6979         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6980      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6981      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6982 C Following matrices are needed only for 6-th order cumulants
6983         IF (wcorr6.gt.0.0d0) THEN
6984         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6985      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6986      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6987         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6988      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6989      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6990      &   ADtEAderx(1,1,1,1,1,1))
6991         lprn=.false.
6992         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6993      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6994      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6995      &   ADtEA1derx(1,1,1,1,1,1))
6996         ENDIF
6997 C End 6-th order cumulants
6998 cd        lprn=.false.
6999 cd        if (lprn) then
7000 cd        write (2,*) 'In calc_eello6'
7001 cd        do iii=1,2
7002 cd          write (2,*) 'iii=',iii
7003 cd          do kkk=1,5
7004 cd            write (2,*) 'kkk=',kkk
7005 cd            do jjj=1,2
7006 cd              write (2,'(3(2f10.5),5x)')
7007 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7008 cd            enddo
7009 cd          enddo
7010 cd        enddo
7011 cd        endif
7012         call transpose2(EUgder(1,1,k),auxmat(1,1))
7013         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7014         call transpose2(EUg(1,1,k),auxmat(1,1))
7015         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7016         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7017         do iii=1,2
7018           do kkk=1,5
7019             do lll=1,3
7020               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7021      &          EAEAderx(1,1,lll,kkk,iii,1))
7022             enddo
7023           enddo
7024         enddo
7025 C A1T kernel(i+1) A2
7026         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7027      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7028      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7029 C Following matrices are needed only for 6-th order cumulants
7030         IF (wcorr6.gt.0.0d0) THEN
7031         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7032      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7033      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7034         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7035      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7036      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7037      &   ADtEAderx(1,1,1,1,1,2))
7038         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7039      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7040      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7041      &   ADtEA1derx(1,1,1,1,1,2))
7042         ENDIF
7043 C End 6-th order cumulants
7044         call transpose2(EUgder(1,1,l),auxmat(1,1))
7045         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7046         call transpose2(EUg(1,1,l),auxmat(1,1))
7047         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7048         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7049         do iii=1,2
7050           do kkk=1,5
7051             do lll=1,3
7052               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7053      &          EAEAderx(1,1,lll,kkk,iii,2))
7054             enddo
7055           enddo
7056         enddo
7057 C AEAb1 and AEAb2
7058 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7059 C They are needed only when the fifth- or the sixth-order cumulants are
7060 C indluded.
7061         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7062         call transpose2(AEA(1,1,1),auxmat(1,1))
7063         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7064         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7065         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7066         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7067         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7068         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7069         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7070         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7071         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7072         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7073         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7074         call transpose2(AEA(1,1,2),auxmat(1,1))
7075         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7076         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7077         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7078         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7079         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7080         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7081         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7082         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7083         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7084         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7085         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7086 C Calculate the Cartesian derivatives of the vectors.
7087         do iii=1,2
7088           do kkk=1,5
7089             do lll=1,3
7090               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7091               call matvec2(auxmat(1,1),b1(1,iti),
7092      &          AEAb1derx(1,lll,kkk,iii,1,1))
7093               call matvec2(auxmat(1,1),Ub2(1,i),
7094      &          AEAb2derx(1,lll,kkk,iii,1,1))
7095               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7096      &          AEAb1derx(1,lll,kkk,iii,2,1))
7097               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7098      &          AEAb2derx(1,lll,kkk,iii,2,1))
7099               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7100               call matvec2(auxmat(1,1),b1(1,itj),
7101      &          AEAb1derx(1,lll,kkk,iii,1,2))
7102               call matvec2(auxmat(1,1),Ub2(1,j),
7103      &          AEAb2derx(1,lll,kkk,iii,1,2))
7104               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7105      &          AEAb1derx(1,lll,kkk,iii,2,2))
7106               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7107      &          AEAb2derx(1,lll,kkk,iii,2,2))
7108             enddo
7109           enddo
7110         enddo
7111         ENDIF
7112 C End vectors
7113       else
7114 C Antiparallel orientation of the two CA-CA-CA frames.
7115         if (i.gt.1) then
7116           iti=itortyp(itype(i))
7117         else
7118           iti=ntortyp+1
7119         endif
7120         itk1=itortyp(itype(k+1))
7121         itl=itortyp(itype(l))
7122         itj=itortyp(itype(j))
7123         if (j.lt.nres-1) then
7124           itj1=itortyp(itype(j+1))
7125         else
7126           itj1=ntortyp+1
7127         endif
7128 C A2 kernel(j-1)T A1T
7129         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7130      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7131      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7132 C Following matrices are needed only for 6-th order cumulants
7133         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7134      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7135         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7136      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7137      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7138         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7139      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7140      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7141      &   ADtEAderx(1,1,1,1,1,1))
7142         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7143      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7144      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7145      &   ADtEA1derx(1,1,1,1,1,1))
7146         ENDIF
7147 C End 6-th order cumulants
7148         call transpose2(EUgder(1,1,k),auxmat(1,1))
7149         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7150         call transpose2(EUg(1,1,k),auxmat(1,1))
7151         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7152         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7153         do iii=1,2
7154           do kkk=1,5
7155             do lll=1,3
7156               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7157      &          EAEAderx(1,1,lll,kkk,iii,1))
7158             enddo
7159           enddo
7160         enddo
7161 C A2T kernel(i+1)T A1
7162         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7163      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7164      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7165 C Following matrices are needed only for 6-th order cumulants
7166         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7167      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7168         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7169      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7170      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7171         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7172      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7173      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7174      &   ADtEAderx(1,1,1,1,1,2))
7175         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7176      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7177      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7178      &   ADtEA1derx(1,1,1,1,1,2))
7179         ENDIF
7180 C End 6-th order cumulants
7181         call transpose2(EUgder(1,1,j),auxmat(1,1))
7182         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7183         call transpose2(EUg(1,1,j),auxmat(1,1))
7184         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7185         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7186         do iii=1,2
7187           do kkk=1,5
7188             do lll=1,3
7189               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7190      &          EAEAderx(1,1,lll,kkk,iii,2))
7191             enddo
7192           enddo
7193         enddo
7194 C AEAb1 and AEAb2
7195 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7196 C They are needed only when the fifth- or the sixth-order cumulants are
7197 C indluded.
7198         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7199      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7200         call transpose2(AEA(1,1,1),auxmat(1,1))
7201         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7202         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7203         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7204         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7205         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7206         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7207         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7208         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7209         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7210         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7211         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7212         call transpose2(AEA(1,1,2),auxmat(1,1))
7213         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7214         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7215         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7216         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7217         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7218         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7219         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7220         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7221         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7222         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7223         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7224 C Calculate the Cartesian derivatives of the vectors.
7225         do iii=1,2
7226           do kkk=1,5
7227             do lll=1,3
7228               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7229               call matvec2(auxmat(1,1),b1(1,iti),
7230      &          AEAb1derx(1,lll,kkk,iii,1,1))
7231               call matvec2(auxmat(1,1),Ub2(1,i),
7232      &          AEAb2derx(1,lll,kkk,iii,1,1))
7233               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7234      &          AEAb1derx(1,lll,kkk,iii,2,1))
7235               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7236      &          AEAb2derx(1,lll,kkk,iii,2,1))
7237               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7238               call matvec2(auxmat(1,1),b1(1,itl),
7239      &          AEAb1derx(1,lll,kkk,iii,1,2))
7240               call matvec2(auxmat(1,1),Ub2(1,l),
7241      &          AEAb2derx(1,lll,kkk,iii,1,2))
7242               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7243      &          AEAb1derx(1,lll,kkk,iii,2,2))
7244               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7245      &          AEAb2derx(1,lll,kkk,iii,2,2))
7246             enddo
7247           enddo
7248         enddo
7249         ENDIF
7250 C End vectors
7251       endif
7252       return
7253       end
7254 C---------------------------------------------------------------------------
7255       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7256      &  KK,KKderg,AKA,AKAderg,AKAderx)
7257       implicit none
7258       integer nderg
7259       logical transp
7260       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7261      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7262      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7263       integer iii,kkk,lll
7264       integer jjj,mmm
7265       logical lprn
7266       common /kutas/ lprn
7267       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7268       do iii=1,nderg
7269         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7270      &    AKAderg(1,1,iii))
7271       enddo
7272 cd      if (lprn) write (2,*) 'In kernel'
7273       do kkk=1,5
7274 cd        if (lprn) write (2,*) 'kkk=',kkk
7275         do lll=1,3
7276           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7277      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7278 cd          if (lprn) then
7279 cd            write (2,*) 'lll=',lll
7280 cd            write (2,*) 'iii=1'
7281 cd            do jjj=1,2
7282 cd              write (2,'(3(2f10.5),5x)')
7283 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7284 cd            enddo
7285 cd          endif
7286           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7287      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7288 cd          if (lprn) then
7289 cd            write (2,*) 'lll=',lll
7290 cd            write (2,*) 'iii=2'
7291 cd            do jjj=1,2
7292 cd              write (2,'(3(2f10.5),5x)')
7293 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7294 cd            enddo
7295 cd          endif
7296         enddo
7297       enddo
7298       return
7299       end
7300 C---------------------------------------------------------------------------
7301       double precision function eello4(i,j,k,l,jj,kk)
7302       implicit real*8 (a-h,o-z)
7303       include 'DIMENSIONS'
7304       include 'COMMON.IOUNITS'
7305       include 'COMMON.CHAIN'
7306       include 'COMMON.DERIV'
7307       include 'COMMON.INTERACT'
7308       include 'COMMON.CONTACTS'
7309       include 'COMMON.TORSION'
7310       include 'COMMON.VAR'
7311       include 'COMMON.GEO'
7312       double precision pizda(2,2),ggg1(3),ggg2(3)
7313 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7314 cd        eello4=0.0d0
7315 cd        return
7316 cd      endif
7317 cd      print *,'eello4:',i,j,k,l,jj,kk
7318 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7319 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7320 cold      eij=facont_hb(jj,i)
7321 cold      ekl=facont_hb(kk,k)
7322 cold      ekont=eij*ekl
7323       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7324 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7325       gcorr_loc(k-1)=gcorr_loc(k-1)
7326      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7327       if (l.eq.j+1) then
7328         gcorr_loc(l-1)=gcorr_loc(l-1)
7329      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7330       else
7331         gcorr_loc(j-1)=gcorr_loc(j-1)
7332      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7333       endif
7334       do iii=1,2
7335         do kkk=1,5
7336           do lll=1,3
7337             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7338      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7339 cd            derx(lll,kkk,iii)=0.0d0
7340           enddo
7341         enddo
7342       enddo
7343 cd      gcorr_loc(l-1)=0.0d0
7344 cd      gcorr_loc(j-1)=0.0d0
7345 cd      gcorr_loc(k-1)=0.0d0
7346 cd      eel4=1.0d0
7347 cd      write (iout,*)'Contacts have occurred for peptide groups',
7348 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7349 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7350       if (j.lt.nres-1) then
7351         j1=j+1
7352         j2=j-1
7353       else
7354         j1=j-1
7355         j2=j-2
7356       endif
7357       if (l.lt.nres-1) then
7358         l1=l+1
7359         l2=l-1
7360       else
7361         l1=l-1
7362         l2=l-2
7363       endif
7364       do ll=1,3
7365 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7366 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7367         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7368         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7369 cgrad        ghalf=0.5d0*ggg1(ll)
7370         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7371         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7372         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7373         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7374         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7375         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7376 cgrad        ghalf=0.5d0*ggg2(ll)
7377         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7378         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7379         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7380         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7381         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7382         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7383       enddo
7384 cgrad      do m=i+1,j-1
7385 cgrad        do ll=1,3
7386 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7387 cgrad        enddo
7388 cgrad      enddo
7389 cgrad      do m=k+1,l-1
7390 cgrad        do ll=1,3
7391 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7392 cgrad        enddo
7393 cgrad      enddo
7394 cgrad      do m=i+2,j2
7395 cgrad        do ll=1,3
7396 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7397 cgrad        enddo
7398 cgrad      enddo
7399 cgrad      do m=k+2,l2
7400 cgrad        do ll=1,3
7401 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7402 cgrad        enddo
7403 cgrad      enddo
7404 cd      do iii=1,nres-3
7405 cd        write (2,*) iii,gcorr_loc(iii)
7406 cd      enddo
7407       eello4=ekont*eel4
7408 cd      write (2,*) 'ekont',ekont
7409 cd      write (iout,*) 'eello4',ekont*eel4
7410       return
7411       end
7412 C---------------------------------------------------------------------------
7413       double precision function eello5(i,j,k,l,jj,kk)
7414       implicit real*8 (a-h,o-z)
7415       include 'DIMENSIONS'
7416       include 'COMMON.IOUNITS'
7417       include 'COMMON.CHAIN'
7418       include 'COMMON.DERIV'
7419       include 'COMMON.INTERACT'
7420       include 'COMMON.CONTACTS'
7421       include 'COMMON.TORSION'
7422       include 'COMMON.VAR'
7423       include 'COMMON.GEO'
7424       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7425       double precision ggg1(3),ggg2(3)
7426 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7427 C                                                                              C
7428 C                            Parallel chains                                   C
7429 C                                                                              C
7430 C          o             o                   o             o                   C
7431 C         /l\           / \             \   / \           / \   /              C
7432 C        /   \         /   \             \ /   \         /   \ /               C
7433 C       j| o |l1       | o |              o| o |         | o |o                C
7434 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7435 C      \i/   \         /   \ /             /   \         /   \                 C
7436 C       o    k1             o                                                  C
7437 C         (I)          (II)                (III)          (IV)                 C
7438 C                                                                              C
7439 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7440 C                                                                              C
7441 C                            Antiparallel chains                               C
7442 C                                                                              C
7443 C          o             o                   o             o                   C
7444 C         /j\           / \             \   / \           / \   /              C
7445 C        /   \         /   \             \ /   \         /   \ /               C
7446 C      j1| o |l        | o |              o| o |         | o |o                C
7447 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7448 C      \i/   \         /   \ /             /   \         /   \                 C
7449 C       o     k1            o                                                  C
7450 C         (I)          (II)                (III)          (IV)                 C
7451 C                                                                              C
7452 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7453 C                                                                              C
7454 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7455 C                                                                              C
7456 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7457 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7458 cd        eello5=0.0d0
7459 cd        return
7460 cd      endif
7461 cd      write (iout,*)
7462 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7463 cd     &   ' and',k,l
7464       itk=itortyp(itype(k))
7465       itl=itortyp(itype(l))
7466       itj=itortyp(itype(j))
7467       eello5_1=0.0d0
7468       eello5_2=0.0d0
7469       eello5_3=0.0d0
7470       eello5_4=0.0d0
7471 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7472 cd     &   eel5_3_num,eel5_4_num)
7473       do iii=1,2
7474         do kkk=1,5
7475           do lll=1,3
7476             derx(lll,kkk,iii)=0.0d0
7477           enddo
7478         enddo
7479       enddo
7480 cd      eij=facont_hb(jj,i)
7481 cd      ekl=facont_hb(kk,k)
7482 cd      ekont=eij*ekl
7483 cd      write (iout,*)'Contacts have occurred for peptide groups',
7484 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7485 cd      goto 1111
7486 C Contribution from the graph I.
7487 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7488 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7489       call transpose2(EUg(1,1,k),auxmat(1,1))
7490       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7491       vv(1)=pizda(1,1)-pizda(2,2)
7492       vv(2)=pizda(1,2)+pizda(2,1)
7493       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7494      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7495 C Explicit gradient in virtual-dihedral angles.
7496       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7497      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7498      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7499       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7500       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7501       vv(1)=pizda(1,1)-pizda(2,2)
7502       vv(2)=pizda(1,2)+pizda(2,1)
7503       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7504      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7505      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7506       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7507       vv(1)=pizda(1,1)-pizda(2,2)
7508       vv(2)=pizda(1,2)+pizda(2,1)
7509       if (l.eq.j+1) then
7510         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7511      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7512      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7513       else
7514         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7515      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7516      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7517       endif
7518 C Cartesian gradient
7519       do iii=1,2
7520         do kkk=1,5
7521           do lll=1,3
7522             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7523      &        pizda(1,1))
7524             vv(1)=pizda(1,1)-pizda(2,2)
7525             vv(2)=pizda(1,2)+pizda(2,1)
7526             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7527      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7528      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7529           enddo
7530         enddo
7531       enddo
7532 c      goto 1112
7533 c1111  continue
7534 C Contribution from graph II
7535       call transpose2(EE(1,1,itk),auxmat(1,1))
7536       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7537       vv(1)=pizda(1,1)+pizda(2,2)
7538       vv(2)=pizda(2,1)-pizda(1,2)
7539       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7540      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7541 C Explicit gradient in virtual-dihedral angles.
7542       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7543      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7544       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7545       vv(1)=pizda(1,1)+pizda(2,2)
7546       vv(2)=pizda(2,1)-pizda(1,2)
7547       if (l.eq.j+1) then
7548         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7549      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7550      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7551       else
7552         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7553      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7554      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7555       endif
7556 C Cartesian gradient
7557       do iii=1,2
7558         do kkk=1,5
7559           do lll=1,3
7560             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7561      &        pizda(1,1))
7562             vv(1)=pizda(1,1)+pizda(2,2)
7563             vv(2)=pizda(2,1)-pizda(1,2)
7564             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7565      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7566      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7567           enddo
7568         enddo
7569       enddo
7570 cd      goto 1112
7571 cd1111  continue
7572       if (l.eq.j+1) then
7573 cd        goto 1110
7574 C Parallel orientation
7575 C Contribution from graph III
7576         call transpose2(EUg(1,1,l),auxmat(1,1))
7577         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7578         vv(1)=pizda(1,1)-pizda(2,2)
7579         vv(2)=pizda(1,2)+pizda(2,1)
7580         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7581      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7582 C Explicit gradient in virtual-dihedral angles.
7583         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7584      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7585      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7586         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7587         vv(1)=pizda(1,1)-pizda(2,2)
7588         vv(2)=pizda(1,2)+pizda(2,1)
7589         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7590      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7591      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7592         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7593         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7594         vv(1)=pizda(1,1)-pizda(2,2)
7595         vv(2)=pizda(1,2)+pizda(2,1)
7596         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7597      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7598      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7599 C Cartesian gradient
7600         do iii=1,2
7601           do kkk=1,5
7602             do lll=1,3
7603               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7604      &          pizda(1,1))
7605               vv(1)=pizda(1,1)-pizda(2,2)
7606               vv(2)=pizda(1,2)+pizda(2,1)
7607               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7608      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7609      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7610             enddo
7611           enddo
7612         enddo
7613 cd        goto 1112
7614 C Contribution from graph IV
7615 cd1110    continue
7616         call transpose2(EE(1,1,itl),auxmat(1,1))
7617         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7618         vv(1)=pizda(1,1)+pizda(2,2)
7619         vv(2)=pizda(2,1)-pizda(1,2)
7620         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7621      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7622 C Explicit gradient in virtual-dihedral angles.
7623         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7624      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7625         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7626         vv(1)=pizda(1,1)+pizda(2,2)
7627         vv(2)=pizda(2,1)-pizda(1,2)
7628         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7629      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7630      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7631 C Cartesian gradient
7632         do iii=1,2
7633           do kkk=1,5
7634             do lll=1,3
7635               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7636      &          pizda(1,1))
7637               vv(1)=pizda(1,1)+pizda(2,2)
7638               vv(2)=pizda(2,1)-pizda(1,2)
7639               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7640      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7641      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7642             enddo
7643           enddo
7644         enddo
7645       else
7646 C Antiparallel orientation
7647 C Contribution from graph III
7648 c        goto 1110
7649         call transpose2(EUg(1,1,j),auxmat(1,1))
7650         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7651         vv(1)=pizda(1,1)-pizda(2,2)
7652         vv(2)=pizda(1,2)+pizda(2,1)
7653         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7654      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7655 C Explicit gradient in virtual-dihedral angles.
7656         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7657      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7658      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7659         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7660         vv(1)=pizda(1,1)-pizda(2,2)
7661         vv(2)=pizda(1,2)+pizda(2,1)
7662         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7663      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7664      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7665         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7666         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7667         vv(1)=pizda(1,1)-pizda(2,2)
7668         vv(2)=pizda(1,2)+pizda(2,1)
7669         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7670      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7671      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7672 C Cartesian gradient
7673         do iii=1,2
7674           do kkk=1,5
7675             do lll=1,3
7676               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7677      &          pizda(1,1))
7678               vv(1)=pizda(1,1)-pizda(2,2)
7679               vv(2)=pizda(1,2)+pizda(2,1)
7680               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7681      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7682      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7683             enddo
7684           enddo
7685         enddo
7686 cd        goto 1112
7687 C Contribution from graph IV
7688 1110    continue
7689         call transpose2(EE(1,1,itj),auxmat(1,1))
7690         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7691         vv(1)=pizda(1,1)+pizda(2,2)
7692         vv(2)=pizda(2,1)-pizda(1,2)
7693         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7694      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7695 C Explicit gradient in virtual-dihedral angles.
7696         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7697      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7698         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7699         vv(1)=pizda(1,1)+pizda(2,2)
7700         vv(2)=pizda(2,1)-pizda(1,2)
7701         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7702      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7703      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7704 C Cartesian gradient
7705         do iii=1,2
7706           do kkk=1,5
7707             do lll=1,3
7708               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7709      &          pizda(1,1))
7710               vv(1)=pizda(1,1)+pizda(2,2)
7711               vv(2)=pizda(2,1)-pizda(1,2)
7712               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7713      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7714      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7715             enddo
7716           enddo
7717         enddo
7718       endif
7719 1112  continue
7720       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7721 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7722 cd        write (2,*) 'ijkl',i,j,k,l
7723 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7724 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7725 cd      endif
7726 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7727 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7728 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7729 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7730       if (j.lt.nres-1) then
7731         j1=j+1
7732         j2=j-1
7733       else
7734         j1=j-1
7735         j2=j-2
7736       endif
7737       if (l.lt.nres-1) then
7738         l1=l+1
7739         l2=l-1
7740       else
7741         l1=l-1
7742         l2=l-2
7743       endif
7744 cd      eij=1.0d0
7745 cd      ekl=1.0d0
7746 cd      ekont=1.0d0
7747 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7748 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7749 C        summed up outside the subrouine as for the other subroutines
7750 C        handling long-range interactions. The old code is commented out
7751 C        with "cgrad" to keep track of changes.
7752       do ll=1,3
7753 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7754 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7755         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7756         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7757 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7758 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7759 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7760 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7761 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7762 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7763 c     &   gradcorr5ij,
7764 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7765 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7766 cgrad        ghalf=0.5d0*ggg1(ll)
7767 cd        ghalf=0.0d0
7768         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7769         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7770         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7771         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7772         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7773         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7774 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7775 cgrad        ghalf=0.5d0*ggg2(ll)
7776 cd        ghalf=0.0d0
7777         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7778         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7779         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7780         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7781         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7782         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7783       enddo
7784 cd      goto 1112
7785 cgrad      do m=i+1,j-1
7786 cgrad        do ll=1,3
7787 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7788 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7789 cgrad        enddo
7790 cgrad      enddo
7791 cgrad      do m=k+1,l-1
7792 cgrad        do ll=1,3
7793 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7794 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7795 cgrad        enddo
7796 cgrad      enddo
7797 c1112  continue
7798 cgrad      do m=i+2,j2
7799 cgrad        do ll=1,3
7800 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7801 cgrad        enddo
7802 cgrad      enddo
7803 cgrad      do m=k+2,l2
7804 cgrad        do ll=1,3
7805 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7806 cgrad        enddo
7807 cgrad      enddo
7808 cd      do iii=1,nres-3
7809 cd        write (2,*) iii,g_corr5_loc(iii)
7810 cd      enddo
7811       eello5=ekont*eel5
7812 cd      write (2,*) 'ekont',ekont
7813 cd      write (iout,*) 'eello5',ekont*eel5
7814       return
7815       end
7816 c--------------------------------------------------------------------------
7817       double precision function eello6(i,j,k,l,jj,kk)
7818       implicit real*8 (a-h,o-z)
7819       include 'DIMENSIONS'
7820       include 'COMMON.IOUNITS'
7821       include 'COMMON.CHAIN'
7822       include 'COMMON.DERIV'
7823       include 'COMMON.INTERACT'
7824       include 'COMMON.CONTACTS'
7825       include 'COMMON.TORSION'
7826       include 'COMMON.VAR'
7827       include 'COMMON.GEO'
7828       include 'COMMON.FFIELD'
7829       double precision ggg1(3),ggg2(3)
7830 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7831 cd        eello6=0.0d0
7832 cd        return
7833 cd      endif
7834 cd      write (iout,*)
7835 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7836 cd     &   ' and',k,l
7837       eello6_1=0.0d0
7838       eello6_2=0.0d0
7839       eello6_3=0.0d0
7840       eello6_4=0.0d0
7841       eello6_5=0.0d0
7842       eello6_6=0.0d0
7843 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7844 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7845       do iii=1,2
7846         do kkk=1,5
7847           do lll=1,3
7848             derx(lll,kkk,iii)=0.0d0
7849           enddo
7850         enddo
7851       enddo
7852 cd      eij=facont_hb(jj,i)
7853 cd      ekl=facont_hb(kk,k)
7854 cd      ekont=eij*ekl
7855 cd      eij=1.0d0
7856 cd      ekl=1.0d0
7857 cd      ekont=1.0d0
7858       if (l.eq.j+1) then
7859         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7860         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7861         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7862         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7863         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7864         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7865       else
7866         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7867         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7868         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7869         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7870         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7871           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7872         else
7873           eello6_5=0.0d0
7874         endif
7875         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7876       endif
7877 C If turn contributions are considered, they will be handled separately.
7878       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7879 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7880 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7881 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7882 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7883 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7884 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7885 cd      goto 1112
7886       if (j.lt.nres-1) then
7887         j1=j+1
7888         j2=j-1
7889       else
7890         j1=j-1
7891         j2=j-2
7892       endif
7893       if (l.lt.nres-1) then
7894         l1=l+1
7895         l2=l-1
7896       else
7897         l1=l-1
7898         l2=l-2
7899       endif
7900       do ll=1,3
7901 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7902 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7903 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7904 cgrad        ghalf=0.5d0*ggg1(ll)
7905 cd        ghalf=0.0d0
7906         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7907         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7908         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7909         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7910         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7911         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7912         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7913         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7914 cgrad        ghalf=0.5d0*ggg2(ll)
7915 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7916 cd        ghalf=0.0d0
7917         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7918         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7919         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7920         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7921         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7922         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7923       enddo
7924 cd      goto 1112
7925 cgrad      do m=i+1,j-1
7926 cgrad        do ll=1,3
7927 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7928 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7929 cgrad        enddo
7930 cgrad      enddo
7931 cgrad      do m=k+1,l-1
7932 cgrad        do ll=1,3
7933 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7934 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7935 cgrad        enddo
7936 cgrad      enddo
7937 cgrad1112  continue
7938 cgrad      do m=i+2,j2
7939 cgrad        do ll=1,3
7940 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7941 cgrad        enddo
7942 cgrad      enddo
7943 cgrad      do m=k+2,l2
7944 cgrad        do ll=1,3
7945 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7946 cgrad        enddo
7947 cgrad      enddo
7948 cd      do iii=1,nres-3
7949 cd        write (2,*) iii,g_corr6_loc(iii)
7950 cd      enddo
7951       eello6=ekont*eel6
7952 cd      write (2,*) 'ekont',ekont
7953 cd      write (iout,*) 'eello6',ekont*eel6
7954       return
7955       end
7956 c--------------------------------------------------------------------------
7957       double precision function eello6_graph1(i,j,k,l,imat,swap)
7958       implicit real*8 (a-h,o-z)
7959       include 'DIMENSIONS'
7960       include 'COMMON.IOUNITS'
7961       include 'COMMON.CHAIN'
7962       include 'COMMON.DERIV'
7963       include 'COMMON.INTERACT'
7964       include 'COMMON.CONTACTS'
7965       include 'COMMON.TORSION'
7966       include 'COMMON.VAR'
7967       include 'COMMON.GEO'
7968       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7969       logical swap
7970       logical lprn
7971       common /kutas/ lprn
7972 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7973 C                                                                              C
7974 C      Parallel       Antiparallel                                             C
7975 C                                                                              C
7976 C          o             o                                                     C
7977 C         /l\           /j\                                                    C
7978 C        /   \         /   \                                                   C
7979 C       /| o |         | o |\                                                  C
7980 C     \ j|/k\|  /   \  |/k\|l /                                                C
7981 C      \ /   \ /     \ /   \ /                                                 C
7982 C       o     o       o     o                                                  C
7983 C       i             i                                                        C
7984 C                                                                              C
7985 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7986       itk=itortyp(itype(k))
7987       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7988       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7989       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7990       call transpose2(EUgC(1,1,k),auxmat(1,1))
7991       call matmat2(AEA(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       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7995       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7996       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7997       s5=scalar2(vv(1),Dtobr2(1,i))
7998 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7999       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8000       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8001      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8002      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8003      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8004      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8005      & +scalar2(vv(1),Dtobr2der(1,i)))
8006       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8007       vv1(1)=pizda1(1,1)-pizda1(2,2)
8008       vv1(2)=pizda1(1,2)+pizda1(2,1)
8009       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8010       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8011       if (l.eq.j+1) then
8012         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8013      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8014      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8015      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8016      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8017       else
8018         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8019      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8020      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8021      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8022      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8023       endif
8024       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8025       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8026       vv1(1)=pizda1(1,1)-pizda1(2,2)
8027       vv1(2)=pizda1(1,2)+pizda1(2,1)
8028       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8029      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8030      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8031      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8032       do iii=1,2
8033         if (swap) then
8034           ind=3-iii
8035         else
8036           ind=iii
8037         endif
8038         do kkk=1,5
8039           do lll=1,3
8040             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8041             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8042             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8043             call transpose2(EUgC(1,1,k),auxmat(1,1))
8044             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8045      &        pizda1(1,1))
8046             vv1(1)=pizda1(1,1)-pizda1(2,2)
8047             vv1(2)=pizda1(1,2)+pizda1(2,1)
8048             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8049             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8050      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8051             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8052      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8053             s5=scalar2(vv(1),Dtobr2(1,i))
8054             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8055           enddo
8056         enddo
8057       enddo
8058       return
8059       end
8060 c----------------------------------------------------------------------------
8061       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8062       implicit real*8 (a-h,o-z)
8063       include 'DIMENSIONS'
8064       include 'COMMON.IOUNITS'
8065       include 'COMMON.CHAIN'
8066       include 'COMMON.DERIV'
8067       include 'COMMON.INTERACT'
8068       include 'COMMON.CONTACTS'
8069       include 'COMMON.TORSION'
8070       include 'COMMON.VAR'
8071       include 'COMMON.GEO'
8072       logical swap
8073       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8074      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8075       logical lprn
8076       common /kutas/ lprn
8077 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8078 C                                                                              C
8079 C      Parallel       Antiparallel                                             C
8080 C                                                                              C
8081 C          o             o                                                     C
8082 C     \   /l\           /j\   /                                                C
8083 C      \ /   \         /   \ /                                                 C
8084 C       o| o |         | o |o                                                  C
8085 C     \ j|/k\|      \  |/k\|l                                                  C
8086 C      \ /   \       \ /   \                                                   C
8087 C       o             o                                                        C
8088 C       i             i                                                        C
8089 C                                                                              C
8090 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8091 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8092 C AL 7/4/01 s1 would occur in the sixth-order moment,
8093 C           but not in a cluster cumulant
8094 #ifdef MOMENT
8095       s1=dip(1,jj,i)*dip(1,kk,k)
8096 #endif
8097       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8098       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8099       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8100       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8101       call transpose2(EUg(1,1,k),auxmat(1,1))
8102       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8103       vv(1)=pizda(1,1)-pizda(2,2)
8104       vv(2)=pizda(1,2)+pizda(2,1)
8105       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8106 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8107 #ifdef MOMENT
8108       eello6_graph2=-(s1+s2+s3+s4)
8109 #else
8110       eello6_graph2=-(s2+s3+s4)
8111 #endif
8112 c      eello6_graph2=-s3
8113 C Derivatives in gamma(i-1)
8114       if (i.gt.1) then
8115 #ifdef MOMENT
8116         s1=dipderg(1,jj,i)*dip(1,kk,k)
8117 #endif
8118         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8119         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8120         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8121         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8122 #ifdef MOMENT
8123         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8124 #else
8125         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8126 #endif
8127 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8128       endif
8129 C Derivatives in gamma(k-1)
8130 #ifdef MOMENT
8131       s1=dip(1,jj,i)*dipderg(1,kk,k)
8132 #endif
8133       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8134       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8135       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8136       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8137       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8138       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8139       vv(1)=pizda(1,1)-pizda(2,2)
8140       vv(2)=pizda(1,2)+pizda(2,1)
8141       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8142 #ifdef MOMENT
8143       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8144 #else
8145       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8146 #endif
8147 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8148 C Derivatives in gamma(j-1) or gamma(l-1)
8149       if (j.gt.1) then
8150 #ifdef MOMENT
8151         s1=dipderg(3,jj,i)*dip(1,kk,k)
8152 #endif
8153         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8154         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8155         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8156         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8157         vv(1)=pizda(1,1)-pizda(2,2)
8158         vv(2)=pizda(1,2)+pizda(2,1)
8159         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8160 #ifdef MOMENT
8161         if (swap) then
8162           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8163         else
8164           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8165         endif
8166 #endif
8167         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8168 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8169       endif
8170 C Derivatives in gamma(l-1) or gamma(j-1)
8171       if (l.gt.1) then
8172 #ifdef MOMENT
8173         s1=dip(1,jj,i)*dipderg(3,kk,k)
8174 #endif
8175         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8176         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8177         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8178         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8179         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8180         vv(1)=pizda(1,1)-pizda(2,2)
8181         vv(2)=pizda(1,2)+pizda(2,1)
8182         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8183 #ifdef MOMENT
8184         if (swap) then
8185           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8186         else
8187           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8188         endif
8189 #endif
8190         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8191 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8192       endif
8193 C Cartesian derivatives.
8194       if (lprn) then
8195         write (2,*) 'In eello6_graph2'
8196         do iii=1,2
8197           write (2,*) 'iii=',iii
8198           do kkk=1,5
8199             write (2,*) 'kkk=',kkk
8200             do jjj=1,2
8201               write (2,'(3(2f10.5),5x)')
8202      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8203             enddo
8204           enddo
8205         enddo
8206       endif
8207       do iii=1,2
8208         do kkk=1,5
8209           do lll=1,3
8210 #ifdef MOMENT
8211             if (iii.eq.1) then
8212               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8213             else
8214               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8215             endif
8216 #endif
8217             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8218      &        auxvec(1))
8219             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8220             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8221      &        auxvec(1))
8222             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8223             call transpose2(EUg(1,1,k),auxmat(1,1))
8224             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8225      &        pizda(1,1))
8226             vv(1)=pizda(1,1)-pizda(2,2)
8227             vv(2)=pizda(1,2)+pizda(2,1)
8228             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8229 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8230 #ifdef MOMENT
8231             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8232 #else
8233             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8234 #endif
8235             if (swap) then
8236               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8237             else
8238               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8239             endif
8240           enddo
8241         enddo
8242       enddo
8243       return
8244       end
8245 c----------------------------------------------------------------------------
8246       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8247       implicit real*8 (a-h,o-z)
8248       include 'DIMENSIONS'
8249       include 'COMMON.IOUNITS'
8250       include 'COMMON.CHAIN'
8251       include 'COMMON.DERIV'
8252       include 'COMMON.INTERACT'
8253       include 'COMMON.CONTACTS'
8254       include 'COMMON.TORSION'
8255       include 'COMMON.VAR'
8256       include 'COMMON.GEO'
8257       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8258       logical swap
8259 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8260 C                                                                              C
8261 C      Parallel       Antiparallel                                             C
8262 C                                                                              C
8263 C          o             o                                                     C
8264 C         /l\   /   \   /j\                                                    C
8265 C        /   \ /     \ /   \                                                   C
8266 C       /| o |o       o| o |\                                                  C
8267 C       j|/k\|  /      |/k\|l /                                                C
8268 C        /   \ /       /   \ /                                                 C
8269 C       /     o       /     o                                                  C
8270 C       i             i                                                        C
8271 C                                                                              C
8272 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8273 C
8274 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8275 C           energy moment and not to the cluster cumulant.
8276       iti=itortyp(itype(i))
8277       if (j.lt.nres-1) then
8278         itj1=itortyp(itype(j+1))
8279       else
8280         itj1=ntortyp+1
8281       endif
8282       itk=itortyp(itype(k))
8283       itk1=itortyp(itype(k+1))
8284       if (l.lt.nres-1) then
8285         itl1=itortyp(itype(l+1))
8286       else
8287         itl1=ntortyp+1
8288       endif
8289 #ifdef MOMENT
8290       s1=dip(4,jj,i)*dip(4,kk,k)
8291 #endif
8292       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8293       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8294       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8295       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8296       call transpose2(EE(1,1,itk),auxmat(1,1))
8297       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8298       vv(1)=pizda(1,1)+pizda(2,2)
8299       vv(2)=pizda(2,1)-pizda(1,2)
8300       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8301 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8302 cd     & "sum",-(s2+s3+s4)
8303 #ifdef MOMENT
8304       eello6_graph3=-(s1+s2+s3+s4)
8305 #else
8306       eello6_graph3=-(s2+s3+s4)
8307 #endif
8308 c      eello6_graph3=-s4
8309 C Derivatives in gamma(k-1)
8310       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8311       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8312       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8313       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8314 C Derivatives in gamma(l-1)
8315       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8316       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8317       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8318       vv(1)=pizda(1,1)+pizda(2,2)
8319       vv(2)=pizda(2,1)-pizda(1,2)
8320       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8321       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8322 C Cartesian derivatives.
8323       do iii=1,2
8324         do kkk=1,5
8325           do lll=1,3
8326 #ifdef MOMENT
8327             if (iii.eq.1) then
8328               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8329             else
8330               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8331             endif
8332 #endif
8333             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8334      &        auxvec(1))
8335             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8336             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8337      &        auxvec(1))
8338             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8339             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8340      &        pizda(1,1))
8341             vv(1)=pizda(1,1)+pizda(2,2)
8342             vv(2)=pizda(2,1)-pizda(1,2)
8343             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8344 #ifdef MOMENT
8345             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8346 #else
8347             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8348 #endif
8349             if (swap) then
8350               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8351             else
8352               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8353             endif
8354 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8355           enddo
8356         enddo
8357       enddo
8358       return
8359       end
8360 c----------------------------------------------------------------------------
8361       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8362       implicit real*8 (a-h,o-z)
8363       include 'DIMENSIONS'
8364       include 'COMMON.IOUNITS'
8365       include 'COMMON.CHAIN'
8366       include 'COMMON.DERIV'
8367       include 'COMMON.INTERACT'
8368       include 'COMMON.CONTACTS'
8369       include 'COMMON.TORSION'
8370       include 'COMMON.VAR'
8371       include 'COMMON.GEO'
8372       include 'COMMON.FFIELD'
8373       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8374      & auxvec1(2),auxmat1(2,2)
8375       logical swap
8376 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8377 C                                                                              C
8378 C      Parallel       Antiparallel                                             C
8379 C                                                                              C
8380 C          o             o                                                     C
8381 C         /l\   /   \   /j\                                                    C
8382 C        /   \ /     \ /   \                                                   C
8383 C       /| o |o       o| o |\                                                  C
8384 C     \ j|/k\|      \  |/k\|l                                                  C
8385 C      \ /   \       \ /   \                                                   C
8386 C       o     \       o     \                                                  C
8387 C       i             i                                                        C
8388 C                                                                              C
8389 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8390 C
8391 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8392 C           energy moment and not to the cluster cumulant.
8393 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8394       iti=itortyp(itype(i))
8395       itj=itortyp(itype(j))
8396       if (j.lt.nres-1) then
8397         itj1=itortyp(itype(j+1))
8398       else
8399         itj1=ntortyp+1
8400       endif
8401       itk=itortyp(itype(k))
8402       if (k.lt.nres-1) then
8403         itk1=itortyp(itype(k+1))
8404       else
8405         itk1=ntortyp+1
8406       endif
8407       itl=itortyp(itype(l))
8408       if (l.lt.nres-1) then
8409         itl1=itortyp(itype(l+1))
8410       else
8411         itl1=ntortyp+1
8412       endif
8413 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8414 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8415 cd     & ' itl',itl,' itl1',itl1
8416 #ifdef MOMENT
8417       if (imat.eq.1) then
8418         s1=dip(3,jj,i)*dip(3,kk,k)
8419       else
8420         s1=dip(2,jj,j)*dip(2,kk,l)
8421       endif
8422 #endif
8423       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8424       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8425       if (j.eq.l+1) then
8426         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8427         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8428       else
8429         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8430         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8431       endif
8432       call transpose2(EUg(1,1,k),auxmat(1,1))
8433       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8434       vv(1)=pizda(1,1)-pizda(2,2)
8435       vv(2)=pizda(2,1)+pizda(1,2)
8436       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8437 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8438 #ifdef MOMENT
8439       eello6_graph4=-(s1+s2+s3+s4)
8440 #else
8441       eello6_graph4=-(s2+s3+s4)
8442 #endif
8443 C Derivatives in gamma(i-1)
8444       if (i.gt.1) then
8445 #ifdef MOMENT
8446         if (imat.eq.1) then
8447           s1=dipderg(2,jj,i)*dip(3,kk,k)
8448         else
8449           s1=dipderg(4,jj,j)*dip(2,kk,l)
8450         endif
8451 #endif
8452         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8453         if (j.eq.l+1) then
8454           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8455           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8456         else
8457           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8458           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8459         endif
8460         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8461         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8462 cd          write (2,*) 'turn6 derivatives'
8463 #ifdef MOMENT
8464           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8465 #else
8466           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8467 #endif
8468         else
8469 #ifdef MOMENT
8470           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8471 #else
8472           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8473 #endif
8474         endif
8475       endif
8476 C Derivatives in gamma(k-1)
8477 #ifdef MOMENT
8478       if (imat.eq.1) then
8479         s1=dip(3,jj,i)*dipderg(2,kk,k)
8480       else
8481         s1=dip(2,jj,j)*dipderg(4,kk,l)
8482       endif
8483 #endif
8484       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8485       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8486       if (j.eq.l+1) then
8487         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8488         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8489       else
8490         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8491         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8492       endif
8493       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8494       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8495       vv(1)=pizda(1,1)-pizda(2,2)
8496       vv(2)=pizda(2,1)+pizda(1,2)
8497       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8498       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8499 #ifdef MOMENT
8500         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8501 #else
8502         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8503 #endif
8504       else
8505 #ifdef MOMENT
8506         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8507 #else
8508         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8509 #endif
8510       endif
8511 C Derivatives in gamma(j-1) or gamma(l-1)
8512       if (l.eq.j+1 .and. l.gt.1) then
8513         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8514         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8515         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8516         vv(1)=pizda(1,1)-pizda(2,2)
8517         vv(2)=pizda(2,1)+pizda(1,2)
8518         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8519         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8520       else if (j.gt.1) then
8521         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8522         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8523         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8524         vv(1)=pizda(1,1)-pizda(2,2)
8525         vv(2)=pizda(2,1)+pizda(1,2)
8526         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8527         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8528           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8529         else
8530           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8531         endif
8532       endif
8533 C Cartesian derivatives.
8534       do iii=1,2
8535         do kkk=1,5
8536           do lll=1,3
8537 #ifdef MOMENT
8538             if (iii.eq.1) then
8539               if (imat.eq.1) then
8540                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8541               else
8542                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8543               endif
8544             else
8545               if (imat.eq.1) then
8546                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8547               else
8548                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8549               endif
8550             endif
8551 #endif
8552             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8553      &        auxvec(1))
8554             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8555             if (j.eq.l+1) then
8556               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8557      &          b1(1,itj1),auxvec(1))
8558               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8559             else
8560               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8561      &          b1(1,itl1),auxvec(1))
8562               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8563             endif
8564             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8565      &        pizda(1,1))
8566             vv(1)=pizda(1,1)-pizda(2,2)
8567             vv(2)=pizda(2,1)+pizda(1,2)
8568             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8569             if (swap) then
8570               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8571 #ifdef MOMENT
8572                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8573      &             -(s1+s2+s4)
8574 #else
8575                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8576      &             -(s2+s4)
8577 #endif
8578                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8579               else
8580 #ifdef MOMENT
8581                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8582 #else
8583                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8584 #endif
8585                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8586               endif
8587             else
8588 #ifdef MOMENT
8589               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8590 #else
8591               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8592 #endif
8593               if (l.eq.j+1) then
8594                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8595               else
8596                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8597               endif
8598             endif
8599           enddo
8600         enddo
8601       enddo
8602       return
8603       end
8604 c----------------------------------------------------------------------------
8605       double precision function eello_turn6(i,jj,kk)
8606       implicit real*8 (a-h,o-z)
8607       include 'DIMENSIONS'
8608       include 'COMMON.IOUNITS'
8609       include 'COMMON.CHAIN'
8610       include 'COMMON.DERIV'
8611       include 'COMMON.INTERACT'
8612       include 'COMMON.CONTACTS'
8613       include 'COMMON.TORSION'
8614       include 'COMMON.VAR'
8615       include 'COMMON.GEO'
8616       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8617      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8618      &  ggg1(3),ggg2(3)
8619       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8620      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8621 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8622 C           the respective energy moment and not to the cluster cumulant.
8623       s1=0.0d0
8624       s8=0.0d0
8625       s13=0.0d0
8626 c
8627       eello_turn6=0.0d0
8628       j=i+4
8629       k=i+1
8630       l=i+3
8631       iti=itortyp(itype(i))
8632       itk=itortyp(itype(k))
8633       itk1=itortyp(itype(k+1))
8634       itl=itortyp(itype(l))
8635       itj=itortyp(itype(j))
8636 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8637 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8638 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8639 cd        eello6=0.0d0
8640 cd        return
8641 cd      endif
8642 cd      write (iout,*)
8643 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8644 cd     &   ' and',k,l
8645 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8646       do iii=1,2
8647         do kkk=1,5
8648           do lll=1,3
8649             derx_turn(lll,kkk,iii)=0.0d0
8650           enddo
8651         enddo
8652       enddo
8653 cd      eij=1.0d0
8654 cd      ekl=1.0d0
8655 cd      ekont=1.0d0
8656       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8657 cd      eello6_5=0.0d0
8658 cd      write (2,*) 'eello6_5',eello6_5
8659 #ifdef MOMENT
8660       call transpose2(AEA(1,1,1),auxmat(1,1))
8661       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8662       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8663       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8664 #endif
8665       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8666       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8667       s2 = scalar2(b1(1,itk),vtemp1(1))
8668 #ifdef MOMENT
8669       call transpose2(AEA(1,1,2),atemp(1,1))
8670       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8671       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8672       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8673 #endif
8674       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8675       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8676       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8677 #ifdef MOMENT
8678       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8679       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8680       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8681       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8682       ss13 = scalar2(b1(1,itk),vtemp4(1))
8683       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8684 #endif
8685 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8686 c      s1=0.0d0
8687 c      s2=0.0d0
8688 c      s8=0.0d0
8689 c      s12=0.0d0
8690 c      s13=0.0d0
8691       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8692 C Derivatives in gamma(i+2)
8693       s1d =0.0d0
8694       s8d =0.0d0
8695 #ifdef MOMENT
8696       call transpose2(AEA(1,1,1),auxmatd(1,1))
8697       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8698       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8699       call transpose2(AEAderg(1,1,2),atempd(1,1))
8700       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8701       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8702 #endif
8703       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8704       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8705       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8706 c      s1d=0.0d0
8707 c      s2d=0.0d0
8708 c      s8d=0.0d0
8709 c      s12d=0.0d0
8710 c      s13d=0.0d0
8711       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8712 C Derivatives in gamma(i+3)
8713 #ifdef MOMENT
8714       call transpose2(AEA(1,1,1),auxmatd(1,1))
8715       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8716       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8717       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8718 #endif
8719       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8720       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8721       s2d = scalar2(b1(1,itk),vtemp1d(1))
8722 #ifdef MOMENT
8723       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8724       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8725 #endif
8726       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8727 #ifdef MOMENT
8728       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8729       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8730       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8731 #endif
8732 c      s1d=0.0d0
8733 c      s2d=0.0d0
8734 c      s8d=0.0d0
8735 c      s12d=0.0d0
8736 c      s13d=0.0d0
8737 #ifdef MOMENT
8738       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8739      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8740 #else
8741       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8742      &               -0.5d0*ekont*(s2d+s12d)
8743 #endif
8744 C Derivatives in gamma(i+4)
8745       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8746       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8747       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8748 #ifdef MOMENT
8749       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8750       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8751       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8752 #endif
8753 c      s1d=0.0d0
8754 c      s2d=0.0d0
8755 c      s8d=0.0d0
8756 C      s12d=0.0d0
8757 c      s13d=0.0d0
8758 #ifdef MOMENT
8759       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8760 #else
8761       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8762 #endif
8763 C Derivatives in gamma(i+5)
8764 #ifdef MOMENT
8765       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8766       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8767       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8768 #endif
8769       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8770       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8771       s2d = scalar2(b1(1,itk),vtemp1d(1))
8772 #ifdef MOMENT
8773       call transpose2(AEA(1,1,2),atempd(1,1))
8774       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8775       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8776 #endif
8777       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8778       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8779 #ifdef MOMENT
8780       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8781       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8782       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8783 #endif
8784 c      s1d=0.0d0
8785 c      s2d=0.0d0
8786 c      s8d=0.0d0
8787 c      s12d=0.0d0
8788 c      s13d=0.0d0
8789 #ifdef MOMENT
8790       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8791      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8792 #else
8793       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8794      &               -0.5d0*ekont*(s2d+s12d)
8795 #endif
8796 C Cartesian derivatives
8797       do iii=1,2
8798         do kkk=1,5
8799           do lll=1,3
8800 #ifdef MOMENT
8801             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8802             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8803             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8804 #endif
8805             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8806             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8807      &          vtemp1d(1))
8808             s2d = scalar2(b1(1,itk),vtemp1d(1))
8809 #ifdef MOMENT
8810             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8811             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8812             s8d = -(atempd(1,1)+atempd(2,2))*
8813      &           scalar2(cc(1,1,itl),vtemp2(1))
8814 #endif
8815             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8816      &           auxmatd(1,1))
8817             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8818             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8819 c      s1d=0.0d0
8820 c      s2d=0.0d0
8821 c      s8d=0.0d0
8822 c      s12d=0.0d0
8823 c      s13d=0.0d0
8824 #ifdef MOMENT
8825             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8826      &        - 0.5d0*(s1d+s2d)
8827 #else
8828             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8829      &        - 0.5d0*s2d
8830 #endif
8831 #ifdef MOMENT
8832             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8833      &        - 0.5d0*(s8d+s12d)
8834 #else
8835             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8836      &        - 0.5d0*s12d
8837 #endif
8838           enddo
8839         enddo
8840       enddo
8841 #ifdef MOMENT
8842       do kkk=1,5
8843         do lll=1,3
8844           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8845      &      achuj_tempd(1,1))
8846           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8847           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8848           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8849           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8850           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8851      &      vtemp4d(1))
8852           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8853           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8854           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8855         enddo
8856       enddo
8857 #endif
8858 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8859 cd     &  16*eel_turn6_num
8860 cd      goto 1112
8861       if (j.lt.nres-1) then
8862         j1=j+1
8863         j2=j-1
8864       else
8865         j1=j-1
8866         j2=j-2
8867       endif
8868       if (l.lt.nres-1) then
8869         l1=l+1
8870         l2=l-1
8871       else
8872         l1=l-1
8873         l2=l-2
8874       endif
8875       do ll=1,3
8876 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8877 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8878 cgrad        ghalf=0.5d0*ggg1(ll)
8879 cd        ghalf=0.0d0
8880         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8881         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8882         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8883      &    +ekont*derx_turn(ll,2,1)
8884         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8885         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8886      &    +ekont*derx_turn(ll,4,1)
8887         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8888         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8889         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8890 cgrad        ghalf=0.5d0*ggg2(ll)
8891 cd        ghalf=0.0d0
8892         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8893      &    +ekont*derx_turn(ll,2,2)
8894         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8895         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8896      &    +ekont*derx_turn(ll,4,2)
8897         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8898         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8899         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8900       enddo
8901 cd      goto 1112
8902 cgrad      do m=i+1,j-1
8903 cgrad        do ll=1,3
8904 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8905 cgrad        enddo
8906 cgrad      enddo
8907 cgrad      do m=k+1,l-1
8908 cgrad        do ll=1,3
8909 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8910 cgrad        enddo
8911 cgrad      enddo
8912 cgrad1112  continue
8913 cgrad      do m=i+2,j2
8914 cgrad        do ll=1,3
8915 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8916 cgrad        enddo
8917 cgrad      enddo
8918 cgrad      do m=k+2,l2
8919 cgrad        do ll=1,3
8920 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8921 cgrad        enddo
8922 cgrad      enddo
8923 cd      do iii=1,nres-3
8924 cd        write (2,*) iii,g_corr6_loc(iii)
8925 cd      enddo
8926       eello_turn6=ekont*eel_turn6
8927 cd      write (2,*) 'ekont',ekont
8928 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8929       return
8930       end
8931
8932 C-----------------------------------------------------------------------------
8933       double precision function scalar(u,v)
8934 !DIR$ INLINEALWAYS scalar
8935 #ifndef OSF
8936 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8937 #endif
8938       implicit none
8939       double precision u(3),v(3)
8940 cd      double precision sc
8941 cd      integer i
8942 cd      sc=0.0d0
8943 cd      do i=1,3
8944 cd        sc=sc+u(i)*v(i)
8945 cd      enddo
8946 cd      scalar=sc
8947
8948       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8949       return
8950       end
8951 crc-------------------------------------------------
8952       SUBROUTINE MATVEC2(A1,V1,V2)
8953 !DIR$ INLINEALWAYS MATVEC2
8954 #ifndef OSF
8955 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8956 #endif
8957       implicit real*8 (a-h,o-z)
8958       include 'DIMENSIONS'
8959       DIMENSION A1(2,2),V1(2),V2(2)
8960 c      DO 1 I=1,2
8961 c        VI=0.0
8962 c        DO 3 K=1,2
8963 c    3     VI=VI+A1(I,K)*V1(K)
8964 c        Vaux(I)=VI
8965 c    1 CONTINUE
8966
8967       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8968       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8969
8970       v2(1)=vaux1
8971       v2(2)=vaux2
8972       END
8973 C---------------------------------------
8974       SUBROUTINE MATMAT2(A1,A2,A3)
8975 #ifndef OSF
8976 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8977 #endif
8978       implicit real*8 (a-h,o-z)
8979       include 'DIMENSIONS'
8980       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8981 c      DIMENSION AI3(2,2)
8982 c        DO  J=1,2
8983 c          A3IJ=0.0
8984 c          DO K=1,2
8985 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8986 c          enddo
8987 c          A3(I,J)=A3IJ
8988 c       enddo
8989 c      enddo
8990
8991       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8992       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8993       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8994       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8995
8996       A3(1,1)=AI3_11
8997       A3(2,1)=AI3_21
8998       A3(1,2)=AI3_12
8999       A3(2,2)=AI3_22
9000       END
9001
9002 c-------------------------------------------------------------------------
9003       double precision function scalar2(u,v)
9004 !DIR$ INLINEALWAYS scalar2
9005       implicit none
9006       double precision u(2),v(2)
9007       double precision sc
9008       integer i
9009       scalar2=u(1)*v(1)+u(2)*v(2)
9010       return
9011       end
9012
9013 C-----------------------------------------------------------------------------
9014
9015       subroutine transpose2(a,at)
9016 !DIR$ INLINEALWAYS transpose2
9017 #ifndef OSF
9018 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9019 #endif
9020       implicit none
9021       double precision a(2,2),at(2,2)
9022       at(1,1)=a(1,1)
9023       at(1,2)=a(2,1)
9024       at(2,1)=a(1,2)
9025       at(2,2)=a(2,2)
9026       return
9027       end
9028 c--------------------------------------------------------------------------
9029       subroutine transpose(n,a,at)
9030       implicit none
9031       integer n,i,j
9032       double precision a(n,n),at(n,n)
9033       do i=1,n
9034         do j=1,n
9035           at(j,i)=a(i,j)
9036         enddo
9037       enddo
9038       return
9039       end
9040 C---------------------------------------------------------------------------
9041       subroutine prodmat3(a1,a2,kk,transp,prod)
9042 !DIR$ INLINEALWAYS prodmat3
9043 #ifndef OSF
9044 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9045 #endif
9046       implicit none
9047       integer i,j
9048       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9049       logical transp
9050 crc      double precision auxmat(2,2),prod_(2,2)
9051
9052       if (transp) then
9053 crc        call transpose2(kk(1,1),auxmat(1,1))
9054 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9055 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9056
9057            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9058      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9059            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9060      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9061            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9062      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9063            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9064      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9065
9066       else
9067 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9068 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9069
9070            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9071      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9072            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9073      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9074            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9075      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9076            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9077      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9078
9079       endif
9080 c      call transpose2(a2(1,1),a2t(1,1))
9081
9082 crc      print *,transp
9083 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9084 crc      print *,((prod(i,j),i=1,2),j=1,2)
9085
9086       return
9087       end
9088