source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 c    Here are the energies showed per procesor if the are more processors
 305 c    per molecule then we sum it up in sum_energy subroutine
 306 c      print *," Processor",myrank," calls SUM_ENERGY"
 307       call sum_energy(energia,.true.)
 308       if (dyn_ss) call dyn_set_nss
 309 c      print *," Processor",myrank," left SUM_ENERGY"
 310 #ifdef TIMING
 311       time_sumene=time_sumene+MPI_Wtime()-time00
 312 #endif
 313       return
 314       end
 315 c-------------------------------------------------------------------------------
 316       subroutine sum_energy(energia,reduce)
 317       implicit real*8 (a-h,o-z)
 318       include 'DIMENSIONS'
 319 #ifndef ISNAN
 320       external proc_proc
 321 #ifdef WINPGI
 322 cMS$ATTRIBUTES C ::  proc_proc
 323 #endif
 324 #endif
 325 #ifdef MPI
 326       include "mpif.h"
 327 #endif
 328       include 'COMMON.SETUP'
 329       include 'COMMON.IOUNITS'
 330       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 331       include 'COMMON.FFIELD'
 332       include 'COMMON.DERIV'
 333       include 'COMMON.INTERACT'
 334       include 'COMMON.SBRIDGE'
 335       include 'COMMON.CHAIN'
 336       include 'COMMON.VAR'
 337       include 'COMMON.CONTROL'
 338       include 'COMMON.TIME1'
 339       logical reduce
 340 #ifdef MPI
 341       if (nfgtasks.gt.1 .and. reduce) then
 342 #ifdef DEBUG
 343         write (iout,*) "energies before REDUCE"
 344         call enerprint(energia)
 345         call flush(iout)
 346 #endif
 347         do i=0,n_ene
 348           enebuff(i)=energia(i)
 349         enddo
 350         time00=MPI_Wtime()
 351         call MPI_Barrier(FG_COMM,IERR)
 352         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 353         time00=MPI_Wtime()
 354         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 355      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 356 #ifdef DEBUG
 357         write (iout,*) "energies after REDUCE"
 358         call enerprint(energia)
 359         call flush(iout)
 360 #endif
 361         time_Reduce=time_Reduce+MPI_Wtime()-time00
 362       endif
 363       if (fg_rank.eq.0) then
 364 #endif
 365       evdw=energia(1)
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 446 #endif
 447       include 'COMMON.SETUP'
 448       include 'COMMON.IOUNITS'
 449       include 'COMMON.FFIELD'
 450       include 'COMMON.DERIV'
 451       include 'COMMON.INTERACT'
 452       include 'COMMON.SBRIDGE'
 453       include 'COMMON.CHAIN'
 454       include 'COMMON.VAR'
 455       include 'COMMON.CONTROL'
 456       include 'COMMON.TIME1'
 457       include 'COMMON.MAXGRAD'
 458       include 'COMMON.SCCOR'
 459 #ifdef TIMING
 460       time01=MPI_Wtime()
 461 #endif
 462 #ifdef DEBUG
 463       write (iout,*) "sum_gradient gvdwc, gvdwx"
 464       do i=1,nres
 465         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 466      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 467       enddo
 468       call flush(iout)
 469 #endif
 470 #ifdef MPI
 471 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 472         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 473      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 474 #endif
 475 C
 476 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 477 C            in virtual-bond-vector coordinates
 478 C
 479 #ifdef DEBUG
 480 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 481 c      do i=1,nres-1
 482 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 483 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 484 c      enddo
 485 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 486 c      do i=1,nres-1
 487 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 488 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 489 c      enddo
 490       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 491       do i=1,nres
 492         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 493      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 494      &   g_corr5_loc(i)
 495       enddo
 496       call flush(iout)
 497 #endif
 498 #ifdef SPLITELE
 499       do i=1,nct
 500         do j=1,3
 501           gradbufc(j,i)=wsc*gvdwc(j,i)+
 502      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 503      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 504      &                wel_loc*gel_loc_long(j,i)+
 505      &                wcorr*gradcorr_long(j,i)+
 506      &                wcorr5*gradcorr5_long(j,i)+
 507      &                wcorr6*gradcorr6_long(j,i)+
 508      &                wturn6*gcorr6_turn_long(j,i)+
 509      &                wstrain*ghpbc(j,i)
 510         enddo
 511       enddo
 512 #else
 513       do i=1,nct
 514         do j=1,3
 515           gradbufc(j,i)=wsc*gvdwc(j,i)+
 516      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 517      &                welec*gelc_long(j,i)+
 518      &                wbond*gradb(j,i)+
 519      &                wel_loc*gel_loc_long(j,i)+
 520      &                wcorr*gradcorr_long(j,i)+
 521      &                wcorr5*gradcorr5_long(j,i)+
 522      &                wcorr6*gradcorr6_long(j,i)+
 523      &                wturn6*gcorr6_turn_long(j,i)+
 524      &                wstrain*ghpbc(j,i)
 525         enddo
 526       enddo
 527 #endif
 528 #ifdef MPI
 529       if (nfgtasks.gt.1) then
 530       time00=MPI_Wtime()
 531 #ifdef DEBUG
 532       write (iout,*) "gradbufc before allreduce"
 533       do i=1,nres
 534         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 535       enddo
 536       call flush(iout)
 537 #endif
 538       do i=1,nres
 539         do j=1,3
 540           gradbufc_sum(j,i)=gradbufc(j,i)
 541         enddo
 542       enddo
 543 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 544 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 545 c      time_reduce=time_reduce+MPI_Wtime()-time00
 546 #ifdef DEBUG
 547 c      write (iout,*) "gradbufc_sum after allreduce"
 548 c      do i=1,nres
 549 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 550 c      enddo
 551 c      call flush(iout)
 552 #endif
 553 #ifdef TIMING
 554 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 555 #endif
 556       do i=nnt,nres
 557         do k=1,3
 558           gradbufc(k,i)=0.0d0
 559         enddo
 560       enddo
 561 #ifdef DEBUG
 562       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 563       write (iout,*) (i," jgrad_start",jgrad_start(i),
 564      &                  " jgrad_end  ",jgrad_end(i),
 565      &                  i=igrad_start,igrad_end)
 566 #endif
 567 c
 568 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 569 c do not parallelize this part.
 570 c
 571 c      do i=igrad_start,igrad_end
 572 c        do j=jgrad_start(i),jgrad_end(i)
 573 c          do k=1,3
 574 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 575 c          enddo
 576 c        enddo
 577 c      enddo
 578       do j=1,3
 579         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 580       enddo
 581       do i=nres-2,nnt,-1
 582         do j=1,3
 583           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 584         enddo
 585       enddo
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc after summing"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       else
 594 #endif
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       do i=1,nres
 603         do j=1,3
 604           gradbufc_sum(j,i)=gradbufc(j,i)
 605           gradbufc(j,i)=0.0d0
 606         enddo
 607       enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,nnt,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 c      do i=nnt,nres-1
 617 c        do k=1,3
 618 c          gradbufc(k,i)=0.0d0
 619 c        enddo
 620 c        do j=i+1,nres
 621 c          do k=1,3
 622 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 623 c          enddo
 624 c        enddo
 625 c      enddo
 626 #ifdef DEBUG
 627       write (iout,*) "gradbufc after summing"
 628       do i=1,nres
 629         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 630       enddo
 631       call flush(iout)
 632 #endif
 633 #ifdef MPI
 634       endif
 635 #endif
 636       do k=1,3
 637         gradbufc(k,nres)=0.0d0
 638       enddo
 639       do i=1,nct
 640         do j=1,3
 641 #ifdef SPLITELE
 642           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 643      &                wel_loc*gel_loc(j,i)+
 644      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 645      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 646      &                wel_loc*gel_loc_long(j,i)+
 647      &                wcorr*gradcorr_long(j,i)+
 648      &                wcorr5*gradcorr5_long(j,i)+
 649      &                wcorr6*gradcorr6_long(j,i)+
 650      &                wturn6*gcorr6_turn_long(j,i))+
 651      &                wbond*gradb(j,i)+
 652      &                wcorr*gradcorr(j,i)+
 653      &                wturn3*gcorr3_turn(j,i)+
 654      &                wturn4*gcorr4_turn(j,i)+
 655      &                wcorr5*gradcorr5(j,i)+
 656      &                wcorr6*gradcorr6(j,i)+
 657      &                wturn6*gcorr6_turn(j,i)+
 658      &                wsccor*gsccorc(j,i)
 659      &               +wscloc*gscloc(j,i)
 660 #else
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679 #endif
 680           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 681      &                  wbond*gradbx(j,i)+
 682      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 683      &                  wsccor*gsccorx(j,i)
 684      &                 +wscloc*gsclocx(j,i)
 685         enddo
 686       enddo
 687 #ifdef DEBUG
 688       write (iout,*) "gloc before adding corr"
 689       do i=1,4*nres
 690         write (iout,*) i,gloc(i,icg)
 691       enddo
 692 #endif
 693       do i=1,nres-3
 694         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 695      &   +wcorr5*g_corr5_loc(i)
 696      &   +wcorr6*g_corr6_loc(i)
 697      &   +wturn4*gel_loc_turn4(i)
 698      &   +wturn3*gel_loc_turn3(i)
 699      &   +wturn6*gel_loc_turn6(i)
 700      &   +wel_loc*gel_loc_loc(i)
 701       enddo
 702 #ifdef DEBUG
 703       write (iout,*) "gloc after adding corr"
 704       do i=1,4*nres
 705         write (iout,*) i,gloc(i,icg)
 706       enddo
 707 #endif
 708 #ifdef MPI
 709       if (nfgtasks.gt.1) then
 710         do j=1,3
 711           do i=1,nres
 712             gradbufc(j,i)=gradc(j,i,icg)
 713             gradbufx(j,i)=gradx(j,i,icg)
 714           enddo
 715         enddo
 716         do i=1,4*nres
 717           glocbuf(i)=gloc(i,icg)
 718         enddo
 719 c#define DEBUG
 720 #ifdef DEBUG
 721       write (iout,*) "gloc_sc before reduce"
 722       do i=1,nres
 723        do j=1,1
 724         write (iout,*) i,j,gloc_sc(j,i,icg)
 725        enddo
 726       enddo
 727 #endif
 728 c#undef DEBUG
 729         do i=1,nres
 730          do j=1,3
 731           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 732          enddo
 733         enddo
 734         time00=MPI_Wtime()
 735         call MPI_Barrier(FG_COMM,IERR)
 736         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 737         time00=MPI_Wtime()
 738         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 739      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 740         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 743      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 744         time_reduce=time_reduce+MPI_Wtime()-time00
 745         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 746      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 747         time_reduce=time_reduce+MPI_Wtime()-time00
 748 c#define DEBUG
 749 #ifdef DEBUG
 750       write (iout,*) "gloc_sc after reduce"
 751       do i=1,nres
 752        do j=1,1
 753         write (iout,*) i,j,gloc_sc(j,i,icg)
 754        enddo
 755       enddo
 756 #endif
 757 c#undef DEBUG
 758 #ifdef DEBUG
 759       write (iout,*) "gloc after reduce"
 760       do i=1,4*nres
 761         write (iout,*) i,gloc(i,icg)
 762       enddo
 763 #endif
 764       endif
 765 #endif
 766       if (gnorm_check) then
 767 c
 768 c Compute the maximum elements of the gradient
 769 c
 770       gvdwc_max=0.0d0
 771       gvdwc_scp_max=0.0d0
 772       gelc_max=0.0d0
 773       gvdwpp_max=0.0d0
 774       gradb_max=0.0d0
 775       ghpbc_max=0.0d0
 776       gradcorr_max=0.0d0
 777       gel_loc_max=0.0d0
 778       gcorr3_turn_max=0.0d0
 779       gcorr4_turn_max=0.0d0
 780       gradcorr5_max=0.0d0
 781       gradcorr6_max=0.0d0
 782       gcorr6_turn_max=0.0d0
 783       gsccorc_max=0.0d0
 784       gscloc_max=0.0d0
 785       gvdwx_max=0.0d0
 786       gradx_scp_max=0.0d0
 787       ghpbx_max=0.0d0
 788       gradxorr_max=0.0d0
 789       gsccorx_max=0.0d0
 790       gsclocx_max=0.0d0
 791       do i=1,nct
 792         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 793         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 794         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 795         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 796      &   gvdwc_scp_max=gvdwc_scp_norm
 797         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 798         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 799         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 800         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 801         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 802         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 803         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 804         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 805         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 806         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 807         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 808         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 809         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 810      &    gcorr3_turn(1,i)))
 811         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 812      &    gcorr3_turn_max=gcorr3_turn_norm
 813         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 814      &    gcorr4_turn(1,i)))
 815         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 816      &    gcorr4_turn_max=gcorr4_turn_norm
 817         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 818         if (gradcorr5_norm.gt.gradcorr5_max)
 819      &    gradcorr5_max=gradcorr5_norm
 820         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 821         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 822         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 823      &    gcorr6_turn(1,i)))
 824         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 825      &    gcorr6_turn_max=gcorr6_turn_norm
 826         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 827         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 828         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 829         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 830         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 831         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 832         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 833         if (gradx_scp_norm.gt.gradx_scp_max)
 834      &    gradx_scp_max=gradx_scp_norm
 835         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 836         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 837         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 838         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 839         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 840         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 841         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 842         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 843       enddo
 844       if (gradout) then
 845 #ifdef AIX
 846         open(istat,file=statname,position="append")
 847 #else
 848         open(istat,file=statname,access="append")
 849 #endif
 850         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 851      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 852      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 853      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 854      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 855      &     gsccorx_max,gsclocx_max
 856         close(istat)
 857         if (gvdwc_max.gt.1.0d4) then
 858           write (iout,*) "gvdwc gvdwx gradb gradbx"
 859           do i=nnt,nct
 860             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 861      &        gradb(j,i),gradbx(j,i),j=1,3)
 862           enddo
 863           call pdbout(0.0d0,'cipiszcze',iout)
 864           call flush(iout)
 865         endif
 866       endif
 867       endif
 868 #ifdef DEBUG
 869       write (iout,*) "gradc gradx gloc"
 870       do i=1,nres
 871         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 872      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 873       enddo
 874 #endif
 875 #ifdef TIMING
 876       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 877 #endif
 878       return
 879       end
 880 c-------------------------------------------------------------------------------
 881       subroutine rescale_weights(t_bath)
 882       implicit real*8 (a-h,o-z)
 883       include 'DIMENSIONS'
 884       include 'COMMON.IOUNITS'
 885       include 'COMMON.FFIELD'
 886       include 'COMMON.SBRIDGE'
 887       double precision kfac /2.4d0/
 888       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 889 c      facT=temp0/t_bath
 890 c      facT=2*temp0/(t_bath+temp0)
 891       if (rescale_mode.eq.0) then
 892         facT=1.0d0
 893         facT2=1.0d0
 894         facT3=1.0d0
 895         facT4=1.0d0
 896         facT5=1.0d0
 897       else if (rescale_mode.eq.1) then
 898         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 899         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 900         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 901         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 902         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 903       else if (rescale_mode.eq.2) then
 904         x=t_bath/temp0
 905         x2=x*x
 906         x3=x2*x
 907         x4=x3*x
 908         x5=x4*x
 909         facT=licznik/dlog(dexp(x)+dexp(-x))
 910         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 911         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 912         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 913         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 914       else
 915         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 916         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 917 #ifdef MPI
 918        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 919 #endif
 920        stop 555
 921       endif
 922       welec=weights(3)*fact
 923       wcorr=weights(4)*fact3
 924       wcorr5=weights(5)*fact4
 925       wcorr6=weights(6)*fact5
 926       wel_loc=weights(7)*fact2
 927       wturn3=weights(8)*fact2
 928       wturn4=weights(9)*fact3
 929       wturn6=weights(10)*fact5
 930       wtor=weights(13)*fact
 931       wtor_d=weights(14)*fact2
 932       wsccor=weights(21)*fact
 933
 934       return
 935       end
 936 C------------------------------------------------------------------------
 937       subroutine enerprint(energia)
 938       implicit real*8 (a-h,o-z)
 939       include 'DIMENSIONS'
 940       include 'COMMON.IOUNITS'
 941       include 'COMMON.FFIELD'
 942       include 'COMMON.SBRIDGE'
 943       include 'COMMON.MD'
 944       double precision energia(0:n_ene)
 945       etot=energia(0)
 946       evdw=energia(1)
 947       evdw2=energia(2)
 948 #ifdef SCP14
 949       evdw2=energia(2)+energia(18)
 950 #else
 951       evdw2=energia(2)
 952 #endif
 953       ees=energia(3)
 954 #ifdef SPLITELE
 955       evdw1=energia(16)
 956 #endif
 957       ecorr=energia(4)
 958       ecorr5=energia(5)
 959       ecorr6=energia(6)
 960       eel_loc=energia(7)
 961       eello_turn3=energia(8)
 962       eello_turn4=energia(9)
 963       eello_turn6=energia(10)
 964       ebe=energia(11)
 965       escloc=energia(12)
 966       etors=energia(13)
 967       etors_d=energia(14)
 968       ehpb=energia(15)
 969       edihcnstr=energia(19)
 970       estr=energia(17)
 971       Uconst=energia(20)
 972       esccor=energia(21)
 973 #ifdef SPLITELE
 974       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 975      &  estr,wbond,ebe,wang,
 976      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 977      &  ecorr,wcorr,
 978      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 979      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 980      &  edihcnstr,ebr*nss,
 981      &  Uconst,etot
 982    10 format (/'Virtual-chain energies:'//
 983      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 984      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 985      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 986      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 987      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 988      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 989      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 990      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 991      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 992      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 993      & ' (SS bridges & dist. cnstr.)'/
 994      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 998      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 999      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1000      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1001      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1002      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1003      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1004      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1005      & 'ETOT=  ',1pE16.6,' (total)')
1006 #else
1007       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1008      &  estr,wbond,ebe,wang,
1009      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1010      &  ecorr,wcorr,
1011      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1012      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1013      &  ebr*nss,Uconst,etot
1014    10 format (/'Virtual-chain energies:'//
1015      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1016      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1017      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1018      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1019      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1020      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1021      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1022      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1023      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1024      & ' (SS bridges & dist. cnstr.)'/
1025      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1029      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1030      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1031      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1032      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1033      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1034      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1035      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1036      & 'ETOT=  ',1pE16.6,' (total)')
1037 #endif
1038       return
1039       end
1040 C-----------------------------------------------------------------------
1041       subroutine elj(evdw)
1042 C
1043 C This subroutine calculates the interaction energy of nonbonded side chains
1044 C assuming the LJ potential of interaction.
1045 C
1046       implicit real*8 (a-h,o-z)
1047       include 'DIMENSIONS'
1048       parameter (accur=1.0d-10)
1049       include 'COMMON.GEO'
1050       include 'COMMON.VAR'
1051       include 'COMMON.LOCAL'
1052       include 'COMMON.CHAIN'
1053       include 'COMMON.DERIV'
1054       include 'COMMON.INTERACT'
1055       include 'COMMON.TORSION'
1056       include 'COMMON.SBRIDGE'
1057       include 'COMMON.NAMES'
1058       include 'COMMON.IOUNITS'
1059       include 'COMMON.CONTACTS'
1060       dimension gg(3)
1061 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 C Change 12/1/95
1071         num_conti=0
1072 C
1073 C Calculate SC interaction energy.
1074 C
1075         do iint=1,nint_gr(i)
1076 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1077 cd   &                  'iend=',iend(i,iint)
1078           do j=istart(i,iint),iend(i,iint)
1079             itypj=iabs(itype(j))
1080             if (itypj.eq.ntyp1) cycle
1081             xj=c(1,nres+j)-xi
1082             yj=c(2,nres+j)-yi
1083             zj=c(3,nres+j)-zi
1084 C Change 12/1/95 to calculate four-body interactions
1085             rij=xj*xj+yj*yj+zj*zj
1086             rrij=1.0D0/rij
1087 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1088             eps0ij=eps(itypi,itypj)
1089             fac=rrij**expon2
1090             e1=fac*fac*aa(itypi,itypj)
1091             e2=fac*bb(itypi,itypj)
1092             evdwij=e1+e2
1093 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1096 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1097 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1098 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1099             evdw=evdw+evdwij
1100 C
1101 C Calculate the components of the gradient in DC and X
1102 C
1103             fac=-rrij*(e1+evdwij)
1104             gg(1)=xj*fac
1105             gg(2)=yj*fac
1106             gg(3)=zj*fac
1107             do k=1,3
1108               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1109               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1110               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1111               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1112             enddo
1113 cgrad            do k=i,j-1
1114 cgrad              do l=1,3
1115 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1116 cgrad              enddo
1117 cgrad            enddo
1118 C
1119 C 12/1/95, revised on 5/20/97
1120 C
1121 C Calculate the contact function. The ith column of the array JCONT will
1122 C contain the numbers of atoms that make contacts with the atom I (of numbers
1123 C greater than I). The arrays FACONT and GACONT will contain the values of
1124 C the contact function and its derivative.
1125 C
1126 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1127 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1128 C Uncomment next line, if the correlation interactions are contact function only
1129             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1130               rij=dsqrt(rij)
1131               sigij=sigma(itypi,itypj)
1132               r0ij=rs0(itypi,itypj)
1133 C
1134 C Check whether the SC's are not too far to make a contact.
1135 C
1136               rcut=1.5d0*r0ij
1137               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1138 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1139 C
1140               if (fcont.gt.0.0D0) then
1141 C If the SC-SC distance if close to sigma, apply spline.
1142 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1143 cAdam &             fcont1,fprimcont1)
1144 cAdam           fcont1=1.0d0-fcont1
1145 cAdam           if (fcont1.gt.0.0d0) then
1146 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1147 cAdam             fcont=fcont*fcont1
1148 cAdam           endif
1149 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1150 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1151 cga             do k=1,3
1152 cga               gg(k)=gg(k)*eps0ij
1153 cga             enddo
1154 cga             eps0ij=-evdwij*eps0ij
1155 C Uncomment for AL's type of SC correlation interactions.
1156 cadam           eps0ij=-evdwij
1157                 num_conti=num_conti+1
1158                 jcont(num_conti,i)=j
1159                 facont(num_conti,i)=fcont*eps0ij
1160                 fprimcont=eps0ij*fprimcont/rij
1161                 fcont=expon*fcont
1162 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1163 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1164 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1165 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1166                 gacont(1,num_conti,i)=-fprimcont*xj
1167                 gacont(2,num_conti,i)=-fprimcont*yj
1168                 gacont(3,num_conti,i)=-fprimcont*zj
1169 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1170 cd              write (iout,'(2i3,3f10.5)')
1171 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1172               endif
1173             endif
1174           enddo      ! j
1175         enddo        ! iint
1176 C Change 12/1/95
1177         num_cont(i)=num_conti
1178       enddo          ! i
1179       do i=1,nct
1180         do j=1,3
1181           gvdwc(j,i)=expon*gvdwc(j,i)
1182           gvdwx(j,i)=expon*gvdwx(j,i)
1183         enddo
1184       enddo
1185 C******************************************************************************
1186 C
1187 C                              N O T E !!!
1188 C
1189 C To save time, the factor of EXPON has been extracted from ALL components
1190 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1191 C use!
1192 C
1193 C******************************************************************************
1194       return
1195       end
1196 C-----------------------------------------------------------------------------
1197       subroutine eljk(evdw)
1198 C
1199 C This subroutine calculates the interaction energy of nonbonded side chains
1200 C assuming the LJK potential of interaction.
1201 C
1202       implicit real*8 (a-h,o-z)
1203       include 'DIMENSIONS'
1204       include 'COMMON.GEO'
1205       include 'COMMON.VAR'
1206       include 'COMMON.LOCAL'
1207       include 'COMMON.CHAIN'
1208       include 'COMMON.DERIV'
1209       include 'COMMON.INTERACT'
1210       include 'COMMON.IOUNITS'
1211       include 'COMMON.NAMES'
1212       dimension gg(3)
1213       logical scheck
1214 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1215       evdw=0.0D0
1216       do i=iatsc_s,iatsc_e
1217         itypi=iabs(itype(i))
1218         if (itypi.eq.ntyp1) cycle
1219         itypi1=iabs(itype(i+1))
1220         xi=c(1,nres+i)
1221         yi=c(2,nres+i)
1222         zi=c(3,nres+i)
1223 C
1224 C Calculate SC interaction energy.
1225 C
1226         do iint=1,nint_gr(i)
1227           do j=istart(i,iint),iend(i,iint)
1228             itypj=iabs(itype(j))
1229             if (itypj.eq.ntyp1) cycle
1230             xj=c(1,nres+j)-xi
1231             yj=c(2,nres+j)-yi
1232             zj=c(3,nres+j)-zi
1233             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1234             fac_augm=rrij**expon
1235             e_augm=augm(itypi,itypj)*fac_augm
1236             r_inv_ij=dsqrt(rrij)
1237             rij=1.0D0/r_inv_ij
1238             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1239             fac=r_shift_inv**expon
1240             e1=fac*fac*aa(itypi,itypj)
1241             e2=fac*bb(itypi,itypj)
1242             evdwij=e_augm+e1+e2
1243 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1244 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1245 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1246 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1247 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1248 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1249 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1250             evdw=evdw+evdwij
1251 C
1252 C Calculate the components of the gradient in DC and X
1253 C
1254             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1255             gg(1)=xj*fac
1256             gg(2)=yj*fac
1257             gg(3)=zj*fac
1258             do k=1,3
1259               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1260               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1261               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1262               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1263             enddo
1264 cgrad            do k=i,j-1
1265 cgrad              do l=1,3
1266 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1267 cgrad              enddo
1268 cgrad            enddo
1269           enddo      ! j
1270         enddo        ! iint
1271       enddo          ! i
1272       do i=1,nct
1273         do j=1,3
1274           gvdwc(j,i)=expon*gvdwc(j,i)
1275           gvdwx(j,i)=expon*gvdwx(j,i)
1276         enddo
1277       enddo
1278       return
1279       end
1280 C-----------------------------------------------------------------------------
1281       subroutine ebp(evdw)
1282 C
1283 C This subroutine calculates the interaction energy of nonbonded side chains
1284 C assuming the Berne-Pechukas potential of interaction.
1285 C
1286       implicit real*8 (a-h,o-z)
1287       include 'DIMENSIONS'
1288       include 'COMMON.GEO'
1289       include 'COMMON.VAR'
1290       include 'COMMON.LOCAL'
1291       include 'COMMON.CHAIN'
1292       include 'COMMON.DERIV'
1293       include 'COMMON.NAMES'
1294       include 'COMMON.INTERACT'
1295       include 'COMMON.IOUNITS'
1296       include 'COMMON.CALC'
1297       common /srutu/ icall
1298 c     double precision rrsave(maxdim)
1299       logical lprn
1300       evdw=0.0D0
1301 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1302       evdw=0.0D0
1303 c     if (icall.eq.0) then
1304 c       lprn=.true.
1305 c     else
1306         lprn=.false.
1307 c     endif
1308       ind=0
1309       do i=iatsc_s,iatsc_e
1310         itypi=iabs(itype(i))
1311         if (itypi.eq.ntyp1) cycle
1312         itypi1=iabs(itype(i+1))
1313         xi=c(1,nres+i)
1314         yi=c(2,nres+i)
1315         zi=c(3,nres+i)
1316         dxi=dc_norm(1,nres+i)
1317         dyi=dc_norm(2,nres+i)
1318         dzi=dc_norm(3,nres+i)
1319 c        dsci_inv=dsc_inv(itypi)
1320         dsci_inv=vbld_inv(i+nres)
1321 C
1322 C Calculate SC interaction energy.
1323 C
1324         do iint=1,nint_gr(i)
1325           do j=istart(i,iint),iend(i,iint)
1326             ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 c            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331             chi1=chi(itypi,itypj)
1332             chi2=chi(itypj,itypi)
1333             chi12=chi1*chi2
1334             chip1=chip(itypi)
1335             chip2=chip(itypj)
1336             chip12=chip1*chip2
1337             alf1=alp(itypi)
1338             alf2=alp(itypj)
1339             alf12=0.5D0*(alf1+alf2)
1340 C For diagnostics only!!!
1341 c           chi1=0.0D0
1342 c           chi2=0.0D0
1343 c           chi12=0.0D0
1344 c           chip1=0.0D0
1345 c           chip2=0.0D0
1346 c           chip12=0.0D0
1347 c           alf1=0.0D0
1348 c           alf2=0.0D0
1349 c           alf12=0.0D0
1350             xj=c(1,nres+j)-xi
1351             yj=c(2,nres+j)-yi
1352             zj=c(3,nres+j)-zi
1353             dxj=dc_norm(1,nres+j)
1354             dyj=dc_norm(2,nres+j)
1355             dzj=dc_norm(3,nres+j)
1356             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1357 cd          if (icall.eq.0) then
1358 cd            rrsave(ind)=rrij
1359 cd          else
1360 cd            rrij=rrsave(ind)
1361 cd          endif
1362             rij=dsqrt(rrij)
1363 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1364             call sc_angular
1365 C Calculate whole angle-dependent part of epsilon and contributions
1366 C to its derivatives
1367             fac=(rrij*sigsq)**expon2
1368             e1=fac*fac*aa(itypi,itypj)
1369             e2=fac*bb(itypi,itypj)
1370             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1371             eps2der=evdwij*eps3rt
1372             eps3der=evdwij*eps2rt
1373             evdwij=evdwij*eps2rt*eps3rt
1374             evdw=evdw+evdwij
1375             if (lprn) then
1376             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1377             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1378 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1379 cd     &        restyp(itypi),i,restyp(itypj),j,
1380 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1381 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1382 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1383 cd     &        evdwij
1384             endif
1385 C Calculate gradient components.
1386             e1=e1*eps1*eps2rt**2*eps3rt**2
1387             fac=-expon*(e1+evdwij)
1388             sigder=fac/sigsq
1389             fac=rrij*fac
1390 C Calculate radial part of the gradient
1391             gg(1)=xj*fac
1392             gg(2)=yj*fac
1393             gg(3)=zj*fac
1394 C Calculate the angular part of the gradient and sum add the contributions
1395 C to the appropriate components of the Cartesian gradient.
1396             call sc_grad
1397           enddo      ! j
1398         enddo        ! iint
1399       enddo          ! i
1400 c     stop
1401       return
1402       end
1403 C-----------------------------------------------------------------------------
1404       subroutine egb(evdw)
1405 C
1406 C This subroutine calculates the interaction energy of nonbonded side chains
1407 C assuming the Gay-Berne potential of interaction.
1408 C
1409       implicit real*8 (a-h,o-z)
1410       include 'DIMENSIONS'
1411       include 'COMMON.GEO'
1412       include 'COMMON.VAR'
1413       include 'COMMON.LOCAL'
1414       include 'COMMON.CHAIN'
1415       include 'COMMON.DERIV'
1416       include 'COMMON.NAMES'
1417       include 'COMMON.INTERACT'
1418       include 'COMMON.IOUNITS'
1419       include 'COMMON.CALC'
1420       include 'COMMON.CONTROL'
1421       include 'COMMON.SBRIDGE'
1422       logical lprn
1423       evdw=0.0D0
1424 ccccc      energy_dec=.false.
1425 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427       lprn=.false.
1428 c     if (icall.eq.0) lprn=.false.
1429       ind=0
1430       do i=iatsc_s,iatsc_e
1431         itypi=iabs(itype(i))
1432         if (itypi.eq.ntyp1) cycle
1433         itypi1=iabs(itype(i+1))
1434         xi=c(1,nres+i)
1435         yi=c(2,nres+i)
1436         zi=c(3,nres+i)
1437         dxi=dc_norm(1,nres+i)
1438         dyi=dc_norm(2,nres+i)
1439         dzi=dc_norm(3,nres+i)
1440 c        dsci_inv=dsc_inv(itypi)
1441         dsci_inv=vbld_inv(i+nres)
1442 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1443 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1450               call dyn_ssbond_ene(i,j,evdwij)
1451               evdw=evdw+evdwij
1452               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1453      &                        'evdw',i,j,evdwij,' ss'
1454             ELSE
1455             ind=ind+1
1456             itypj=iabs(itype(j))
1457             if (itypj.eq.ntyp1) cycle
1458 c            dscj_inv=dsc_inv(itypj)
1459             dscj_inv=vbld_inv(j+nres)
1460 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1461 c     &       1.0d0/vbld(j+nres)
1462 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1463             sig0ij=sigma(itypi,itypj)
1464             chi1=chi(itypi,itypj)
1465             chi2=chi(itypj,itypi)
1466             chi12=chi1*chi2
1467             chip1=chip(itypi)
1468             chip2=chip(itypj)
1469             chip12=chip1*chip2
1470             alf1=alp(itypi)
1471             alf2=alp(itypj)
1472             alf12=0.5D0*(alf1+alf2)
1473 C For diagnostics only!!!
1474 c           chi1=0.0D0
1475 c           chi2=0.0D0
1476 c           chi12=0.0D0
1477 c           chip1=0.0D0
1478 c           chip2=0.0D0
1479 c           chip12=0.0D0
1480 c           alf1=0.0D0
1481 c           alf2=0.0D0
1482 c           alf12=0.0D0
1483             xj=c(1,nres+j)-xi
1484             yj=c(2,nres+j)-yi
1485             zj=c(3,nres+j)-zi
1486             dxj=dc_norm(1,nres+j)
1487             dyj=dc_norm(2,nres+j)
1488             dzj=dc_norm(3,nres+j)
1489 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1490 c            write (iout,*) "j",j," dc_norm",
1491 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1492             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1493             rij=dsqrt(rrij)
1494 C Calculate angle-dependent terms of energy and contributions to their
1495 C derivatives.
1496             call sc_angular
1497             sigsq=1.0D0/sigsq
1498             sig=sig0ij*dsqrt(sigsq)
1499             rij_shift=1.0D0/rij-sig+sig0ij
1500 c for diagnostics; uncomment
1501 c            rij_shift=1.2*sig0ij
1502 C I hate to put IF's in the loops, but here don't have another choice!!!!
1503             if (rij_shift.le.0.0D0) then
1504               evdw=1.0D20
1505 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1506 cd     &        restyp(itypi),i,restyp(itypj),j,
1507 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1508               return
1509             endif
1510             sigder=-sig*sigsq
1511 c---------------------------------------------------------------
1512             rij_shift=1.0D0/rij_shift
1513             fac=rij_shift**expon
1514             e1=fac*fac*aa(itypi,itypj)
1515             e2=fac*bb(itypi,itypj)
1516             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1517             eps2der=evdwij*eps3rt
1518             eps3der=evdwij*eps2rt
1519 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1520 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1521             evdwij=evdwij*eps2rt*eps3rt
1522             evdw=evdw+evdwij
1523             if (lprn) then
1524             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1525             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1526             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1527      &        restyp(itypi),i,restyp(itypj),j,
1528      &        epsi,sigm,chi1,chi2,chip1,chip2,
1529      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1530      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1531      &        evdwij
1532             endif
1533
1534             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1535      &                        'evdw',i,j,evdwij
1536
1537 C Calculate gradient components.
1538             e1=e1*eps1*eps2rt**2*eps3rt**2
1539             fac=-expon*(e1+evdwij)*rij_shift
1540             sigder=fac*sigder
1541             fac=rij*fac
1542 c            fac=0.0d0
1543 C Calculate the radial part of the gradient
1544             gg(1)=xj*fac
1545             gg(2)=yj*fac
1546             gg(3)=zj*fac
1547 C Calculate angular part of the gradient.
1548             call sc_grad
1549             ENDIF    ! dyn_ss
1550           enddo      ! j
1551         enddo        ! iint
1552       enddo          ! i
1553 c      write (iout,*) "Number of loop steps in EGB:",ind
1554 cccc      energy_dec=.false.
1555       return
1556       end
1557 C-----------------------------------------------------------------------------
1558       subroutine egbv(evdw)
1559 C
1560 C This subroutine calculates the interaction energy of nonbonded side chains
1561 C assuming the Gay-Berne-Vorobjev potential of interaction.
1562 C
1563       implicit real*8 (a-h,o-z)
1564       include 'DIMENSIONS'
1565       include 'COMMON.GEO'
1566       include 'COMMON.VAR'
1567       include 'COMMON.LOCAL'
1568       include 'COMMON.CHAIN'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.NAMES'
1571       include 'COMMON.INTERACT'
1572       include 'COMMON.IOUNITS'
1573       include 'COMMON.CALC'
1574       common /srutu/ icall
1575       logical lprn
1576       evdw=0.0D0
1577 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1578       evdw=0.0D0
1579       lprn=.false.
1580 c     if (icall.eq.0) lprn=.true.
1581       ind=0
1582       do i=iatsc_s,iatsc_e
1583         itypi=iabs(itype(i))
1584         if (itypi.eq.ntyp1) cycle
1585         itypi1=iabs(itype(i+1))
1586         xi=c(1,nres+i)
1587         yi=c(2,nres+i)
1588         zi=c(3,nres+i)
1589         dxi=dc_norm(1,nres+i)
1590         dyi=dc_norm(2,nres+i)
1591         dzi=dc_norm(3,nres+i)
1592 c        dsci_inv=dsc_inv(itypi)
1593         dsci_inv=vbld_inv(i+nres)
1594 C
1595 C Calculate SC interaction energy.
1596 C
1597         do iint=1,nint_gr(i)
1598           do j=istart(i,iint),iend(i,iint)
1599             ind=ind+1
1600             itypj=iabs(itype(j))
1601             if (itypj.eq.ntyp1) cycle
1602 c            dscj_inv=dsc_inv(itypj)
1603             dscj_inv=vbld_inv(j+nres)
1604             sig0ij=sigma(itypi,itypj)
1605             r0ij=r0(itypi,itypj)
1606             chi1=chi(itypi,itypj)
1607             chi2=chi(itypj,itypi)
1608             chi12=chi1*chi2
1609             chip1=chip(itypi)
1610             chip2=chip(itypj)
1611             chip12=chip1*chip2
1612             alf1=alp(itypi)
1613             alf2=alp(itypj)
1614             alf12=0.5D0*(alf1+alf2)
1615 C For diagnostics only!!!
1616 c           chi1=0.0D0
1617 c           chi2=0.0D0
1618 c           chi12=0.0D0
1619 c           chip1=0.0D0
1620 c           chip2=0.0D0
1621 c           chip12=0.0D0
1622 c           alf1=0.0D0
1623 c           alf2=0.0D0
1624 c           alf12=0.0D0
1625             xj=c(1,nres+j)-xi
1626             yj=c(2,nres+j)-yi
1627             zj=c(3,nres+j)-zi
1628             dxj=dc_norm(1,nres+j)
1629             dyj=dc_norm(2,nres+j)
1630             dzj=dc_norm(3,nres+j)
1631             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1632             rij=dsqrt(rrij)
1633 C Calculate angle-dependent terms of energy and contributions to their
1634 C derivatives.
1635             call sc_angular
1636             sigsq=1.0D0/sigsq
1637             sig=sig0ij*dsqrt(sigsq)
1638             rij_shift=1.0D0/rij-sig+r0ij
1639 C I hate to put IF's in the loops, but here don't have another choice!!!!
1640             if (rij_shift.le.0.0D0) then
1641               evdw=1.0D20
1642               return
1643             endif
1644             sigder=-sig*sigsq
1645 c---------------------------------------------------------------
1646             rij_shift=1.0D0/rij_shift
1647             fac=rij_shift**expon
1648             e1=fac*fac*aa(itypi,itypj)
1649             e2=fac*bb(itypi,itypj)
1650             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1651             eps2der=evdwij*eps3rt
1652             eps3der=evdwij*eps2rt
1653             fac_augm=rrij**expon
1654             e_augm=augm(itypi,itypj)*fac_augm
1655             evdwij=evdwij*eps2rt*eps3rt
1656             evdw=evdw+evdwij+e_augm
1657             if (lprn) then
1658             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1659             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1660             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1661      &        restyp(itypi),i,restyp(itypj),j,
1662      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1663      &        chi1,chi2,chip1,chip2,
1664      &        eps1,eps2rt**2,eps3rt**2,
1665      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1666      &        evdwij+e_augm
1667             endif
1668 C Calculate gradient components.
1669             e1=e1*eps1*eps2rt**2*eps3rt**2
1670             fac=-expon*(e1+evdwij)*rij_shift
1671             sigder=fac*sigder
1672             fac=rij*fac-2*expon*rrij*e_augm
1673 C Calculate the radial part of the gradient
1674             gg(1)=xj*fac
1675             gg(2)=yj*fac
1676             gg(3)=zj*fac
1677 C Calculate angular part of the gradient.
1678             call sc_grad
1679           enddo      ! j
1680         enddo        ! iint
1681       enddo          ! i
1682       end
1683 C-----------------------------------------------------------------------------
1684       subroutine sc_angular
1685 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1686 C om12. Called by ebp, egb, and egbv.
1687       implicit none
1688       include 'COMMON.CALC'
1689       include 'COMMON.IOUNITS'
1690       erij(1)=xj*rij
1691       erij(2)=yj*rij
1692       erij(3)=zj*rij
1693       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1694       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1695       om12=dxi*dxj+dyi*dyj+dzi*dzj
1696       chiom12=chi12*om12
1697 C Calculate eps1(om12) and its derivative in om12
1698       faceps1=1.0D0-om12*chiom12
1699       faceps1_inv=1.0D0/faceps1
1700       eps1=dsqrt(faceps1_inv)
1701 C Following variable is eps1*deps1/dom12
1702       eps1_om12=faceps1_inv*chiom12
1703 c diagnostics only
1704 c      faceps1_inv=om12
1705 c      eps1=om12
1706 c      eps1_om12=1.0d0
1707 c      write (iout,*) "om12",om12," eps1",eps1
1708 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1709 C and om12.
1710       om1om2=om1*om2
1711       chiom1=chi1*om1
1712       chiom2=chi2*om2
1713       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1714       sigsq=1.0D0-facsig*faceps1_inv
1715       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1716       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1717       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1718 c diagnostics only
1719 c      sigsq=1.0d0
1720 c      sigsq_om1=0.0d0
1721 c      sigsq_om2=0.0d0
1722 c      sigsq_om12=0.0d0
1723 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1724 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1725 c     &    " eps1",eps1
1726 C Calculate eps2 and its derivatives in om1, om2, and om12.
1727       chipom1=chip1*om1
1728       chipom2=chip2*om2
1729       chipom12=chip12*om12
1730       facp=1.0D0-om12*chipom12
1731       facp_inv=1.0D0/facp
1732       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1733 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1734 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1735 C Following variable is the square root of eps2
1736       eps2rt=1.0D0-facp1*facp_inv
1737 C Following three variables are the derivatives of the square root of eps
1738 C in om1, om2, and om12.
1739       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1740       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1741       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1742 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1743       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1744 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1745 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1746 c     &  " eps2rt_om12",eps2rt_om12
1747 C Calculate whole angle-dependent part of epsilon and contributions
1748 C to its derivatives
1749       return
1750       end
1751 C----------------------------------------------------------------------------
1752       subroutine sc_grad
1753       implicit real*8 (a-h,o-z)
1754       include 'DIMENSIONS'
1755       include 'COMMON.CHAIN'
1756       include 'COMMON.DERIV'
1757       include 'COMMON.CALC'
1758       include 'COMMON.IOUNITS'
1759       double precision dcosom1(3),dcosom2(3)
1760       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1761       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1762       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1763      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1764 c diagnostics only
1765 c      eom1=0.0d0
1766 c      eom2=0.0d0
1767 c      eom12=evdwij*eps1_om12
1768 c end diagnostics
1769 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1770 c     &  " sigder",sigder
1771 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1772 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1773       do k=1,3
1774         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1775         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1776       enddo
1777       do k=1,3
1778         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1779       enddo
1780 c      write (iout,*) "gg",(gg(k),k=1,3)
1781       do k=1,3
1782         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1783      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1784      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1785         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1786      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1787      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1788 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1789 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1790 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1791 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1792       enddo
1793 C
1794 C Calculate the components of the gradient in DC and X
1795 C
1796 cgrad      do k=i,j-1
1797 cgrad        do l=1,3
1798 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1799 cgrad        enddo
1800 cgrad      enddo
1801       do l=1,3
1802         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1803         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1804       enddo
1805       return
1806       end
1807 C-----------------------------------------------------------------------
1808       subroutine e_softsphere(evdw)
1809 C
1810 C This subroutine calculates the interaction energy of nonbonded side chains
1811 C assuming the LJ potential of interaction.
1812 C
1813       implicit real*8 (a-h,o-z)
1814       include 'DIMENSIONS'
1815       parameter (accur=1.0d-10)
1816       include 'COMMON.GEO'
1817       include 'COMMON.VAR'
1818       include 'COMMON.LOCAL'
1819       include 'COMMON.CHAIN'
1820       include 'COMMON.DERIV'
1821       include 'COMMON.INTERACT'
1822       include 'COMMON.TORSION'
1823       include 'COMMON.SBRIDGE'
1824       include 'COMMON.NAMES'
1825       include 'COMMON.IOUNITS'
1826       include 'COMMON.CONTACTS'
1827       dimension gg(3)
1828 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1829       evdw=0.0D0
1830       do i=iatsc_s,iatsc_e
1831         itypi=iabs(itype(i))
1832         if (itypi.eq.ntyp1) cycle
1833         itypi1=iabs(itype(i+1))
1834         xi=c(1,nres+i)
1835         yi=c(2,nres+i)
1836         zi=c(3,nres+i)
1837 C
1838 C Calculate SC interaction energy.
1839 C
1840         do iint=1,nint_gr(i)
1841 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1842 cd   &                  'iend=',iend(i,iint)
1843           do j=istart(i,iint),iend(i,iint)
1844             itypj=iabs(itype(j))
1845             if (itypj.eq.ntyp1) cycle
1846             xj=c(1,nres+j)-xi
1847             yj=c(2,nres+j)-yi
1848             zj=c(3,nres+j)-zi
1849             rij=xj*xj+yj*yj+zj*zj
1850 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1851             r0ij=r0(itypi,itypj)
1852             r0ijsq=r0ij*r0ij
1853 c            print *,i,j,r0ij,dsqrt(rij)
1854             if (rij.lt.r0ijsq) then
1855               evdwij=0.25d0*(rij-r0ijsq)**2
1856               fac=rij-r0ijsq
1857             else
1858               evdwij=0.0d0
1859               fac=0.0d0
1860             endif
1861             evdw=evdw+evdwij
1862 C
1863 C Calculate the components of the gradient in DC and X
1864 C
1865             gg(1)=xj*fac
1866             gg(2)=yj*fac
1867             gg(3)=zj*fac
1868             do k=1,3
1869               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1870               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1871               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1872               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1873             enddo
1874 cgrad            do k=i,j-1
1875 cgrad              do l=1,3
1876 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1877 cgrad              enddo
1878 cgrad            enddo
1879           enddo ! j
1880         enddo ! iint
1881       enddo ! i
1882       return
1883       end
1884 C--------------------------------------------------------------------------
1885       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1886      &              eello_turn4)
1887 C
1888 C Soft-sphere potential of p-p interaction
1889 C
1890       implicit real*8 (a-h,o-z)
1891       include 'DIMENSIONS'
1892       include 'COMMON.CONTROL'
1893       include 'COMMON.IOUNITS'
1894       include 'COMMON.GEO'
1895       include 'COMMON.VAR'
1896       include 'COMMON.LOCAL'
1897       include 'COMMON.CHAIN'
1898       include 'COMMON.DERIV'
1899       include 'COMMON.INTERACT'
1900       include 'COMMON.CONTACTS'
1901       include 'COMMON.TORSION'
1902       include 'COMMON.VECTORS'
1903       include 'COMMON.FFIELD'
1904       dimension ggg(3)
1905 cd      write(iout,*) 'In EELEC_soft_sphere'
1906       ees=0.0D0
1907       evdw1=0.0D0
1908       eel_loc=0.0d0
1909       eello_turn3=0.0d0
1910       eello_turn4=0.0d0
1911       ind=0
1912       do i=iatel_s,iatel_e
1913         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1914         dxi=dc(1,i)
1915         dyi=dc(2,i)
1916         dzi=dc(3,i)
1917         xmedi=c(1,i)+0.5d0*dxi
1918         ymedi=c(2,i)+0.5d0*dyi
1919         zmedi=c(3,i)+0.5d0*dzi
1920         num_conti=0
1921 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1922         do j=ielstart(i),ielend(i)
1923           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1924           ind=ind+1
1925           iteli=itel(i)
1926           itelj=itel(j)
1927           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1928           r0ij=rpp(iteli,itelj)
1929           r0ijsq=r0ij*r0ij
1930           dxj=dc(1,j)
1931           dyj=dc(2,j)
1932           dzj=dc(3,j)
1933           xj=c(1,j)+0.5D0*dxj-xmedi
1934           yj=c(2,j)+0.5D0*dyj-ymedi
1935           zj=c(3,j)+0.5D0*dzj-zmedi
1936           rij=xj*xj+yj*yj+zj*zj
1937           if (rij.lt.r0ijsq) then
1938             evdw1ij=0.25d0*(rij-r0ijsq)**2
1939             fac=rij-r0ijsq
1940           else
1941             evdw1ij=0.0d0
1942             fac=0.0d0
1943           endif
1944           evdw1=evdw1+evdw1ij
1945 C
1946 C Calculate contributions to the Cartesian gradient.
1947 C
1948           ggg(1)=fac*xj
1949           ggg(2)=fac*yj
1950           ggg(3)=fac*zj
1951           do k=1,3
1952             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1953             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1954           enddo
1955 *
1956 * Loop over residues i+1 thru j-1.
1957 *
1958 cgrad          do k=i+1,j-1
1959 cgrad            do l=1,3
1960 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1961 cgrad            enddo
1962 cgrad          enddo
1963         enddo ! j
1964       enddo   ! i
1965 cgrad      do i=nnt,nct-1
1966 cgrad        do k=1,3
1967 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1968 cgrad        enddo
1969 cgrad        do j=i+1,nct-1
1970 cgrad          do k=1,3
1971 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1972 cgrad          enddo
1973 cgrad        enddo
1974 cgrad      enddo
1975       return
1976       end
1977 c------------------------------------------------------------------------------
1978       subroutine vec_and_deriv
1979       implicit real*8 (a-h,o-z)
1980       include 'DIMENSIONS'
1981 #ifdef MPI
1982       include 'mpif.h'
1983 #endif
1984       include 'COMMON.IOUNITS'
1985       include 'COMMON.GEO'
1986       include 'COMMON.VAR'
1987       include 'COMMON.LOCAL'
1988       include 'COMMON.CHAIN'
1989       include 'COMMON.VECTORS'
1990       include 'COMMON.SETUP'
1991       include 'COMMON.TIME1'
1992       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1993 C Compute the local reference systems. For reference system (i), the
1994 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1995 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1996 #ifdef PARVEC
1997       do i=ivec_start,ivec_end
1998 #else
1999       do i=1,nres-1
2000 #endif
2001           if (i.eq.nres-1) then
2002 C Case of the last full residue
2003 C Compute the Z-axis
2004             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2005             costh=dcos(pi-theta(nres))
2006             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2007             do k=1,3
2008               uz(k,i)=fac*uz(k,i)
2009             enddo
2010 C Compute the derivatives of uz
2011             uzder(1,1,1)= 0.0d0
2012             uzder(2,1,1)=-dc_norm(3,i-1)
2013             uzder(3,1,1)= dc_norm(2,i-1)
2014             uzder(1,2,1)= dc_norm(3,i-1)
2015             uzder(2,2,1)= 0.0d0
2016             uzder(3,2,1)=-dc_norm(1,i-1)
2017             uzder(1,3,1)=-dc_norm(2,i-1)
2018             uzder(2,3,1)= dc_norm(1,i-1)
2019             uzder(3,3,1)= 0.0d0
2020             uzder(1,1,2)= 0.0d0
2021             uzder(2,1,2)= dc_norm(3,i)
2022             uzder(3,1,2)=-dc_norm(2,i)
2023             uzder(1,2,2)=-dc_norm(3,i)
2024             uzder(2,2,2)= 0.0d0
2025             uzder(3,2,2)= dc_norm(1,i)
2026             uzder(1,3,2)= dc_norm(2,i)
2027             uzder(2,3,2)=-dc_norm(1,i)
2028             uzder(3,3,2)= 0.0d0
2029 C Compute the Y-axis
2030             facy=fac
2031             do k=1,3
2032               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2033             enddo
2034 C Compute the derivatives of uy
2035             do j=1,3
2036               do k=1,3
2037                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2038      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2039                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2040               enddo
2041               uyder(j,j,1)=uyder(j,j,1)-costh
2042               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2043             enddo
2044             do j=1,2
2045               do k=1,3
2046                 do l=1,3
2047                   uygrad(l,k,j,i)=uyder(l,k,j)
2048                   uzgrad(l,k,j,i)=uzder(l,k,j)
2049                 enddo
2050               enddo
2051             enddo
2052             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2053             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2054             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2055             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2056           else
2057 C Other residues
2058 C Compute the Z-axis
2059             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2060             costh=dcos(pi-theta(i+2))
2061             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2062             do k=1,3
2063               uz(k,i)=fac*uz(k,i)
2064             enddo
2065 C Compute the derivatives of uz
2066             uzder(1,1,1)= 0.0d0
2067             uzder(2,1,1)=-dc_norm(3,i+1)
2068             uzder(3,1,1)= dc_norm(2,i+1)
2069             uzder(1,2,1)= dc_norm(3,i+1)
2070             uzder(2,2,1)= 0.0d0
2071             uzder(3,2,1)=-dc_norm(1,i+1)
2072             uzder(1,3,1)=-dc_norm(2,i+1)
2073             uzder(2,3,1)= dc_norm(1,i+1)
2074             uzder(3,3,1)= 0.0d0
2075             uzder(1,1,2)= 0.0d0
2076             uzder(2,1,2)= dc_norm(3,i)
2077             uzder(3,1,2)=-dc_norm(2,i)
2078             uzder(1,2,2)=-dc_norm(3,i)
2079             uzder(2,2,2)= 0.0d0
2080             uzder(3,2,2)= dc_norm(1,i)
2081             uzder(1,3,2)= dc_norm(2,i)
2082             uzder(2,3,2)=-dc_norm(1,i)
2083             uzder(3,3,2)= 0.0d0
2084 C Compute the Y-axis
2085             facy=fac
2086             do k=1,3
2087               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2088             enddo
2089 C Compute the derivatives of uy
2090             do j=1,3
2091               do k=1,3
2092                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2093      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2094                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2095               enddo
2096               uyder(j,j,1)=uyder(j,j,1)-costh
2097               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2098             enddo
2099             do j=1,2
2100               do k=1,3
2101                 do l=1,3
2102                   uygrad(l,k,j,i)=uyder(l,k,j)
2103                   uzgrad(l,k,j,i)=uzder(l,k,j)
2104                 enddo
2105               enddo
2106             enddo
2107             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2108             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2109             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2110             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2111           endif
2112       enddo
2113       do i=1,nres-1
2114         vbld_inv_temp(1)=vbld_inv(i+1)
2115         if (i.lt.nres-1) then
2116           vbld_inv_temp(2)=vbld_inv(i+2)
2117           else
2118           vbld_inv_temp(2)=vbld_inv(i)
2119           endif
2120         do j=1,2
2121           do k=1,3
2122             do l=1,3
2123               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2124               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2125             enddo
2126           enddo
2127         enddo
2128       enddo
2129 #if defined(PARVEC) && defined(MPI)
2130       if (nfgtasks1.gt.1) then
2131         time00=MPI_Wtime()
2132 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2133 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2134 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2135         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2136      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2137      &   FG_COMM1,IERR)
2138         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2139      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2140      &   FG_COMM1,IERR)
2141         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2142      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2143      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2144         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2145      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2146      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2147         time_gather=time_gather+MPI_Wtime()-time00
2148       endif
2149 c      if (fg_rank.eq.0) then
2150 c        write (iout,*) "Arrays UY and UZ"
2151 c        do i=1,nres-1
2152 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2153 c     &     (uz(k,i),k=1,3)
2154 c        enddo
2155 c      endif
2156 #endif
2157       return
2158       end
2159 C-----------------------------------------------------------------------------
2160       subroutine check_vecgrad
2161       implicit real*8 (a-h,o-z)
2162       include 'DIMENSIONS'
2163       include 'COMMON.IOUNITS'
2164       include 'COMMON.GEO'
2165       include 'COMMON.VAR'
2166       include 'COMMON.LOCAL'
2167       include 'COMMON.CHAIN'
2168       include 'COMMON.VECTORS'
2169       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2170       dimension uyt(3,maxres),uzt(3,maxres)
2171       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2172       double precision delta /1.0d-7/
2173       call vec_and_deriv
2174 cd      do i=1,nres
2175 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2176 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2177 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2178 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2179 cd     &     (dc_norm(if90,i),if90=1,3)
2180 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2181 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2182 cd          write(iout,'(a)')
2183 cd      enddo
2184       do i=1,nres
2185         do j=1,2
2186           do k=1,3
2187             do l=1,3
2188               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2189               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2190             enddo
2191           enddo
2192         enddo
2193       enddo
2194       call vec_and_deriv
2195       do i=1,nres
2196         do j=1,3
2197           uyt(j,i)=uy(j,i)
2198           uzt(j,i)=uz(j,i)
2199         enddo
2200       enddo
2201       do i=1,nres
2202 cd        write (iout,*) 'i=',i
2203         do k=1,3
2204           erij(k)=dc_norm(k,i)
2205         enddo
2206         do j=1,3
2207           do k=1,3
2208             dc_norm(k,i)=erij(k)
2209           enddo
2210           dc_norm(j,i)=dc_norm(j,i)+delta
2211 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2212 c          do k=1,3
2213 c            dc_norm(k,i)=dc_norm(k,i)/fac
2214 c          enddo
2215 c          write (iout,*) (dc_norm(k,i),k=1,3)
2216 c          write (iout,*) (erij(k),k=1,3)
2217           call vec_and_deriv
2218           do k=1,3
2219             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2220             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2221             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2222             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2223           enddo
2224 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2225 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2226 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2227         enddo
2228         do k=1,3
2229           dc_norm(k,i)=erij(k)
2230         enddo
2231 cd        do k=1,3
2232 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2233 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2234 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2235 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2236 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2237 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2238 cd          write (iout,'(a)')
2239 cd        enddo
2240       enddo
2241       return
2242       end
2243 C--------------------------------------------------------------------------
2244       subroutine set_matrices
2245       implicit real*8 (a-h,o-z)
2246       include 'DIMENSIONS'
2247 #ifdef MPI
2248       include "mpif.h"
2249       include "COMMON.SETUP"
2250       integer IERR
2251       integer status(MPI_STATUS_SIZE)
2252 #endif
2253       include 'COMMON.IOUNITS'
2254       include 'COMMON.GEO'
2255       include 'COMMON.VAR'
2256       include 'COMMON.LOCAL'
2257       include 'COMMON.CHAIN'
2258       include 'COMMON.DERIV'
2259       include 'COMMON.INTERACT'
2260       include 'COMMON.CONTACTS'
2261       include 'COMMON.TORSION'
2262       include 'COMMON.VECTORS'
2263       include 'COMMON.FFIELD'
2264       double precision auxvec(2),auxmat(2,2)
2265 C
2266 C Compute the virtual-bond-torsional-angle dependent quantities needed
2267 C to calculate the el-loc multibody terms of various order.
2268 C
2269 #ifdef PARMAT
2270       do i=ivec_start+2,ivec_end+2
2271 #else
2272       do i=3,nres+1
2273 #endif
2274         if (i .lt. nres+1) then
2275           sin1=dsin(phi(i))
2276           cos1=dcos(phi(i))
2277           sintab(i-2)=sin1
2278           costab(i-2)=cos1
2279           obrot(1,i-2)=cos1
2280           obrot(2,i-2)=sin1
2281           sin2=dsin(2*phi(i))
2282           cos2=dcos(2*phi(i))
2283           sintab2(i-2)=sin2
2284           costab2(i-2)=cos2
2285           obrot2(1,i-2)=cos2
2286           obrot2(2,i-2)=sin2
2287           Ug(1,1,i-2)=-cos1
2288           Ug(1,2,i-2)=-sin1
2289           Ug(2,1,i-2)=-sin1
2290           Ug(2,2,i-2)= cos1
2291           Ug2(1,1,i-2)=-cos2
2292           Ug2(1,2,i-2)=-sin2
2293           Ug2(2,1,i-2)=-sin2
2294           Ug2(2,2,i-2)= cos2
2295         else
2296           costab(i-2)=1.0d0
2297           sintab(i-2)=0.0d0
2298           obrot(1,i-2)=1.0d0
2299           obrot(2,i-2)=0.0d0
2300           obrot2(1,i-2)=0.0d0
2301           obrot2(2,i-2)=0.0d0
2302           Ug(1,1,i-2)=1.0d0
2303           Ug(1,2,i-2)=0.0d0
2304           Ug(2,1,i-2)=0.0d0
2305           Ug(2,2,i-2)=1.0d0
2306           Ug2(1,1,i-2)=0.0d0
2307           Ug2(1,2,i-2)=0.0d0
2308           Ug2(2,1,i-2)=0.0d0
2309           Ug2(2,2,i-2)=0.0d0
2310         endif
2311         if (i .gt. 3 .and. i .lt. nres+1) then
2312           obrot_der(1,i-2)=-sin1
2313           obrot_der(2,i-2)= cos1
2314           Ugder(1,1,i-2)= sin1
2315           Ugder(1,2,i-2)=-cos1
2316           Ugder(2,1,i-2)=-cos1
2317           Ugder(2,2,i-2)=-sin1
2318           dwacos2=cos2+cos2
2319           dwasin2=sin2+sin2
2320           obrot2_der(1,i-2)=-dwasin2
2321           obrot2_der(2,i-2)= dwacos2
2322           Ug2der(1,1,i-2)= dwasin2
2323           Ug2der(1,2,i-2)=-dwacos2
2324           Ug2der(2,1,i-2)=-dwacos2
2325           Ug2der(2,2,i-2)=-dwasin2
2326         else
2327           obrot_der(1,i-2)=0.0d0
2328           obrot_der(2,i-2)=0.0d0
2329           Ugder(1,1,i-2)=0.0d0
2330           Ugder(1,2,i-2)=0.0d0
2331           Ugder(2,1,i-2)=0.0d0
2332           Ugder(2,2,i-2)=0.0d0
2333           obrot2_der(1,i-2)=0.0d0
2334           obrot2_der(2,i-2)=0.0d0
2335           Ug2der(1,1,i-2)=0.0d0
2336           Ug2der(1,2,i-2)=0.0d0
2337           Ug2der(2,1,i-2)=0.0d0
2338           Ug2der(2,2,i-2)=0.0d0
2339         endif
2340 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2341         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2342           iti = itortyp(itype(i-2))
2343         else
2344           iti=ntortyp+1
2345         endif
2346 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2347         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2348           iti1 = itortyp(itype(i-1))
2349         else
2350           iti1=ntortyp+1
2351         endif
2352 cd        write (iout,*) '*******i',i,' iti1',iti
2353 cd        write (iout,*) 'b1',b1(:,iti)
2354 cd        write (iout,*) 'b2',b2(:,iti)
2355 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2356 c        if (i .gt. iatel_s+2) then
2357         if (i .gt. nnt+2) then
2358           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2359           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2360           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2361      &    then
2362           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2363           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2364           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2365           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2366           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2367           endif
2368         else
2369           do k=1,2
2370             Ub2(k,i-2)=0.0d0
2371             Ctobr(k,i-2)=0.0d0
2372             Dtobr2(k,i-2)=0.0d0
2373             do l=1,2
2374               EUg(l,k,i-2)=0.0d0
2375               CUg(l,k,i-2)=0.0d0
2376               DUg(l,k,i-2)=0.0d0
2377               DtUg2(l,k,i-2)=0.0d0
2378             enddo
2379           enddo
2380         endif
2381         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2382         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2383         do k=1,2
2384           muder(k,i-2)=Ub2der(k,i-2)
2385         enddo
2386 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2387         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2388           if (itype(i-1).le.ntyp) then
2389             iti1 = itortyp(itype(i-1))
2390           else
2391             iti1=ntortyp+1
2392           endif
2393         else
2394           iti1=ntortyp+1
2395         endif
2396         do k=1,2
2397           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2398         enddo
2399 cd        write (iout,*) 'mu ',mu(:,i-2)
2400 cd        write (iout,*) 'mu1',mu1(:,i-2)
2401 cd        write (iout,*) 'mu2',mu2(:,i-2)
2402         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2403      &  then
2404         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2405         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2406         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2407         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2408         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2409 C Vectors and matrices dependent on a single virtual-bond dihedral.
2410         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2411         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2412         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2413         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2414         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2415         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2416         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2417         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2418         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2419         endif
2420       enddo
2421 C Matrices dependent on two consecutive virtual-bond dihedrals.
2422 C The order of matrices is from left to right.
2423       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2424      &then
2425 c      do i=max0(ivec_start,2),ivec_end
2426       do i=2,nres-1
2427         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2428         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2429         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2430         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2431         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2432         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2433         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2434         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2435       enddo
2436       endif
2437 #if defined(MPI) && defined(PARMAT)
2438 #ifdef DEBUG
2439 c      if (fg_rank.eq.0) then
2440         write (iout,*) "Arrays UG and UGDER before GATHER"
2441         do i=1,nres-1
2442           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2443      &     ((ug(l,k,i),l=1,2),k=1,2),
2444      &     ((ugder(l,k,i),l=1,2),k=1,2)
2445         enddo
2446         write (iout,*) "Arrays UG2 and UG2DER"
2447         do i=1,nres-1
2448           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2449      &     ((ug2(l,k,i),l=1,2),k=1,2),
2450      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2451         enddo
2452         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2453         do i=1,nres-1
2454           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2455      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2456      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2457         enddo
2458         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2459         do i=1,nres-1
2460           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2461      &     costab(i),sintab(i),costab2(i),sintab2(i)
2462         enddo
2463         write (iout,*) "Array MUDER"
2464         do i=1,nres-1
2465           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2466         enddo
2467 c      endif
2468 #endif
2469       if (nfgtasks.gt.1) then
2470         time00=MPI_Wtime()
2471 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2472 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2473 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2474 #ifdef MATGATHER
2475         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2476      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2477      &   FG_COMM1,IERR)
2478         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2479      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2480      &   FG_COMM1,IERR)
2481         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2482      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2483      &   FG_COMM1,IERR)
2484         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2485      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2486      &   FG_COMM1,IERR)
2487         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2488      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2489      &   FG_COMM1,IERR)
2490         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2491      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2492      &   FG_COMM1,IERR)
2493         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2494      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2495      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2496         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2497      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2498      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2499         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2500      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2501      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2502         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2503      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2504      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2505         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2506      &  then
2507         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2508      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2509      &   FG_COMM1,IERR)
2510         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2514      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2515      &   FG_COMM1,IERR)
2516        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2517      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2523      &   ivec_count(fg_rank1),
2524      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2525      &   FG_COMM1,IERR)
2526         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2527      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2528      &   FG_COMM1,IERR)
2529         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2530      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2531      &   FG_COMM1,IERR)
2532         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2533      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2534      &   FG_COMM1,IERR)
2535         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2536      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2537      &   FG_COMM1,IERR)
2538         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2539      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2540      &   FG_COMM1,IERR)
2541         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2542      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2543      &   FG_COMM1,IERR)
2544         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2545      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2548      &   ivec_count(fg_rank1),
2549      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2550      &   FG_COMM1,IERR)
2551         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2552      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2553      &   FG_COMM1,IERR)
2554        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2555      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2556      &   FG_COMM1,IERR)
2557         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2558      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2559      &   FG_COMM1,IERR)
2560        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2561      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2562      &   FG_COMM1,IERR)
2563         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2564      &   ivec_count(fg_rank1),
2565      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2568      &   ivec_count(fg_rank1),
2569      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2570      &   FG_COMM1,IERR)
2571         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2572      &   ivec_count(fg_rank1),
2573      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2574      &   MPI_MAT2,FG_COMM1,IERR)
2575         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2576      &   ivec_count(fg_rank1),
2577      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2578      &   MPI_MAT2,FG_COMM1,IERR)
2579         endif
2580 #else
2581 c Passes matrix info through the ring
2582       isend=fg_rank1
2583       irecv=fg_rank1-1
2584       if (irecv.lt.0) irecv=nfgtasks1-1
2585       iprev=irecv
2586       inext=fg_rank1+1
2587       if (inext.ge.nfgtasks1) inext=0
2588       do i=1,nfgtasks1-1
2589 c        write (iout,*) "isend",isend," irecv",irecv
2590 c        call flush(iout)
2591         lensend=lentyp(isend)
2592         lenrecv=lentyp(irecv)
2593 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2594 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2595 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2596 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2597 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2598 c        write (iout,*) "Gather ROTAT1"
2599 c        call flush(iout)
2600 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2601 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2602 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2603 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2604 c        write (iout,*) "Gather ROTAT2"
2605 c        call flush(iout)
2606         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2607      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2608      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2609      &   iprev,4400+irecv,FG_COMM,status,IERR)
2610 c        write (iout,*) "Gather ROTAT_OLD"
2611 c        call flush(iout)
2612         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2613      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2614      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2615      &   iprev,5500+irecv,FG_COMM,status,IERR)
2616 c        write (iout,*) "Gather PRECOMP11"
2617 c        call flush(iout)
2618         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2619      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2620      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2621      &   iprev,6600+irecv,FG_COMM,status,IERR)
2622 c        write (iout,*) "Gather PRECOMP12"
2623 c        call flush(iout)
2624         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2625      &  then
2626         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2627      &   MPI_ROTAT2(lensend),inext,7700+isend,
2628      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2629      &   iprev,7700+irecv,FG_COMM,status,IERR)
2630 c        write (iout,*) "Gather PRECOMP21"
2631 c        call flush(iout)
2632         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2633      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2634      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2635      &   iprev,8800+irecv,FG_COMM,status,IERR)
2636 c        write (iout,*) "Gather PRECOMP22"
2637 c        call flush(iout)
2638         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2639      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2640      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2641      &   MPI_PRECOMP23(lenrecv),
2642      &   iprev,9900+irecv,FG_COMM,status,IERR)
2643 c        write (iout,*) "Gather PRECOMP23"
2644 c        call flush(iout)
2645         endif
2646         isend=irecv
2647         irecv=irecv-1
2648         if (irecv.lt.0) irecv=nfgtasks1-1
2649       enddo
2650 #endif
2651         time_gather=time_gather+MPI_Wtime()-time00
2652       endif
2653 #ifdef DEBUG
2654 c      if (fg_rank.eq.0) then
2655         write (iout,*) "Arrays UG and UGDER"
2656         do i=1,nres-1
2657           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2658      &     ((ug(l,k,i),l=1,2),k=1,2),
2659      &     ((ugder(l,k,i),l=1,2),k=1,2)
2660         enddo
2661         write (iout,*) "Arrays UG2 and UG2DER"
2662         do i=1,nres-1
2663           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2664      &     ((ug2(l,k,i),l=1,2),k=1,2),
2665      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2666         enddo
2667         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2668         do i=1,nres-1
2669           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2670      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2671      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2672         enddo
2673         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2674         do i=1,nres-1
2675           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2676      &     costab(i),sintab(i),costab2(i),sintab2(i)
2677         enddo
2678         write (iout,*) "Array MUDER"
2679         do i=1,nres-1
2680           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2681         enddo
2682 c      endif
2683 #endif
2684 #endif
2685 cd      do i=1,nres
2686 cd        iti = itortyp(itype(i))
2687 cd        write (iout,*) i
2688 cd        do j=1,2
2689 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2690 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2691 cd        enddo
2692 cd      enddo
2693       return
2694       end
2695 C--------------------------------------------------------------------------
2696       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2697 C
2698 C This subroutine calculates the average interaction energy and its gradient
2699 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2700 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2701 C The potential depends both on the distance of peptide-group centers and on
2702 C the orientation of the CA-CA virtual bonds.
2703 C
2704       implicit real*8 (a-h,o-z)
2705 #ifdef MPI
2706       include 'mpif.h'
2707 #endif
2708       include 'DIMENSIONS'
2709       include 'COMMON.CONTROL'
2710       include 'COMMON.SETUP'
2711       include 'COMMON.IOUNITS'
2712       include 'COMMON.GEO'
2713       include 'COMMON.VAR'
2714       include 'COMMON.LOCAL'
2715       include 'COMMON.CHAIN'
2716       include 'COMMON.DERIV'
2717       include 'COMMON.INTERACT'
2718       include 'COMMON.CONTACTS'
2719       include 'COMMON.TORSION'
2720       include 'COMMON.VECTORS'
2721       include 'COMMON.FFIELD'
2722       include 'COMMON.TIME1'
2723       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2724      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2725       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2726      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2727       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2728      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2729      &    num_conti,j1,j2
2730 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2731 #ifdef MOMENT
2732       double precision scal_el /1.0d0/
2733 #else
2734       double precision scal_el /0.5d0/
2735 #endif
2736 C 12/13/98
2737 C 13-go grudnia roku pamietnego...
2738       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2739      &                   0.0d0,1.0d0,0.0d0,
2740      &                   0.0d0,0.0d0,1.0d0/
2741 cd      write(iout,*) 'In EELEC'
2742 cd      do i=1,nloctyp
2743 cd        write(iout,*) 'Type',i
2744 cd        write(iout,*) 'B1',B1(:,i)
2745 cd        write(iout,*) 'B2',B2(:,i)
2746 cd        write(iout,*) 'CC',CC(:,:,i)
2747 cd        write(iout,*) 'DD',DD(:,:,i)
2748 cd        write(iout,*) 'EE',EE(:,:,i)
2749 cd      enddo
2750 cd      call check_vecgrad
2751 cd      stop
2752       if (icheckgrad.eq.1) then
2753         do i=1,nres-1
2754           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2755           do k=1,3
2756             dc_norm(k,i)=dc(k,i)*fac
2757           enddo
2758 c          write (iout,*) 'i',i,' fac',fac
2759         enddo
2760       endif
2761       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2762      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2763      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2764 c        call vec_and_deriv
2765 #ifdef TIMING
2766         time01=MPI_Wtime()
2767 #endif
2768         call set_matrices
2769 #ifdef TIMING
2770         time_mat=time_mat+MPI_Wtime()-time01
2771 #endif
2772       endif
2773 cd      do i=1,nres-1
2774 cd        write (iout,*) 'i=',i
2775 cd        do k=1,3
2776 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2777 cd        enddo
2778 cd        do k=1,3
2779 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2780 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2781 cd        enddo
2782 cd      enddo
2783       t_eelecij=0.0d0
2784       ees=0.0D0
2785       evdw1=0.0D0
2786       eel_loc=0.0d0
2787       eello_turn3=0.0d0
2788       eello_turn4=0.0d0
2789       ind=0
2790       do i=1,nres
2791         num_cont_hb(i)=0
2792       enddo
2793 cd      print '(a)','Enter EELEC'
2794 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2795       do i=1,nres
2796         gel_loc_loc(i)=0.0d0
2797         gcorr_loc(i)=0.0d0
2798       enddo
2799 c
2800 c
2801 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2802 C
2803 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2804 C
2805       do i=iturn3_start,iturn3_end
2806         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2807      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2808         dxi=dc(1,i)
2809         dyi=dc(2,i)
2810         dzi=dc(3,i)
2811         dx_normi=dc_norm(1,i)
2812         dy_normi=dc_norm(2,i)
2813         dz_normi=dc_norm(3,i)
2814         xmedi=c(1,i)+0.5d0*dxi
2815         ymedi=c(2,i)+0.5d0*dyi
2816         zmedi=c(3,i)+0.5d0*dzi
2817         num_conti=0
2818         call eelecij(i,i+2,ees,evdw1,eel_loc)
2819         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2820         num_cont_hb(i)=num_conti
2821       enddo
2822       do i=iturn4_start,iturn4_end
2823         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2824      &    .or. itype(i+3).eq.ntyp1
2825      &    .or. itype(i+4).eq.ntyp1) cycle
2826         dxi=dc(1,i)
2827         dyi=dc(2,i)
2828         dzi=dc(3,i)
2829         dx_normi=dc_norm(1,i)
2830         dy_normi=dc_norm(2,i)
2831         dz_normi=dc_norm(3,i)
2832         xmedi=c(1,i)+0.5d0*dxi
2833         ymedi=c(2,i)+0.5d0*dyi
2834         zmedi=c(3,i)+0.5d0*dzi
2835         num_conti=num_cont_hb(i)
2836         call eelecij(i,i+3,ees,evdw1,eel_loc)
2837         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2838      &   call eturn4(i,eello_turn4)
2839         num_cont_hb(i)=num_conti
2840       enddo   ! i
2841 c
2842 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2843 c
2844       do i=iatel_s,iatel_e
2845         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2846         dxi=dc(1,i)
2847         dyi=dc(2,i)
2848         dzi=dc(3,i)
2849         dx_normi=dc_norm(1,i)
2850         dy_normi=dc_norm(2,i)
2851         dz_normi=dc_norm(3,i)
2852         xmedi=c(1,i)+0.5d0*dxi
2853         ymedi=c(2,i)+0.5d0*dyi
2854         zmedi=c(3,i)+0.5d0*dzi
2855 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2856         num_conti=num_cont_hb(i)
2857         do j=ielstart(i),ielend(i)
2858 c          write (iout,*) i,j,itype(i),itype(j)
2859           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2860           call eelecij(i,j,ees,evdw1,eel_loc)
2861         enddo ! j
2862         num_cont_hb(i)=num_conti
2863       enddo   ! i
2864 c      write (iout,*) "Number of loop steps in EELEC:",ind
2865 cd      do i=1,nres
2866 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2867 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2868 cd      enddo
2869 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2870 ccc      eel_loc=eel_loc+eello_turn3
2871 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2872       return
2873       end
2874 C-------------------------------------------------------------------------------
2875       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2876       implicit real*8 (a-h,o-z)
2877       include 'DIMENSIONS'
2878 #ifdef MPI
2879       include "mpif.h"
2880 #endif
2881       include 'COMMON.CONTROL'
2882       include 'COMMON.IOUNITS'
2883       include 'COMMON.GEO'
2884       include 'COMMON.VAR'
2885       include 'COMMON.LOCAL'
2886       include 'COMMON.CHAIN'
2887       include 'COMMON.DERIV'
2888       include 'COMMON.INTERACT'
2889       include 'COMMON.CONTACTS'
2890       include 'COMMON.TORSION'
2891       include 'COMMON.VECTORS'
2892       include 'COMMON.FFIELD'
2893       include 'COMMON.TIME1'
2894       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2895      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2896       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2897      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2898       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2899      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2900      &    num_conti,j1,j2
2901 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2902 #ifdef MOMENT
2903       double precision scal_el /1.0d0/
2904 #else
2905       double precision scal_el /0.5d0/
2906 #endif
2907 C 12/13/98
2908 C 13-go grudnia roku pamietnego...
2909       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2910      &                   0.0d0,1.0d0,0.0d0,
2911      &                   0.0d0,0.0d0,1.0d0/
2912 c          time00=MPI_Wtime()
2913 cd      write (iout,*) "eelecij",i,j
2914 c          ind=ind+1
2915           iteli=itel(i)
2916           itelj=itel(j)
2917           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2918           aaa=app(iteli,itelj)
2919           bbb=bpp(iteli,itelj)
2920           ael6i=ael6(iteli,itelj)
2921           ael3i=ael3(iteli,itelj)
2922           dxj=dc(1,j)
2923           dyj=dc(2,j)
2924           dzj=dc(3,j)
2925           dx_normj=dc_norm(1,j)
2926           dy_normj=dc_norm(2,j)
2927           dz_normj=dc_norm(3,j)
2928           xj=c(1,j)+0.5D0*dxj-xmedi
2929           yj=c(2,j)+0.5D0*dyj-ymedi
2930           zj=c(3,j)+0.5D0*dzj-zmedi
2931           rij=xj*xj+yj*yj+zj*zj
2932           rrmij=1.0D0/rij
2933           rij=dsqrt(rij)
2934           rmij=1.0D0/rij
2935           r3ij=rrmij*rmij
2936           r6ij=r3ij*r3ij
2937           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2938           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2939           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2940           fac=cosa-3.0D0*cosb*cosg
2941           ev1=aaa*r6ij*r6ij
2942 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2943           if (j.eq.i+2) ev1=scal_el*ev1
2944           ev2=bbb*r6ij
2945           fac3=ael6i*r6ij
2946           fac4=ael3i*r3ij
2947           evdwij=ev1+ev2
2948           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2949           el2=fac4*fac
2950           eesij=el1+el2
2951 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2952           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2953           ees=ees+eesij
2954           evdw1=evdw1+evdwij
2955 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2956 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2957 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2958 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2959
2960           if (energy_dec) then
2961               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2962      &'evdw1',i,j,evdwij
2963      &,iteli,itelj,aaa,evdw1
2964               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2965           endif
2966
2967 C
2968 C Calculate contributions to the Cartesian gradient.
2969 C
2970 #ifdef SPLITELE
2971           facvdw=-6*rrmij*(ev1+evdwij)
2972           facel=-3*rrmij*(el1+eesij)
2973           fac1=fac
2974           erij(1)=xj*rmij
2975           erij(2)=yj*rmij
2976           erij(3)=zj*rmij
2977 *
2978 * Radial derivatives. First process both termini of the fragment (i,j)
2979 *
2980           ggg(1)=facel*xj
2981           ggg(2)=facel*yj
2982           ggg(3)=facel*zj
2983 c          do k=1,3
2984 c            ghalf=0.5D0*ggg(k)
2985 c            gelc(k,i)=gelc(k,i)+ghalf
2986 c            gelc(k,j)=gelc(k,j)+ghalf
2987 c          enddo
2988 c 9/28/08 AL Gradient compotents will be summed only at the end
2989           do k=1,3
2990             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2991             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2992           enddo
2993 *
2994 * Loop over residues i+1 thru j-1.
2995 *
2996 cgrad          do k=i+1,j-1
2997 cgrad            do l=1,3
2998 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2999 cgrad            enddo
3000 cgrad          enddo
3001           ggg(1)=facvdw*xj
3002           ggg(2)=facvdw*yj
3003           ggg(3)=facvdw*zj
3004 c          do k=1,3
3005 c            ghalf=0.5D0*ggg(k)
3006 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3007 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3008 c          enddo
3009 c 9/28/08 AL Gradient compotents will be summed only at the end
3010           do k=1,3
3011             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3012             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3013           enddo
3014 *
3015 * Loop over residues i+1 thru j-1.
3016 *
3017 cgrad          do k=i+1,j-1
3018 cgrad            do l=1,3
3019 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3020 cgrad            enddo
3021 cgrad          enddo
3022 #else
3023           facvdw=ev1+evdwij
3024           facel=el1+eesij
3025           fac1=fac
3026           fac=-3*rrmij*(facvdw+facvdw+facel)
3027           erij(1)=xj*rmij
3028           erij(2)=yj*rmij
3029           erij(3)=zj*rmij
3030 *
3031 * Radial derivatives. First process both termini of the fragment (i,j)
3032 *
3033           ggg(1)=fac*xj
3034           ggg(2)=fac*yj
3035           ggg(3)=fac*zj
3036 c          do k=1,3
3037 c            ghalf=0.5D0*ggg(k)
3038 c            gelc(k,i)=gelc(k,i)+ghalf
3039 c            gelc(k,j)=gelc(k,j)+ghalf
3040 c          enddo
3041 c 9/28/08 AL Gradient compotents will be summed only at the end
3042           do k=1,3
3043             gelc_long(k,j)=gelc(k,j)+ggg(k)
3044             gelc_long(k,i)=gelc(k,i)-ggg(k)
3045           enddo
3046 *
3047 * Loop over residues i+1 thru j-1.
3048 *
3049 cgrad          do k=i+1,j-1
3050 cgrad            do l=1,3
3051 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3052 cgrad            enddo
3053 cgrad          enddo
3054 c 9/28/08 AL Gradient compotents will be summed only at the end
3055           ggg(1)=facvdw*xj
3056           ggg(2)=facvdw*yj
3057           ggg(3)=facvdw*zj
3058           do k=1,3
3059             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3060             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3061           enddo
3062 #endif
3063 *
3064 * Angular part
3065 *
3066           ecosa=2.0D0*fac3*fac1+fac4
3067           fac4=-3.0D0*fac4
3068           fac3=-6.0D0*fac3
3069           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3070           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3071           do k=1,3
3072             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3073             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3074           enddo
3075 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3076 cd   &          (dcosg(k),k=1,3)
3077           do k=1,3
3078             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3079           enddo
3080 c          do k=1,3
3081 c            ghalf=0.5D0*ggg(k)
3082 c            gelc(k,i)=gelc(k,i)+ghalf
3083 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3084 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3085 c            gelc(k,j)=gelc(k,j)+ghalf
3086 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3087 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3088 c          enddo
3089 cgrad          do k=i+1,j-1
3090 cgrad            do l=1,3
3091 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3092 cgrad            enddo
3093 cgrad          enddo
3094           do k=1,3
3095             gelc(k,i)=gelc(k,i)
3096      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3097      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3098             gelc(k,j)=gelc(k,j)
3099      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3100      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3101             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3102             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3103           enddo
3104           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3105      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3106      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3107 C
3108 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3109 C   energy of a peptide unit is assumed in the form of a second-order
3110 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3111 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3112 C   are computed for EVERY pair of non-contiguous peptide groups.
3113 C
3114           if (j.lt.nres-1) then
3115             j1=j+1
3116             j2=j-1
3117           else
3118             j1=j-1
3119             j2=j-2
3120           endif
3121           kkk=0
3122           do k=1,2
3123             do l=1,2
3124               kkk=kkk+1
3125               muij(kkk)=mu(k,i)*mu(l,j)
3126             enddo
3127           enddo
3128 cd         write (iout,*) 'EELEC: i',i,' j',j
3129 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3130 cd          write(iout,*) 'muij',muij
3131           ury=scalar(uy(1,i),erij)
3132           urz=scalar(uz(1,i),erij)
3133           vry=scalar(uy(1,j),erij)
3134           vrz=scalar(uz(1,j),erij)
3135           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3136           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3137           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3138           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3139           fac=dsqrt(-ael6i)*r3ij
3140           a22=a22*fac
3141           a23=a23*fac
3142           a32=a32*fac
3143           a33=a33*fac
3144 cd          write (iout,'(4i5,4f10.5)')
3145 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3146 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3147 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3148 cd     &      uy(:,j),uz(:,j)
3149 cd          write (iout,'(4f10.5)')
3150 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3151 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3152 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3153 cd           write (iout,'(9f10.5/)')
3154 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3155 C Derivatives of the elements of A in virtual-bond vectors
3156           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3157           do k=1,3
3158             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3159             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3160             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3161             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3162             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3163             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3164             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3165             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3166             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3167             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3168             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3169             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3170           enddo
3171 C Compute radial contributions to the gradient
3172           facr=-3.0d0*rrmij
3173           a22der=a22*facr
3174           a23der=a23*facr
3175           a32der=a32*facr
3176           a33der=a33*facr
3177           agg(1,1)=a22der*xj
3178           agg(2,1)=a22der*yj
3179           agg(3,1)=a22der*zj
3180           agg(1,2)=a23der*xj
3181           agg(2,2)=a23der*yj
3182           agg(3,2)=a23der*zj
3183           agg(1,3)=a32der*xj
3184           agg(2,3)=a32der*yj
3185           agg(3,3)=a32der*zj
3186           agg(1,4)=a33der*xj
3187           agg(2,4)=a33der*yj
3188           agg(3,4)=a33der*zj
3189 C Add the contributions coming from er
3190           fac3=-3.0d0*fac
3191           do k=1,3
3192             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3193             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3194             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3195             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3196           enddo
3197           do k=1,3
3198 C Derivatives in DC(i)
3199 cgrad            ghalf1=0.5d0*agg(k,1)
3200 cgrad            ghalf2=0.5d0*agg(k,2)
3201 cgrad            ghalf3=0.5d0*agg(k,3)
3202 cgrad            ghalf4=0.5d0*agg(k,4)
3203             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3204      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3205             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3206      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3207             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3208      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3209             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3210      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3211 C Derivatives in DC(i+1)
3212             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3213      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3214             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3215      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3216             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3217      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3218             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3219      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3220 C Derivatives in DC(j)
3221             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3222      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3223             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3224      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3225             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3226      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3227             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3228      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3229 C Derivatives in DC(j+1) or DC(nres-1)
3230             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3231      &      -3.0d0*vryg(k,3)*ury)
3232             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3233      &      -3.0d0*vrzg(k,3)*ury)
3234             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3235      &      -3.0d0*vryg(k,3)*urz)
3236             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3237      &      -3.0d0*vrzg(k,3)*urz)
3238 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3239 cgrad              do l=1,4
3240 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3241 cgrad              enddo
3242 cgrad            endif
3243           enddo
3244           acipa(1,1)=a22
3245           acipa(1,2)=a23
3246           acipa(2,1)=a32
3247           acipa(2,2)=a33
3248           a22=-a22
3249           a23=-a23
3250           do l=1,2
3251             do k=1,3
3252               agg(k,l)=-agg(k,l)
3253               aggi(k,l)=-aggi(k,l)
3254               aggi1(k,l)=-aggi1(k,l)
3255               aggj(k,l)=-aggj(k,l)
3256               aggj1(k,l)=-aggj1(k,l)
3257             enddo
3258           enddo
3259           if (j.lt.nres-1) then
3260             a22=-a22
3261             a32=-a32
3262             do l=1,3,2
3263               do k=1,3
3264                 agg(k,l)=-agg(k,l)
3265                 aggi(k,l)=-aggi(k,l)
3266                 aggi1(k,l)=-aggi1(k,l)
3267                 aggj(k,l)=-aggj(k,l)
3268                 aggj1(k,l)=-aggj1(k,l)
3269               enddo
3270             enddo
3271           else
3272             a22=-a22
3273             a23=-a23
3274             a32=-a32
3275             a33=-a33
3276             do l=1,4
3277               do k=1,3
3278                 agg(k,l)=-agg(k,l)
3279                 aggi(k,l)=-aggi(k,l)
3280                 aggi1(k,l)=-aggi1(k,l)
3281                 aggj(k,l)=-aggj(k,l)
3282                 aggj1(k,l)=-aggj1(k,l)
3283               enddo
3284             enddo
3285           endif
3286           ENDIF ! WCORR
3287           IF (wel_loc.gt.0.0d0) THEN
3288 C Contribution to the local-electrostatic energy coming from the i-j pair
3289           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3290      &     +a33*muij(4)
3291 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3292
3293           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3294      &            'eelloc',i,j,eel_loc_ij
3295 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3296
3297           eel_loc=eel_loc+eel_loc_ij
3298 C Partial derivatives in virtual-bond dihedral angles gamma
3299           if (i.gt.1)
3300      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3301      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3302      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3303           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3304      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3305      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3306 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3307           do l=1,3
3308             ggg(l)=agg(l,1)*muij(1)+
3309      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3310             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3311             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3312 cgrad            ghalf=0.5d0*ggg(l)
3313 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3314 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3315           enddo
3316 cgrad          do k=i+1,j2
3317 cgrad            do l=1,3
3318 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3319 cgrad            enddo
3320 cgrad          enddo
3321 C Remaining derivatives of eello
3322           do l=1,3
3323             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3324      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3325             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3326      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3327             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3328      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3329             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3330      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3331           enddo
3332           ENDIF
3333 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3334 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3335           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3336      &       .and. num_conti.le.maxconts) then
3337 c            write (iout,*) i,j," entered corr"
3338 C
3339 C Calculate the contact function. The ith column of the array JCONT will
3340 C contain the numbers of atoms that make contacts with the atom I (of numbers
3341 C greater than I). The arrays FACONT and GACONT will contain the values of
3342 C the contact function and its derivative.
3343 c           r0ij=1.02D0*rpp(iteli,itelj)
3344 c           r0ij=1.11D0*rpp(iteli,itelj)
3345             r0ij=2.20D0*rpp(iteli,itelj)
3346 c           r0ij=1.55D0*rpp(iteli,itelj)
3347             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3348             if (fcont.gt.0.0D0) then
3349               num_conti=num_conti+1
3350               if (num_conti.gt.maxconts) then
3351                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3352      &                         ' will skip next contacts for this conf.'
3353               else
3354                 jcont_hb(num_conti,i)=j
3355 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3356 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3357                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3358      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3359 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3360 C  terms.
3361                 d_cont(num_conti,i)=rij
3362 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3363 C     --- Electrostatic-interaction matrix ---
3364                 a_chuj(1,1,num_conti,i)=a22
3365                 a_chuj(1,2,num_conti,i)=a23
3366                 a_chuj(2,1,num_conti,i)=a32
3367                 a_chuj(2,2,num_conti,i)=a33
3368 C     --- Gradient of rij
3369                 do kkk=1,3
3370                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3371                 enddo
3372                 kkll=0
3373                 do k=1,2
3374                   do l=1,2
3375                     kkll=kkll+1
3376                     do m=1,3
3377                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3378                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3379                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3380                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3381                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3382                     enddo
3383                   enddo
3384                 enddo
3385                 ENDIF
3386                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3387 C Calculate contact energies
3388                 cosa4=4.0D0*cosa
3389                 wij=cosa-3.0D0*cosb*cosg
3390                 cosbg1=cosb+cosg
3391                 cosbg2=cosb-cosg
3392 c               fac3=dsqrt(-ael6i)/r0ij**3
3393                 fac3=dsqrt(-ael6i)*r3ij
3394 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3395                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3396                 if (ees0tmp.gt.0) then
3397                   ees0pij=dsqrt(ees0tmp)
3398                 else
3399                   ees0pij=0
3400                 endif
3401 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3402                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3403                 if (ees0tmp.gt.0) then
3404                   ees0mij=dsqrt(ees0tmp)
3405                 else
3406                   ees0mij=0
3407                 endif
3408 c               ees0mij=0.0D0
3409                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3410                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3411 C Diagnostics. Comment out or remove after debugging!
3412 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3413 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3414 c               ees0m(num_conti,i)=0.0D0
3415 C End diagnostics.
3416 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3417 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3418 C Angular derivatives of the contact function
3419                 ees0pij1=fac3/ees0pij
3420                 ees0mij1=fac3/ees0mij
3421                 fac3p=-3.0D0*fac3*rrmij
3422                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3423                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3424 c               ees0mij1=0.0D0
3425                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3426                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3427                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3428                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3429                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3430                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3431                 ecosap=ecosa1+ecosa2
3432                 ecosbp=ecosb1+ecosb2
3433                 ecosgp=ecosg1+ecosg2
3434                 ecosam=ecosa1-ecosa2
3435                 ecosbm=ecosb1-ecosb2
3436                 ecosgm=ecosg1-ecosg2
3437 C Diagnostics
3438 c               ecosap=ecosa1
3439 c               ecosbp=ecosb1
3440 c               ecosgp=ecosg1
3441 c               ecosam=0.0D0
3442 c               ecosbm=0.0D0
3443 c               ecosgm=0.0D0
3444 C End diagnostics
3445                 facont_hb(num_conti,i)=fcont
3446                 fprimcont=fprimcont/rij
3447 cd              facont_hb(num_conti,i)=1.0D0
3448 C Following line is for diagnostics.
3449 cd              fprimcont=0.0D0
3450                 do k=1,3
3451                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3452                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3453                 enddo
3454                 do k=1,3
3455                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3456                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3457                 enddo
3458                 gggp(1)=gggp(1)+ees0pijp*xj
3459                 gggp(2)=gggp(2)+ees0pijp*yj
3460                 gggp(3)=gggp(3)+ees0pijp*zj
3461                 gggm(1)=gggm(1)+ees0mijp*xj
3462                 gggm(2)=gggm(2)+ees0mijp*yj
3463                 gggm(3)=gggm(3)+ees0mijp*zj
3464 C Derivatives due to the contact function
3465                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3466                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3467                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3468                 do k=1,3
3469 c
3470 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3471 c          following the change of gradient-summation algorithm.
3472 c
3473 cgrad                  ghalfp=0.5D0*gggp(k)
3474 cgrad                  ghalfm=0.5D0*gggm(k)
3475                   gacontp_hb1(k,num_conti,i)=!ghalfp
3476      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3477      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3478                   gacontp_hb2(k,num_conti,i)=!ghalfp
3479      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3480      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3481                   gacontp_hb3(k,num_conti,i)=gggp(k)
3482                   gacontm_hb1(k,num_conti,i)=!ghalfm
3483      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3484      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3485                   gacontm_hb2(k,num_conti,i)=!ghalfm
3486      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3487      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3488                   gacontm_hb3(k,num_conti,i)=gggm(k)
3489                 enddo
3490 C Diagnostics. Comment out or remove after debugging!
3491 cdiag           do k=1,3
3492 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3493 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3494 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3495 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3496 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3497 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3498 cdiag           enddo
3499               ENDIF ! wcorr
3500               endif  ! num_conti.le.maxconts
3501             endif  ! fcont.gt.0
3502           endif    ! j.gt.i+1
3503           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3504             do k=1,4
3505               do l=1,3
3506                 ghalf=0.5d0*agg(l,k)
3507                 aggi(l,k)=aggi(l,k)+ghalf
3508                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3509                 aggj(l,k)=aggj(l,k)+ghalf
3510               enddo
3511             enddo
3512             if (j.eq.nres-1 .and. i.lt.j-2) then
3513               do k=1,4
3514                 do l=1,3
3515                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3516                 enddo
3517               enddo
3518             endif
3519           endif
3520 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3521       return
3522       end
3523 C-----------------------------------------------------------------------------
3524       subroutine eturn3(i,eello_turn3)
3525 C Third- and fourth-order contributions from turns
3526       implicit real*8 (a-h,o-z)
3527       include 'DIMENSIONS'
3528       include 'COMMON.IOUNITS'
3529       include 'COMMON.GEO'
3530       include 'COMMON.VAR'
3531       include 'COMMON.LOCAL'
3532       include 'COMMON.CHAIN'
3533       include 'COMMON.DERIV'
3534       include 'COMMON.INTERACT'
3535       include 'COMMON.CONTACTS'
3536       include 'COMMON.TORSION'
3537       include 'COMMON.VECTORS'
3538       include 'COMMON.FFIELD'
3539       include 'COMMON.CONTROL'
3540       dimension ggg(3)
3541       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3542      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3543      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3544       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3545      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3546       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3547      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3548      &    num_conti,j1,j2
3549       j=i+2
3550 c      write (iout,*) "eturn3",i,j,j1,j2
3551       a_temp(1,1)=a22
3552       a_temp(1,2)=a23
3553       a_temp(2,1)=a32
3554       a_temp(2,2)=a33
3555 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3556 C
3557 C               Third-order contributions
3558 C
3559 C                 (i+2)o----(i+3)
3560 C                      | |
3561 C                      | |
3562 C                 (i+1)o----i
3563 C
3564 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3565 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3566         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3567         call transpose2(auxmat(1,1),auxmat1(1,1))
3568         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3569         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3570         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3571      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3572 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3573 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3574 cd     &    ' eello_turn3_num',4*eello_turn3_num
3575 C Derivatives in gamma(i)
3576         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3577         call transpose2(auxmat2(1,1),auxmat3(1,1))
3578         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3579         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3580 C Derivatives in gamma(i+1)
3581         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3582         call transpose2(auxmat2(1,1),auxmat3(1,1))
3583         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3584         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3585      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3586 C Cartesian derivatives
3587         do l=1,3
3588 c            ghalf1=0.5d0*agg(l,1)
3589 c            ghalf2=0.5d0*agg(l,2)
3590 c            ghalf3=0.5d0*agg(l,3)
3591 c            ghalf4=0.5d0*agg(l,4)
3592           a_temp(1,1)=aggi(l,1)!+ghalf1
3593           a_temp(1,2)=aggi(l,2)!+ghalf2
3594           a_temp(2,1)=aggi(l,3)!+ghalf3
3595           a_temp(2,2)=aggi(l,4)!+ghalf4
3596           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3597           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3598      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3599           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3600           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3601           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3602           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3603           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3604           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3605      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3606           a_temp(1,1)=aggj(l,1)!+ghalf1
3607           a_temp(1,2)=aggj(l,2)!+ghalf2
3608           a_temp(2,1)=aggj(l,3)!+ghalf3
3609           a_temp(2,2)=aggj(l,4)!+ghalf4
3610           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3611           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3612      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3613           a_temp(1,1)=aggj1(l,1)
3614           a_temp(1,2)=aggj1(l,2)
3615           a_temp(2,1)=aggj1(l,3)
3616           a_temp(2,2)=aggj1(l,4)
3617           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3618           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3619      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3620         enddo
3621       return
3622       end
3623 C-------------------------------------------------------------------------------
3624       subroutine eturn4(i,eello_turn4)
3625 C Third- and fourth-order contributions from turns
3626       implicit real*8 (a-h,o-z)
3627       include 'DIMENSIONS'
3628       include 'COMMON.IOUNITS'
3629       include 'COMMON.GEO'
3630       include 'COMMON.VAR'
3631       include 'COMMON.LOCAL'
3632       include 'COMMON.CHAIN'
3633       include 'COMMON.DERIV'
3634       include 'COMMON.INTERACT'
3635       include 'COMMON.CONTACTS'
3636       include 'COMMON.TORSION'
3637       include 'COMMON.VECTORS'
3638       include 'COMMON.FFIELD'
3639       include 'COMMON.CONTROL'
3640       dimension ggg(3)
3641       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3642      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3643      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3644       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3645      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3646       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3647      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3648      &    num_conti,j1,j2
3649       j=i+3
3650 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3651 C
3652 C               Fourth-order contributions
3653 C
3654 C                 (i+3)o----(i+4)
3655 C                     /  |
3656 C               (i+2)o   |
3657 C                     \  |
3658 C                 (i+1)o----i
3659 C
3660 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3661 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3662 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3663         a_temp(1,1)=a22
3664         a_temp(1,2)=a23
3665         a_temp(2,1)=a32
3666         a_temp(2,2)=a33
3667         iti1=itortyp(itype(i+1))
3668         iti2=itortyp(itype(i+2))
3669         iti3=itortyp(itype(i+3))
3670 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3671         call transpose2(EUg(1,1,i+1),e1t(1,1))
3672         call transpose2(Eug(1,1,i+2),e2t(1,1))
3673         call transpose2(Eug(1,1,i+3),e3t(1,1))
3674         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3675         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3676         s1=scalar2(b1(1,iti2),auxvec(1))
3677         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3678         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3679         s2=scalar2(b1(1,iti1),auxvec(1))
3680         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3681         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3682         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3683         eello_turn4=eello_turn4-(s1+s2+s3)
3684         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3685      &      'eturn4',i,j,-(s1+s2+s3)
3686 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3687 cd     &    ' eello_turn4_num',8*eello_turn4_num
3688 C Derivatives in gamma(i)
3689         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3690         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3691         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3692         s1=scalar2(b1(1,iti2),auxvec(1))
3693         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3694         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3695         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3696 C Derivatives in gamma(i+1)
3697         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3698         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3699         s2=scalar2(b1(1,iti1),auxvec(1))
3700         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3701         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3702         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3703         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3704 C Derivatives in gamma(i+2)
3705         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3706         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3707         s1=scalar2(b1(1,iti2),auxvec(1))
3708         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3709         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3710         s2=scalar2(b1(1,iti1),auxvec(1))
3711         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3712         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3713         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3714         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3715 C Cartesian derivatives
3716 C Derivatives of this turn contributions in DC(i+2)
3717         if (j.lt.nres-1) then
3718           do l=1,3
3719             a_temp(1,1)=agg(l,1)
3720             a_temp(1,2)=agg(l,2)
3721             a_temp(2,1)=agg(l,3)
3722             a_temp(2,2)=agg(l,4)
3723             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3724             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3725             s1=scalar2(b1(1,iti2),auxvec(1))
3726             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3727             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3728             s2=scalar2(b1(1,iti1),auxvec(1))
3729             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3730             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3731             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3732             ggg(l)=-(s1+s2+s3)
3733             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3734           enddo
3735         endif
3736 C Remaining derivatives of this turn contribution
3737         do l=1,3
3738           a_temp(1,1)=aggi(l,1)
3739           a_temp(1,2)=aggi(l,2)
3740           a_temp(2,1)=aggi(l,3)
3741           a_temp(2,2)=aggi(l,4)
3742           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3743           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3744           s1=scalar2(b1(1,iti2),auxvec(1))
3745           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3746           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3747           s2=scalar2(b1(1,iti1),auxvec(1))
3748           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3749           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3750           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3751           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3752           a_temp(1,1)=aggi1(l,1)
3753           a_temp(1,2)=aggi1(l,2)
3754           a_temp(2,1)=aggi1(l,3)
3755           a_temp(2,2)=aggi1(l,4)
3756           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3757           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3758           s1=scalar2(b1(1,iti2),auxvec(1))
3759           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3760           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3761           s2=scalar2(b1(1,iti1),auxvec(1))
3762           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3763           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3764           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3765           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3766           a_temp(1,1)=aggj(l,1)
3767           a_temp(1,2)=aggj(l,2)
3768           a_temp(2,1)=aggj(l,3)
3769           a_temp(2,2)=aggj(l,4)
3770           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3771           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3772           s1=scalar2(b1(1,iti2),auxvec(1))
3773           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3774           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3775           s2=scalar2(b1(1,iti1),auxvec(1))
3776           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3777           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3778           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3779           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3780           a_temp(1,1)=aggj1(l,1)
3781           a_temp(1,2)=aggj1(l,2)
3782           a_temp(2,1)=aggj1(l,3)
3783           a_temp(2,2)=aggj1(l,4)
3784           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3785           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3786           s1=scalar2(b1(1,iti2),auxvec(1))
3787           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3788           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3789           s2=scalar2(b1(1,iti1),auxvec(1))
3790           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3791           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3792           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3793 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3794           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3795         enddo
3796       return
3797       end
3798 C-----------------------------------------------------------------------------
3799       subroutine vecpr(u,v,w)
3800       implicit real*8(a-h,o-z)
3801       dimension u(3),v(3),w(3)
3802       w(1)=u(2)*v(3)-u(3)*v(2)
3803       w(2)=-u(1)*v(3)+u(3)*v(1)
3804       w(3)=u(1)*v(2)-u(2)*v(1)
3805       return
3806       end
3807 C-----------------------------------------------------------------------------
3808       subroutine unormderiv(u,ugrad,unorm,ungrad)
3809 C This subroutine computes the derivatives of a normalized vector u, given
3810 C the derivatives computed without normalization conditions, ugrad. Returns
3811 C ungrad.
3812       implicit none
3813       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3814       double precision vec(3)
3815       double precision scalar
3816       integer i,j
3817 c      write (2,*) 'ugrad',ugrad
3818 c      write (2,*) 'u',u
3819       do i=1,3
3820         vec(i)=scalar(ugrad(1,i),u(1))
3821       enddo
3822 c      write (2,*) 'vec',vec
3823       do i=1,3
3824         do j=1,3
3825           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3826         enddo
3827       enddo
3828 c      write (2,*) 'ungrad',ungrad
3829       return
3830       end
3831 C-----------------------------------------------------------------------------
3832       subroutine escp_soft_sphere(evdw2,evdw2_14)
3833 C
3834 C This subroutine calculates the excluded-volume interaction energy between
3835 C peptide-group centers and side chains and its gradient in virtual-bond and
3836 C side-chain vectors.
3837 C
3838       implicit real*8 (a-h,o-z)
3839       include 'DIMENSIONS'
3840       include 'COMMON.GEO'
3841       include 'COMMON.VAR'
3842       include 'COMMON.LOCAL'
3843       include 'COMMON.CHAIN'
3844       include 'COMMON.DERIV'
3845       include 'COMMON.INTERACT'
3846       include 'COMMON.FFIELD'
3847       include 'COMMON.IOUNITS'
3848       include 'COMMON.CONTROL'
3849       dimension ggg(3)
3850       evdw2=0.0D0
3851       evdw2_14=0.0d0
3852       r0_scp=4.5d0
3853 cd    print '(a)','Enter ESCP'
3854 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3855       do i=iatscp_s,iatscp_e
3856         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3857         iteli=itel(i)
3858         xi=0.5D0*(c(1,i)+c(1,i+1))
3859         yi=0.5D0*(c(2,i)+c(2,i+1))
3860         zi=0.5D0*(c(3,i)+c(3,i+1))
3861
3862         do iint=1,nscp_gr(i)
3863
3864         do j=iscpstart(i,iint),iscpend(i,iint)
3865           if (itype(j).eq.ntyp1) cycle
3866           itypj=iabs(itype(j))
3867 C Uncomment following three lines for SC-p interactions
3868 c         xj=c(1,nres+j)-xi
3869 c         yj=c(2,nres+j)-yi
3870 c         zj=c(3,nres+j)-zi
3871 C Uncomment following three lines for Ca-p interactions
3872           xj=c(1,j)-xi
3873           yj=c(2,j)-yi
3874           zj=c(3,j)-zi
3875           rij=xj*xj+yj*yj+zj*zj
3876           r0ij=r0_scp
3877           r0ijsq=r0ij*r0ij
3878           if (rij.lt.r0ijsq) then
3879             evdwij=0.25d0*(rij-r0ijsq)**2
3880             fac=rij-r0ijsq
3881           else
3882             evdwij=0.0d0
3883             fac=0.0d0
3884           endif
3885           evdw2=evdw2+evdwij
3886 C
3887 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3888 C
3889           ggg(1)=xj*fac
3890           ggg(2)=yj*fac
3891           ggg(3)=zj*fac
3892 cgrad          if (j.lt.i) then
3893 cd          write (iout,*) 'j<i'
3894 C Uncomment following three lines for SC-p interactions
3895 c           do k=1,3
3896 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3897 c           enddo
3898 cgrad          else
3899 cd          write (iout,*) 'j>i'
3900 cgrad            do k=1,3
3901 cgrad              ggg(k)=-ggg(k)
3902 C Uncomment following line for SC-p interactions
3903 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3904 cgrad            enddo
3905 cgrad          endif
3906 cgrad          do k=1,3
3907 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3908 cgrad          enddo
3909 cgrad          kstart=min0(i+1,j)
3910 cgrad          kend=max0(i-1,j-1)
3911 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3912 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3913 cgrad          do k=kstart,kend
3914 cgrad            do l=1,3
3915 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3916 cgrad            enddo
3917 cgrad          enddo
3918           do k=1,3
3919             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3920             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3921           enddo
3922         enddo
3923
3924         enddo ! iint
3925       enddo ! i
3926       return
3927       end
3928 C-----------------------------------------------------------------------------
3929       subroutine escp(evdw2,evdw2_14)
3930 C
3931 C This subroutine calculates the excluded-volume interaction energy between
3932 C peptide-group centers and side chains and its gradient in virtual-bond and
3933 C side-chain vectors.
3934 C
3935       implicit real*8 (a-h,o-z)
3936       include 'DIMENSIONS'
3937       include 'COMMON.GEO'
3938       include 'COMMON.VAR'
3939       include 'COMMON.LOCAL'
3940       include 'COMMON.CHAIN'
3941       include 'COMMON.DERIV'
3942       include 'COMMON.INTERACT'
3943       include 'COMMON.FFIELD'
3944       include 'COMMON.IOUNITS'
3945       include 'COMMON.CONTROL'
3946       dimension ggg(3)
3947       evdw2=0.0D0
3948       evdw2_14=0.0d0
3949 cd    print '(a)','Enter ESCP'
3950 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3951       do i=iatscp_s,iatscp_e
3952         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3953         iteli=itel(i)
3954         xi=0.5D0*(c(1,i)+c(1,i+1))
3955         yi=0.5D0*(c(2,i)+c(2,i+1))
3956         zi=0.5D0*(c(3,i)+c(3,i+1))
3957
3958         do iint=1,nscp_gr(i)
3959
3960         do j=iscpstart(i,iint),iscpend(i,iint)
3961           itypj=iabs(itype(j))
3962           if (itypj.eq.ntyp1) cycle
3963 C Uncomment following three lines for SC-p interactions
3964 c         xj=c(1,nres+j)-xi
3965 c         yj=c(2,nres+j)-yi
3966 c         zj=c(3,nres+j)-zi
3967 C Uncomment following three lines for Ca-p interactions
3968           xj=c(1,j)-xi
3969           yj=c(2,j)-yi
3970           zj=c(3,j)-zi
3971           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3972           fac=rrij**expon2
3973           e1=fac*fac*aad(itypj,iteli)
3974           e2=fac*bad(itypj,iteli)
3975           if (iabs(j-i) .le. 2) then
3976             e1=scal14*e1
3977             e2=scal14*e2
3978             evdw2_14=evdw2_14+e1+e2
3979           endif
3980           evdwij=e1+e2
3981           evdw2=evdw2+evdwij
3982           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3983      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3984      &       bad(itypj,iteli)
3985 C
3986 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3987 C
3988           fac=-(evdwij+e1)*rrij
3989           ggg(1)=xj*fac
3990           ggg(2)=yj*fac
3991           ggg(3)=zj*fac
3992 cgrad          if (j.lt.i) then
3993 cd          write (iout,*) 'j<i'
3994 C Uncomment following three lines for SC-p interactions
3995 c           do k=1,3
3996 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3997 c           enddo
3998 cgrad          else
3999 cd          write (iout,*) 'j>i'
4000 cgrad            do k=1,3
4001 cgrad              ggg(k)=-ggg(k)
4002 C Uncomment following line for SC-p interactions
4003 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4004 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4005 cgrad            enddo
4006 cgrad          endif
4007 cgrad          do k=1,3
4008 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4009 cgrad          enddo
4010 cgrad          kstart=min0(i+1,j)
4011 cgrad          kend=max0(i-1,j-1)
4012 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4013 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4014 cgrad          do k=kstart,kend
4015 cgrad            do l=1,3
4016 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4017 cgrad            enddo
4018 cgrad          enddo
4019           do k=1,3
4020             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4021             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4022           enddo
4023         enddo
4024
4025         enddo ! iint
4026       enddo ! i
4027       do i=1,nct
4028         do j=1,3
4029           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4030           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4031           gradx_scp(j,i)=expon*gradx_scp(j,i)
4032         enddo
4033       enddo
4034 C******************************************************************************
4035 C
4036 C                              N O T E !!!
4037 C
4038 C To save time the factor EXPON has been extracted from ALL components
4039 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4040 C use!
4041 C
4042 C******************************************************************************
4043       return
4044       end
4045 C--------------------------------------------------------------------------
4046       subroutine edis(ehpb)
4047 C
4048 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4049 C
4050       implicit real*8 (a-h,o-z)
4051       include 'DIMENSIONS'
4052       include 'COMMON.SBRIDGE'
4053       include 'COMMON.CHAIN'
4054       include 'COMMON.DERIV'
4055       include 'COMMON.VAR'
4056       include 'COMMON.INTERACT'
4057       include 'COMMON.IOUNITS'
4058       dimension ggg(3)
4059       ehpb=0.0D0
4060 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4061 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4062       if (link_end.eq.0) return
4063       do i=link_start,link_end
4064 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4065 C CA-CA distance used in regularization of structure.
4066         ii=ihpb(i)
4067         jj=jhpb(i)
4068 C iii and jjj point to the residues for which the distance is assigned.
4069         if (ii.gt.nres) then
4070           iii=ii-nres
4071           jjj=jj-nres
4072         else
4073           iii=ii
4074           jjj=jj
4075         endif
4076 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4077 c     &    dhpb(i),dhpb1(i),forcon(i)
4078 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4079 C    distance and angle dependent SS bond potential.
4080 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4081 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4082         if (.not.dyn_ss .and. i.le.nss) then
4083 C 15/02/13 CC dynamic SSbond - additional check
4084          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4085      & iabs(itype(jjj)).eq.1) then
4086           call ssbond_ene(iii,jjj,eij)
4087           ehpb=ehpb+2*eij
4088          endif
4089 cd          write (iout,*) "eij",eij
4090         else
4091 C Calculate the distance between the two points and its difference from the
4092 C target distance.
4093           dd=dist(ii,jj)
4094             rdis=dd-dhpb(i)
4095 C Get the force constant corresponding to this distance.
4096             waga=forcon(i)
4097 C Calculate the contribution to energy.
4098             ehpb=ehpb+waga*rdis*rdis
4099 C
4100 C Evaluate gradient.
4101 C
4102             fac=waga*rdis/dd
4103 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4104 cd   &   ' waga=',waga,' fac=',fac
4105             do j=1,3
4106               ggg(j)=fac*(c(j,jj)-c(j,ii))
4107             enddo
4108 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4109 C If this is a SC-SC distance, we need to calculate the contributions to the
4110 C Cartesian gradient in the SC vectors (ghpbx).
4111           if (iii.lt.ii) then
4112           do j=1,3
4113             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4114             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4115           enddo
4116           endif
4117 cgrad        do j=iii,jjj-1
4118 cgrad          do k=1,3
4119 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4120 cgrad          enddo
4121 cgrad        enddo
4122           do k=1,3
4123             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4124             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4125           enddo
4126         endif
4127       enddo
4128       ehpb=0.5D0*ehpb
4129       return
4130       end
4131 C--------------------------------------------------------------------------
4132       subroutine ssbond_ene(i,j,eij)
4133 C
4134 C Calculate the distance and angle dependent SS-bond potential energy
4135 C using a free-energy function derived based on RHF/6-31G** ab initio
4136 C calculations of diethyl disulfide.
4137 C
4138 C A. Liwo and U. Kozlowska, 11/24/03
4139 C
4140       implicit real*8 (a-h,o-z)
4141       include 'DIMENSIONS'
4142       include 'COMMON.SBRIDGE'
4143       include 'COMMON.CHAIN'
4144       include 'COMMON.DERIV'
4145       include 'COMMON.LOCAL'
4146       include 'COMMON.INTERACT'
4147       include 'COMMON.VAR'
4148       include 'COMMON.IOUNITS'
4149       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4150       itypi=iabs(itype(i))
4151       xi=c(1,nres+i)
4152       yi=c(2,nres+i)
4153       zi=c(3,nres+i)
4154       dxi=dc_norm(1,nres+i)
4155       dyi=dc_norm(2,nres+i)
4156       dzi=dc_norm(3,nres+i)
4157 c      dsci_inv=dsc_inv(itypi)
4158       dsci_inv=vbld_inv(nres+i)
4159       itypj=iabs(itype(j))
4160 c      dscj_inv=dsc_inv(itypj)
4161       dscj_inv=vbld_inv(nres+j)
4162       xj=c(1,nres+j)-xi
4163       yj=c(2,nres+j)-yi
4164       zj=c(3,nres+j)-zi
4165       dxj=dc_norm(1,nres+j)
4166       dyj=dc_norm(2,nres+j)
4167       dzj=dc_norm(3,nres+j)
4168       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4169       rij=dsqrt(rrij)
4170       erij(1)=xj*rij
4171       erij(2)=yj*rij
4172       erij(3)=zj*rij
4173       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4174       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4175       om12=dxi*dxj+dyi*dyj+dzi*dzj
4176       do k=1,3
4177         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4178         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4179       enddo
4180       rij=1.0d0/rij
4181       deltad=rij-d0cm
4182       deltat1=1.0d0-om1
4183       deltat2=1.0d0+om2
4184       deltat12=om2-om1+2.0d0
4185       cosphi=om12-om1*om2
4186       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4187      &  +akct*deltad*deltat12
4188      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4189 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4190 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4191 c     &  " deltat12",deltat12," eij",eij
4192       ed=2*akcm*deltad+akct*deltat12
4193       pom1=akct*deltad
4194       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4195       eom1=-2*akth*deltat1-pom1-om2*pom2
4196       eom2= 2*akth*deltat2+pom1-om1*pom2
4197       eom12=pom2
4198       do k=1,3
4199         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4200         ghpbx(k,i)=ghpbx(k,i)-ggk
4201      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4202      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4203         ghpbx(k,j)=ghpbx(k,j)+ggk
4204      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4205      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4206         ghpbc(k,i)=ghpbc(k,i)-ggk
4207         ghpbc(k,j)=ghpbc(k,j)+ggk
4208       enddo
4209 C
4210 C Calculate the components of the gradient in DC and X
4211 C
4212 cgrad      do k=i,j-1
4213 cgrad        do l=1,3
4214 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4215 cgrad        enddo
4216 cgrad      enddo
4217       return
4218       end
4219 C--------------------------------------------------------------------------
4220       subroutine ebond(estr)
4221 c
4222 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4223 c
4224       implicit real*8 (a-h,o-z)
4225       include 'DIMENSIONS'
4226       include 'COMMON.LOCAL'
4227       include 'COMMON.GEO'
4228       include 'COMMON.INTERACT'
4229       include 'COMMON.DERIV'
4230       include 'COMMON.VAR'
4231       include 'COMMON.CHAIN'
4232       include 'COMMON.IOUNITS'
4233       include 'COMMON.NAMES'
4234       include 'COMMON.FFIELD'
4235       include 'COMMON.CONTROL'
4236       include 'COMMON.SETUP'
4237       double precision u(3),ud(3)
4238       estr=0.0d0
4239       estr1=0.0d0
4240       do i=ibondp_start,ibondp_end
4241         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4242           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4243           do j=1,3
4244           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4245      &      *dc(j,i-1)/vbld(i)
4246           enddo
4247           if (energy_dec) write(iout,*)
4248      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4249         else
4250         diff = vbld(i)-vbldp0
4251         if (energy_dec) write (iout,*)
4252      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4253         estr=estr+diff*diff
4254         do j=1,3
4255           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4256         enddo
4257 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4258         endif
4259       enddo
4260       estr=0.5d0*AKP*estr+estr1
4261 c
4262 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4263 c
4264       do i=ibond_start,ibond_end
4265         iti=iabs(itype(i))
4266         if (iti.ne.10 .and. iti.ne.ntyp1) then
4267           nbi=nbondterm(iti)
4268           if (nbi.eq.1) then
4269             diff=vbld(i+nres)-vbldsc0(1,iti)
4270             if (energy_dec) write (iout,*)
4271      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4272      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4273             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4274             do j=1,3
4275               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4276             enddo
4277           else
4278             do j=1,nbi
4279               diff=vbld(i+nres)-vbldsc0(j,iti)
4280               ud(j)=aksc(j,iti)*diff
4281               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4282             enddo
4283             uprod=u(1)
4284             do j=2,nbi
4285               uprod=uprod*u(j)
4286             enddo
4287             usum=0.0d0
4288             usumsqder=0.0d0
4289             do j=1,nbi
4290               uprod1=1.0d0
4291               uprod2=1.0d0
4292               do k=1,nbi
4293                 if (k.ne.j) then
4294                   uprod1=uprod1*u(k)
4295                   uprod2=uprod2*u(k)*u(k)
4296                 endif
4297               enddo
4298               usum=usum+uprod1
4299               usumsqder=usumsqder+ud(j)*uprod2
4300             enddo
4301             estr=estr+uprod/usum
4302             do j=1,3
4303              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4304             enddo
4305           endif
4306         endif
4307       enddo
4308       return
4309       end
4310 #ifdef CRYST_THETA
4311 C--------------------------------------------------------------------------
4312       subroutine ebend(etheta)
4313 C
4314 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4315 C angles gamma and its derivatives in consecutive thetas and gammas.
4316 C
4317       implicit real*8 (a-h,o-z)
4318       include 'DIMENSIONS'
4319       include 'COMMON.LOCAL'
4320       include 'COMMON.GEO'
4321       include 'COMMON.INTERACT'
4322       include 'COMMON.DERIV'
4323       include 'COMMON.VAR'
4324       include 'COMMON.CHAIN'
4325       include 'COMMON.IOUNITS'
4326       include 'COMMON.NAMES'
4327       include 'COMMON.FFIELD'
4328       include 'COMMON.CONTROL'
4329       common /calcthet/ term1,term2,termm,diffak,ratak,
4330      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4331      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4332       double precision y(2),z(2)
4333       delta=0.02d0*pi
4334 c      time11=dexp(-2*time)
4335 c      time12=1.0d0
4336       etheta=0.0D0
4337 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4338       do i=ithet_start,ithet_end
4339         if (itype(i-1).eq.ntyp1) cycle
4340 C Zero the energy function and its derivative at 0 or pi.
4341         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4342         it=itype(i-1)
4343         ichir1=isign(1,itype(i-2))
4344         ichir2=isign(1,itype(i))
4345          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4346          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4347          if (itype(i-1).eq.10) then
4348           itype1=isign(10,itype(i-2))
4349           ichir11=isign(1,itype(i-2))
4350           ichir12=isign(1,itype(i-2))
4351           itype2=isign(10,itype(i))
4352           ichir21=isign(1,itype(i))
4353           ichir22=isign(1,itype(i))
4354          endif
4355
4356         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4357 #ifdef OSF
4358           phii=phi(i)
4359           if (phii.ne.phii) phii=150.0
4360 #else
4361           phii=phi(i)
4362 #endif
4363           y(1)=dcos(phii)
4364           y(2)=dsin(phii)
4365         else
4366           y(1)=0.0D0
4367           y(2)=0.0D0
4368         endif
4369         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4370 #ifdef OSF
4371           phii1=phi(i+1)
4372           if (phii1.ne.phii1) phii1=150.0
4373           phii1=pinorm(phii1)
4374           z(1)=cos(phii1)
4375 #else
4376           phii1=phi(i+1)
4377           z(1)=dcos(phii1)
4378 #endif
4379           z(2)=dsin(phii1)
4380         else
4381           z(1)=0.0D0
4382           z(2)=0.0D0
4383         endif
4384 C Calculate the "mean" value of theta from the part of the distribution
4385 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4386 C In following comments this theta will be referred to as t_c.
4387         thet_pred_mean=0.0d0
4388         do k=1,2
4389             athetk=athet(k,it,ichir1,ichir2)
4390             bthetk=bthet(k,it,ichir1,ichir2)
4391           if (it.eq.10) then
4392              athetk=athet(k,itype1,ichir11,ichir12)
4393              bthetk=bthet(k,itype2,ichir21,ichir22)
4394           endif
4395          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4396         enddo
4397         dthett=thet_pred_mean*ssd
4398         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4399 C Derivatives of the "mean" values in gamma1 and gamma2.
4400         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4401      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4402          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4403      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4404          if (it.eq.10) then
4405       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4406      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4407         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4408      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4409          endif
4410         if (theta(i).gt.pi-delta) then
4411           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4412      &         E_tc0)
4413           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4414           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4415           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4416      &        E_theta)
4417           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4418      &        E_tc)
4419         else if (theta(i).lt.delta) then
4420           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4421           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4422           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4423      &        E_theta)
4424           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4425           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4426      &        E_tc)
4427         else
4428           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4429      &        E_theta,E_tc)
4430         endif
4431         etheta=etheta+ethetai
4432         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4433      &      'ebend',i,ethetai
4434         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4435         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4436         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4437       enddo
4438 C Ufff.... We've done all this!!!
4439       return
4440       end
4441 C---------------------------------------------------------------------------
4442       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4443      &     E_tc)
4444       implicit real*8 (a-h,o-z)
4445       include 'DIMENSIONS'
4446       include 'COMMON.LOCAL'
4447       include 'COMMON.IOUNITS'
4448       common /calcthet/ term1,term2,termm,diffak,ratak,
4449      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4450      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4451 C Calculate the contributions to both Gaussian lobes.
4452 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4453 C The "polynomial part" of the "standard deviation" of this part of
4454 C the distribution.
4455         sig=polthet(3,it)
4456         do j=2,0,-1
4457           sig=sig*thet_pred_mean+polthet(j,it)
4458         enddo
4459 C Derivative of the "interior part" of the "standard deviation of the"
4460 C gamma-dependent Gaussian lobe in t_c.
4461         sigtc=3*polthet(3,it)
4462         do j=2,1,-1
4463           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4464         enddo
4465         sigtc=sig*sigtc
4466 C Set the parameters of both Gaussian lobes of the distribution.
4467 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4468         fac=sig*sig+sigc0(it)
4469         sigcsq=fac+fac
4470         sigc=1.0D0/sigcsq
4471 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4472         sigsqtc=-4.0D0*sigcsq*sigtc
4473 c       print *,i,sig,sigtc,sigsqtc
4474 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4475         sigtc=-sigtc/(fac*fac)
4476 C Following variable is sigma(t_c)**(-2)
4477         sigcsq=sigcsq*sigcsq
4478         sig0i=sig0(it)
4479         sig0inv=1.0D0/sig0i**2
4480         delthec=thetai-thet_pred_mean
4481         delthe0=thetai-theta0i
4482         term1=-0.5D0*sigcsq*delthec*delthec
4483         term2=-0.5D0*sig0inv*delthe0*delthe0
4484 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4485 C NaNs in taking the logarithm. We extract the largest exponent which is added
4486 C to the energy (this being the log of the distribution) at the end of energy
4487 C term evaluation for this virtual-bond angle.
4488         if (term1.gt.term2) then
4489           termm=term1
4490           term2=dexp(term2-termm)
4491           term1=1.0d0
4492         else
4493           termm=term2
4494           term1=dexp(term1-termm)
4495           term2=1.0d0
4496         endif
4497 C The ratio between the gamma-independent and gamma-dependent lobes of
4498 C the distribution is a Gaussian function of thet_pred_mean too.
4499         diffak=gthet(2,it)-thet_pred_mean
4500         ratak=diffak/gthet(3,it)**2
4501         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4502 C Let's differentiate it in thet_pred_mean NOW.
4503         aktc=ak*ratak
4504 C Now put together the distribution terms to make complete distribution.
4505         termexp=term1+ak*term2
4506         termpre=sigc+ak*sig0i
4507 C Contribution of the bending energy from this theta is just the -log of
4508 C the sum of the contributions from the two lobes and the pre-exponential
4509 C factor. Simple enough, isn't it?
4510         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4511 C NOW the derivatives!!!
4512 C 6/6/97 Take into account the deformation.
4513         E_theta=(delthec*sigcsq*term1
4514      &       +ak*delthe0*sig0inv*term2)/termexp
4515         E_tc=((sigtc+aktc*sig0i)/termpre
4516      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4517      &       aktc*term2)/termexp)
4518       return
4519       end
4520 c-----------------------------------------------------------------------------
4521       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4522       implicit real*8 (a-h,o-z)
4523       include 'DIMENSIONS'
4524       include 'COMMON.LOCAL'
4525       include 'COMMON.IOUNITS'
4526       common /calcthet/ term1,term2,termm,diffak,ratak,
4527      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4528      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4529       delthec=thetai-thet_pred_mean
4530       delthe0=thetai-theta0i
4531 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4532       t3 = thetai-thet_pred_mean
4533       t6 = t3**2
4534       t9 = term1
4535       t12 = t3*sigcsq
4536       t14 = t12+t6*sigsqtc
4537       t16 = 1.0d0
4538       t21 = thetai-theta0i
4539       t23 = t21**2
4540       t26 = term2
4541       t27 = t21*t26
4542       t32 = termexp
4543       t40 = t32**2
4544       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4545      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4546      & *(-t12*t9-ak*sig0inv*t27)
4547       return
4548       end
4549 #else
4550 C--------------------------------------------------------------------------
4551       subroutine ebend(etheta)
4552 C
4553 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4554 C angles gamma and its derivatives in consecutive thetas and gammas.
4555 C ab initio-derived potentials from
4556 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4557 C
4558       implicit real*8 (a-h,o-z)
4559       include 'DIMENSIONS'
4560       include 'COMMON.LOCAL'
4561       include 'COMMON.GEO'
4562       include 'COMMON.INTERACT'
4563       include 'COMMON.DERIV'
4564       include 'COMMON.VAR'
4565       include 'COMMON.CHAIN'
4566       include 'COMMON.IOUNITS'
4567       include 'COMMON.NAMES'
4568       include 'COMMON.FFIELD'
4569       include 'COMMON.CONTROL'
4570       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4571      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4572      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4573      & sinph1ph2(maxdouble,maxdouble)
4574       logical lprn /.false./, lprn1 /.false./
4575       etheta=0.0D0
4576       do i=ithet_start,ithet_end
4577         if (itype(i-1).eq.ntyp1) cycle
4578         if (iabs(itype(i+1)).eq.20) iblock=2
4579         if (iabs(itype(i+1)).ne.20) iblock=1
4580         dethetai=0.0d0
4581         dephii=0.0d0
4582         dephii1=0.0d0
4583         theti2=0.5d0*theta(i)
4584         ityp2=ithetyp((itype(i-1)))
4585         do k=1,nntheterm
4586           coskt(k)=dcos(k*theti2)
4587           sinkt(k)=dsin(k*theti2)
4588         enddo
4589         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4590 #ifdef OSF
4591           phii=phi(i)
4592           if (phii.ne.phii) phii=150.0
4593 #else
4594           phii=phi(i)
4595 #endif
4596           ityp1=ithetyp((itype(i-2)))
4597 C propagation of chirality for glycine type
4598           do k=1,nsingle
4599             cosph1(k)=dcos(k*phii)
4600             sinph1(k)=dsin(k*phii)
4601           enddo
4602         else
4603           phii=0.0d0
4604           ityp1=nthetyp+1
4605           do k=1,nsingle
4606             cosph1(k)=0.0d0
4607             sinph1(k)=0.0d0
4608           enddo
4609         endif
4610         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4611 #ifdef OSF
4612           phii1=phi(i+1)
4613           if (phii1.ne.phii1) phii1=150.0
4614           phii1=pinorm(phii1)
4615 #else
4616           phii1=phi(i+1)
4617 #endif
4618           ityp3=ithetyp((itype(i)))
4619           do k=1,nsingle
4620             cosph2(k)=dcos(k*phii1)
4621             sinph2(k)=dsin(k*phii1)
4622           enddo
4623         else
4624           phii1=0.0d0
4625           ityp3=nthetyp+1
4626           do k=1,nsingle
4627             cosph2(k)=0.0d0
4628             sinph2(k)=0.0d0
4629           enddo
4630         endif
4631         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4632         do k=1,ndouble
4633           do l=1,k-1
4634             ccl=cosph1(l)*cosph2(k-l)
4635             ssl=sinph1(l)*sinph2(k-l)
4636             scl=sinph1(l)*cosph2(k-l)
4637             csl=cosph1(l)*sinph2(k-l)
4638             cosph1ph2(l,k)=ccl-ssl
4639             cosph1ph2(k,l)=ccl+ssl
4640             sinph1ph2(l,k)=scl+csl
4641             sinph1ph2(k,l)=scl-csl
4642           enddo
4643         enddo
4644         if (lprn) then
4645         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4646      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4647         write (iout,*) "coskt and sinkt"
4648         do k=1,nntheterm
4649           write (iout,*) k,coskt(k),sinkt(k)
4650         enddo
4651         endif
4652         do k=1,ntheterm
4653           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4654           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4655      &      *coskt(k)
4656           if (lprn)
4657      &    write (iout,*) "k",k,"
4658      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4659      &     " ethetai",ethetai
4660         enddo
4661         if (lprn) then
4662         write (iout,*) "cosph and sinph"
4663         do k=1,nsingle
4664           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4665         enddo
4666         write (iout,*) "cosph1ph2 and sinph2ph2"
4667         do k=2,ndouble
4668           do l=1,k-1
4669             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4670      &         sinph1ph2(l,k),sinph1ph2(k,l)
4671           enddo
4672         enddo
4673         write(iout,*) "ethetai",ethetai
4674         endif
4675         do m=1,ntheterm2
4676           do k=1,nsingle
4677             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4678      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4679      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4680      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4681             ethetai=ethetai+sinkt(m)*aux
4682             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4683             dephii=dephii+k*sinkt(m)*(
4684      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4685      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4686             dephii1=dephii1+k*sinkt(m)*(
4687      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4688      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4689             if (lprn)
4690      &      write (iout,*) "m",m," k",k," bbthet",
4691      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4692      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4693      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4694      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4695           enddo
4696         enddo
4697         if (lprn)
4698      &  write(iout,*) "ethetai",ethetai
4699         do m=1,ntheterm3
4700           do k=2,ndouble
4701             do l=1,k-1
4702               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4703      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4704      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4705      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4706               ethetai=ethetai+sinkt(m)*aux
4707               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4708               dephii=dephii+l*sinkt(m)*(
4709      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4710      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4711      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4712      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4713               dephii1=dephii1+(k-l)*sinkt(m)*(
4714      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4715      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4716      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4717      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4718               if (lprn) then
4719               write (iout,*) "m",m," k",k," l",l," ffthet",
4720      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4721      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4722      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4723      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4724      &            " ethetai",ethetai
4725               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4726      &            cosph1ph2(k,l)*sinkt(m),
4727      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4728               endif
4729             enddo
4730           enddo
4731         enddo
4732 10      continue
4733 c        lprn1=.true.
4734         if (lprn1)
4735      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4736      &   i,theta(i)*rad2deg,phii*rad2deg,
4737      &   phii1*rad2deg,ethetai
4738 c        lprn1=.false.
4739         etheta=etheta+ethetai
4740         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4741         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4742         gloc(nphi+i-2,icg)=wang*dethetai
4743       enddo
4744       return
4745       end
4746 #endif
4747 #ifdef CRYST_SC
4748 c-----------------------------------------------------------------------------
4749       subroutine esc(escloc)
4750 C Calculate the local energy of a side chain and its derivatives in the
4751 C corresponding virtual-bond valence angles THETA and the spherical angles
4752 C ALPHA and OMEGA.
4753       implicit real*8 (a-h,o-z)
4754       include 'DIMENSIONS'
4755       include 'COMMON.GEO'
4756       include 'COMMON.LOCAL'
4757       include 'COMMON.VAR'
4758       include 'COMMON.INTERACT'
4759       include 'COMMON.DERIV'
4760       include 'COMMON.CHAIN'
4761       include 'COMMON.IOUNITS'
4762       include 'COMMON.NAMES'
4763       include 'COMMON.FFIELD'
4764       include 'COMMON.CONTROL'
4765       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4766      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4767       common /sccalc/ time11,time12,time112,theti,it,nlobit
4768       delta=0.02d0*pi
4769       escloc=0.0D0
4770 c     write (iout,'(a)') 'ESC'
4771       do i=loc_start,loc_end
4772         it=itype(i)
4773         if (it.eq.ntyp1) cycle
4774         if (it.eq.10) goto 1
4775         nlobit=nlob(iabs(it))
4776 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4777 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4778         theti=theta(i+1)-pipol
4779         x(1)=dtan(theti)
4780         x(2)=alph(i)
4781         x(3)=omeg(i)
4782
4783         if (x(2).gt.pi-delta) then
4784           xtemp(1)=x(1)
4785           xtemp(2)=pi-delta
4786           xtemp(3)=x(3)
4787           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4788           xtemp(2)=pi
4789           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4790           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4791      &        escloci,dersc(2))
4792           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4793      &        ddersc0(1),dersc(1))
4794           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4795      &        ddersc0(3),dersc(3))
4796           xtemp(2)=pi-delta
4797           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4798           xtemp(2)=pi
4799           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4800           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4801      &            dersc0(2),esclocbi,dersc02)
4802           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4803      &            dersc12,dersc01)
4804           call splinthet(x(2),0.5d0*delta,ss,ssd)
4805           dersc0(1)=dersc01
4806           dersc0(2)=dersc02
4807           dersc0(3)=0.0d0
4808           do k=1,3
4809             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4810           enddo
4811           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4812 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4813 c    &             esclocbi,ss,ssd
4814           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4815 c         escloci=esclocbi
4816 c         write (iout,*) escloci
4817         else if (x(2).lt.delta) then
4818           xtemp(1)=x(1)
4819           xtemp(2)=delta
4820           xtemp(3)=x(3)
4821           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4822           xtemp(2)=0.0d0
4823           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4824           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4825      &        escloci,dersc(2))
4826           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4827      &        ddersc0(1),dersc(1))
4828           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4829      &        ddersc0(3),dersc(3))
4830           xtemp(2)=delta
4831           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4832           xtemp(2)=0.0d0
4833           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4834           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4835      &            dersc0(2),esclocbi,dersc02)
4836           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4837      &            dersc12,dersc01)
4838           dersc0(1)=dersc01
4839           dersc0(2)=dersc02
4840           dersc0(3)=0.0d0
4841           call splinthet(x(2),0.5d0*delta,ss,ssd)
4842           do k=1,3
4843             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4844           enddo
4845           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4846 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4847 c    &             esclocbi,ss,ssd
4848           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4849 c         write (iout,*) escloci
4850         else
4851           call enesc(x,escloci,dersc,ddummy,.false.)
4852         endif
4853
4854         escloc=escloc+escloci
4855         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4856      &     'escloc',i,escloci
4857 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4858
4859         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4860      &   wscloc*dersc(1)
4861         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4862         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4863     1   continue
4864       enddo
4865       return
4866       end
4867 C---------------------------------------------------------------------------
4868       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4869       implicit real*8 (a-h,o-z)
4870       include 'DIMENSIONS'
4871       include 'COMMON.GEO'
4872       include 'COMMON.LOCAL'
4873       include 'COMMON.IOUNITS'
4874       common /sccalc/ time11,time12,time112,theti,it,nlobit
4875       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4876       double precision contr(maxlob,-1:1)
4877       logical mixed
4878 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4879         escloc_i=0.0D0
4880         do j=1,3
4881           dersc(j)=0.0D0
4882           if (mixed) ddersc(j)=0.0d0
4883         enddo
4884         x3=x(3)
4885
4886 C Because of periodicity of the dependence of the SC energy in omega we have
4887 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4888 C To avoid underflows, first compute & store the exponents.
4889
4890         do iii=-1,1
4891
4892           x(3)=x3+iii*dwapi
4893
4894           do j=1,nlobit
4895             do k=1,3
4896               z(k)=x(k)-censc(k,j,it)
4897             enddo
4898             do k=1,3
4899               Axk=0.0D0
4900               do l=1,3
4901                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4902               enddo
4903               Ax(k,j,iii)=Axk
4904             enddo
4905             expfac=0.0D0
4906             do k=1,3
4907               expfac=expfac+Ax(k,j,iii)*z(k)
4908             enddo
4909             contr(j,iii)=expfac
4910           enddo ! j
4911
4912         enddo ! iii
4913
4914         x(3)=x3
4915 C As in the case of ebend, we want to avoid underflows in exponentiation and
4916 C subsequent NaNs and INFs in energy calculation.
4917 C Find the largest exponent
4918         emin=contr(1,-1)
4919         do iii=-1,1
4920           do j=1,nlobit
4921             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4922           enddo
4923         enddo
4924         emin=0.5D0*emin
4925 cd      print *,'it=',it,' emin=',emin
4926
4927 C Compute the contribution to SC energy and derivatives
4928         do iii=-1,1
4929
4930           do j=1,nlobit
4931 #ifdef OSF
4932             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4933             if(adexp.ne.adexp) adexp=1.0
4934             expfac=dexp(adexp)
4935 #else
4936             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4937 #endif
4938 cd          print *,'j=',j,' expfac=',expfac
4939             escloc_i=escloc_i+expfac
4940             do k=1,3
4941               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4942             enddo
4943             if (mixed) then
4944               do k=1,3,2
4945                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4946      &            +gaussc(k,2,j,it))*expfac
4947               enddo
4948             endif
4949           enddo
4950
4951         enddo ! iii
4952
4953         dersc(1)=dersc(1)/cos(theti)**2
4954         ddersc(1)=ddersc(1)/cos(theti)**2
4955         ddersc(3)=ddersc(3)
4956
4957         escloci=-(dlog(escloc_i)-emin)
4958         do j=1,3
4959           dersc(j)=dersc(j)/escloc_i
4960         enddo
4961         if (mixed) then
4962           do j=1,3,2
4963             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4964           enddo
4965         endif
4966       return
4967       end
4968 C------------------------------------------------------------------------------
4969       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4970       implicit real*8 (a-h,o-z)
4971       include 'DIMENSIONS'
4972       include 'COMMON.GEO'
4973       include 'COMMON.LOCAL'
4974       include 'COMMON.IOUNITS'
4975       common /sccalc/ time11,time12,time112,theti,it,nlobit
4976       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4977       double precision contr(maxlob)
4978       logical mixed
4979
4980       escloc_i=0.0D0
4981
4982       do j=1,3
4983         dersc(j)=0.0D0
4984       enddo
4985
4986       do j=1,nlobit
4987         do k=1,2
4988           z(k)=x(k)-censc(k,j,it)
4989         enddo
4990         z(3)=dwapi
4991         do k=1,3
4992           Axk=0.0D0
4993           do l=1,3
4994             Axk=Axk+gaussc(l,k,j,it)*z(l)
4995           enddo
4996           Ax(k,j)=Axk
4997         enddo
4998         expfac=0.0D0
4999         do k=1,3
5000           expfac=expfac+Ax(k,j)*z(k)
5001         enddo
5002         contr(j)=expfac
5003       enddo ! j
5004
5005 C As in the case of ebend, we want to avoid underflows in exponentiation and
5006 C subsequent NaNs and INFs in energy calculation.
5007 C Find the largest exponent
5008       emin=contr(1)
5009       do j=1,nlobit
5010         if (emin.gt.contr(j)) emin=contr(j)
5011       enddo
5012       emin=0.5D0*emin
5013
5014 C Compute the contribution to SC energy and derivatives
5015
5016       dersc12=0.0d0
5017       do j=1,nlobit
5018         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5019         escloc_i=escloc_i+expfac
5020         do k=1,2
5021           dersc(k)=dersc(k)+Ax(k,j)*expfac
5022         enddo
5023         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5024      &            +gaussc(1,2,j,it))*expfac
5025         dersc(3)=0.0d0
5026       enddo
5027
5028       dersc(1)=dersc(1)/cos(theti)**2
5029       dersc12=dersc12/cos(theti)**2
5030       escloci=-(dlog(escloc_i)-emin)
5031       do j=1,2
5032         dersc(j)=dersc(j)/escloc_i
5033       enddo
5034       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5035       return
5036       end
5037 #else
5038 c----------------------------------------------------------------------------------
5039       subroutine esc(escloc)
5040 C Calculate the local energy of a side chain and its derivatives in the
5041 C corresponding virtual-bond valence angles THETA and the spherical angles
5042 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5043 C added by Urszula Kozlowska. 07/11/2007
5044 C
5045       implicit real*8 (a-h,o-z)
5046       include 'DIMENSIONS'
5047       include 'COMMON.GEO'
5048       include 'COMMON.LOCAL'
5049       include 'COMMON.VAR'
5050       include 'COMMON.SCROT'
5051       include 'COMMON.INTERACT'
5052       include 'COMMON.DERIV'
5053       include 'COMMON.CHAIN'
5054       include 'COMMON.IOUNITS'
5055       include 'COMMON.NAMES'
5056       include 'COMMON.FFIELD'
5057       include 'COMMON.CONTROL'
5058       include 'COMMON.VECTORS'
5059       double precision x_prime(3),y_prime(3),z_prime(3)
5060      &    , sumene,dsc_i,dp2_i,x(65),
5061      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5062      &    de_dxx,de_dyy,de_dzz,de_dt
5063       double precision s1_t,s1_6_t,s2_t,s2_6_t
5064       double precision
5065      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5066      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5067      & dt_dCi(3),dt_dCi1(3)
5068       common /sccalc/ time11,time12,time112,theti,it,nlobit
5069       delta=0.02d0*pi
5070       escloc=0.0D0
5071       do i=loc_start,loc_end
5072         if (itype(i).eq.ntyp1) cycle
5073         costtab(i+1) =dcos(theta(i+1))
5074         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5075         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5076         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5077         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5078         cosfac=dsqrt(cosfac2)
5079         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5080         sinfac=dsqrt(sinfac2)
5081         it=iabs(itype(i))
5082         if (it.eq.10) goto 1
5083 c
5084 C  Compute the axes of tghe local cartesian coordinates system; store in
5085 c   x_prime, y_prime and z_prime
5086 c
5087         do j=1,3
5088           x_prime(j) = 0.00
5089           y_prime(j) = 0.00
5090           z_prime(j) = 0.00
5091         enddo
5092 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5093 C     &   dc_norm(3,i+nres)
5094         do j = 1,3
5095           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5096           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5097         enddo
5098         do j = 1,3
5099           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5100         enddo
5101 c       write (2,*) "i",i
5102 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5103 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5104 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5105 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5106 c      & " xy",scalar(x_prime(1),y_prime(1)),
5107 c      & " xz",scalar(x_prime(1),z_prime(1)),
5108 c      & " yy",scalar(y_prime(1),y_prime(1)),
5109 c      & " yz",scalar(y_prime(1),z_prime(1)),
5110 c      & " zz",scalar(z_prime(1),z_prime(1))
5111 c
5112 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5113 C to local coordinate system. Store in xx, yy, zz.
5114 c
5115         xx=0.0d0
5116         yy=0.0d0
5117         zz=0.0d0
5118         do j = 1,3
5119           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5120           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5121           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5122         enddo
5123
5124         xxtab(i)=xx
5125         yytab(i)=yy
5126         zztab(i)=zz
5127 C
5128 C Compute the energy of the ith side cbain
5129 C
5130 c        write (2,*) "xx",xx," yy",yy," zz",zz
5131         it=iabs(itype(i))
5132         do j = 1,65
5133           x(j) = sc_parmin(j,it)
5134         enddo
5135 #ifdef CHECK_COORD
5136 Cc diagnostics - remove later
5137         xx1 = dcos(alph(2))
5138         yy1 = dsin(alph(2))*dcos(omeg(2))
5139         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5140         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5141      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5142      &    xx1,yy1,zz1
5143 C,"  --- ", xx_w,yy_w,zz_w
5144 c end diagnostics
5145 #endif
5146         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5147      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5148      &   + x(10)*yy*zz
5149         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5150      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5151      & + x(20)*yy*zz
5152         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5153      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5154      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5155      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5156      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5157      &  +x(40)*xx*yy*zz
5158         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5159      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5160      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5161      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5162      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5163      &  +x(60)*xx*yy*zz
5164         dsc_i   = 0.743d0+x(61)
5165         dp2_i   = 1.9d0+x(62)
5166         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5167      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5168         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5169      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5170         s1=(1+x(63))/(0.1d0 + dscp1)
5171         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5172         s2=(1+x(65))/(0.1d0 + dscp2)
5173         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5174         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5175      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5176 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5177 c     &   sumene4,
5178 c     &   dscp1,dscp2,sumene
5179 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5180         escloc = escloc + sumene
5181 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5182 c     & ,zz,xx,yy
5183 c#define DEBUG
5184 #ifdef DEBUG
5185 C
5186 C This section to check the numerical derivatives of the energy of ith side
5187 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5188 C #define DEBUG in the code to turn it on.
5189 C
5190         write (2,*) "sumene               =",sumene
5191         aincr=1.0d-7
5192         xxsave=xx
5193         xx=xx+aincr
5194         write (2,*) xx,yy,zz
5195         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5196         de_dxx_num=(sumenep-sumene)/aincr
5197         xx=xxsave
5198         write (2,*) "xx+ sumene from enesc=",sumenep
5199         yysave=yy
5200         yy=yy+aincr
5201         write (2,*) xx,yy,zz
5202         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5203         de_dyy_num=(sumenep-sumene)/aincr
5204         yy=yysave
5205         write (2,*) "yy+ sumene from enesc=",sumenep
5206         zzsave=zz
5207         zz=zz+aincr
5208         write (2,*) xx,yy,zz
5209         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5210         de_dzz_num=(sumenep-sumene)/aincr
5211         zz=zzsave
5212         write (2,*) "zz+ sumene from enesc=",sumenep
5213         costsave=cost2tab(i+1)
5214         sintsave=sint2tab(i+1)
5215         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5216         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5217         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5218         de_dt_num=(sumenep-sumene)/aincr
5219         write (2,*) " t+ sumene from enesc=",sumenep
5220         cost2tab(i+1)=costsave
5221         sint2tab(i+1)=sintsave
5222 C End of diagnostics section.
5223 #endif
5224 C
5225 C Compute the gradient of esc
5226 C
5227 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5228         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5229         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5230         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5231         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5232         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5233         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5234         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5235         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5236         pom1=(sumene3*sint2tab(i+1)+sumene1)
5237      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5238         pom2=(sumene4*cost2tab(i+1)+sumene2)
5239      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5240         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5241         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5242      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5243      &  +x(40)*yy*zz
5244         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5245         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5246      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5247      &  +x(60)*yy*zz
5248         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5249      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5250      &        +(pom1+pom2)*pom_dx
5251 #ifdef DEBUG
5252         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5253 #endif
5254 C
5255         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5256         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5257      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5258      &  +x(40)*xx*zz
5259         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5260         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5261      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5262      &  +x(59)*zz**2 +x(60)*xx*zz
5263         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5264      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5265      &        +(pom1-pom2)*pom_dy
5266 #ifdef DEBUG
5267         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5268 #endif
5269 C
5270         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5271      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5272      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5273      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5274      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5275      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5276      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5277      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5278 #ifdef DEBUG
5279         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5280 #endif
5281 C
5282         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5283      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5284      &  +pom1*pom_dt1+pom2*pom_dt2
5285 #ifdef DEBUG
5286         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5287 #endif
5288 c#undef DEBUG
5289 c
5290 C
5291        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5292        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5293        cosfac2xx=cosfac2*xx
5294        sinfac2yy=sinfac2*yy
5295        do k = 1,3
5296          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5297      &      vbld_inv(i+1)
5298          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5299      &      vbld_inv(i)
5300          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5301          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5302 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5303 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5304 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5305 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5306          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5307          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5308          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5309          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5310          dZZ_Ci1(k)=0.0d0
5311          dZZ_Ci(k)=0.0d0
5312          do j=1,3
5313            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5314      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5315            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5316      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5317          enddo
5318
5319          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5320          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5321          dZZ_XYZ(k)=vbld_inv(i+nres)*
5322      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5323 c
5324          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5325          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5326        enddo
5327
5328        do k=1,3
5329          dXX_Ctab(k,i)=dXX_Ci(k)
5330          dXX_C1tab(k,i)=dXX_Ci1(k)
5331          dYY_Ctab(k,i)=dYY_Ci(k)
5332          dYY_C1tab(k,i)=dYY_Ci1(k)
5333          dZZ_Ctab(k,i)=dZZ_Ci(k)
5334          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5335          dXX_XYZtab(k,i)=dXX_XYZ(k)
5336          dYY_XYZtab(k,i)=dYY_XYZ(k)
5337          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5338        enddo
5339
5340        do k = 1,3
5341 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5342 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5343 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5344 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5345 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5346 c     &    dt_dci(k)
5347 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5348 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5349          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5350      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5351          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5352      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5353          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5354      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5355        enddo
5356 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5357 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5358
5359 C to check gradient call subroutine check_grad
5360
5361     1 continue
5362       enddo
5363       return
5364       end
5365 c------------------------------------------------------------------------------
5366       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5367       implicit none
5368       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5369      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5370       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5371      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5372      &   + x(10)*yy*zz
5373       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5374      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5375      & + x(20)*yy*zz
5376       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5377      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5378      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5379      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5380      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5381      &  +x(40)*xx*yy*zz
5382       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5383      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5384      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5385      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5386      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5387      &  +x(60)*xx*yy*zz
5388       dsc_i   = 0.743d0+x(61)
5389       dp2_i   = 1.9d0+x(62)
5390       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5391      &          *(xx*cost2+yy*sint2))
5392       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5393      &          *(xx*cost2-yy*sint2))
5394       s1=(1+x(63))/(0.1d0 + dscp1)
5395       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5396       s2=(1+x(65))/(0.1d0 + dscp2)
5397       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5398       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5399      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5400       enesc=sumene
5401       return
5402       end
5403 #endif
5404 c------------------------------------------------------------------------------
5405       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5406 C
5407 C This procedure calculates two-body contact function g(rij) and its derivative:
5408 C
5409 C           eps0ij                                     !       x < -1
5410 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5411 C            0                                         !       x > 1
5412 C
5413 C where x=(rij-r0ij)/delta
5414 C
5415 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5416 C
5417       implicit none
5418       double precision rij,r0ij,eps0ij,fcont,fprimcont
5419       double precision x,x2,x4,delta
5420 c     delta=0.02D0*r0ij
5421 c      delta=0.2D0*r0ij
5422       x=(rij-r0ij)/delta
5423       if (x.lt.-1.0D0) then
5424         fcont=eps0ij
5425         fprimcont=0.0D0
5426       else if (x.le.1.0D0) then
5427         x2=x*x
5428         x4=x2*x2
5429         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5430         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5431       else
5432         fcont=0.0D0
5433         fprimcont=0.0D0
5434       endif
5435       return
5436       end
5437 c------------------------------------------------------------------------------
5438       subroutine splinthet(theti,delta,ss,ssder)
5439       implicit real*8 (a-h,o-z)
5440       include 'DIMENSIONS'
5441       include 'COMMON.VAR'
5442       include 'COMMON.GEO'
5443       thetup=pi-delta
5444       thetlow=delta
5445       if (theti.gt.pipol) then
5446         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5447       else
5448         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5449         ssder=-ssder
5450       endif
5451       return
5452       end
5453 c------------------------------------------------------------------------------
5454       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5455       implicit none
5456       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5457       double precision ksi,ksi2,ksi3,a1,a2,a3
5458       a1=fprim0*delta/(f1-f0)
5459       a2=3.0d0-2.0d0*a1
5460       a3=a1-2.0d0
5461       ksi=(x-x0)/delta
5462       ksi2=ksi*ksi
5463       ksi3=ksi2*ksi
5464       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5465       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5466       return
5467       end
5468 c------------------------------------------------------------------------------
5469       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5470       implicit none
5471       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5472       double precision ksi,ksi2,ksi3,a1,a2,a3
5473       ksi=(x-x0)/delta
5474       ksi2=ksi*ksi
5475       ksi3=ksi2*ksi
5476       a1=fprim0x*delta
5477       a2=3*(f1x-f0x)-2*fprim0x*delta
5478       a3=fprim0x*delta-2*(f1x-f0x)
5479       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5480       return
5481       end
5482 C-----------------------------------------------------------------------------
5483 #ifdef CRYST_TOR
5484 C-----------------------------------------------------------------------------
5485       subroutine etor(etors,edihcnstr)
5486       implicit real*8 (a-h,o-z)
5487       include 'DIMENSIONS'
5488       include 'COMMON.VAR'
5489       include 'COMMON.GEO'
5490       include 'COMMON.LOCAL'
5491       include 'COMMON.TORSION'
5492       include 'COMMON.INTERACT'
5493       include 'COMMON.DERIV'
5494       include 'COMMON.CHAIN'
5495       include 'COMMON.NAMES'
5496       include 'COMMON.IOUNITS'
5497       include 'COMMON.FFIELD'
5498       include 'COMMON.TORCNSTR'
5499       include 'COMMON.CONTROL'
5500       logical lprn
5501 C Set lprn=.true. for debugging
5502       lprn=.false.
5503 c      lprn=.true.
5504       etors=0.0D0
5505       do i=iphi_start,iphi_end
5506       etors_ii=0.0D0
5507         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5508      &      .or. itype(i).eq.ntyp1) cycle
5509         itori=itortyp(itype(i-2))
5510         itori1=itortyp(itype(i-1))
5511         phii=phi(i)
5512         gloci=0.0D0
5513 C Proline-Proline pair is a special case...
5514         if (itori.eq.3 .and. itori1.eq.3) then
5515           if (phii.gt.-dwapi3) then
5516             cosphi=dcos(3*phii)
5517             fac=1.0D0/(1.0D0-cosphi)
5518             etorsi=v1(1,3,3)*fac
5519             etorsi=etorsi+etorsi
5520             etors=etors+etorsi-v1(1,3,3)
5521             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5522             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5523           endif
5524           do j=1,3
5525             v1ij=v1(j+1,itori,itori1)
5526             v2ij=v2(j+1,itori,itori1)
5527             cosphi=dcos(j*phii)
5528             sinphi=dsin(j*phii)
5529             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5530             if (energy_dec) etors_ii=etors_ii+
5531      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5532             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5533           enddo
5534         else
5535           do j=1,nterm_old
5536             v1ij=v1(j,itori,itori1)
5537             v2ij=v2(j,itori,itori1)
5538             cosphi=dcos(j*phii)
5539             sinphi=dsin(j*phii)
5540             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5541             if (energy_dec) etors_ii=etors_ii+
5542      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5543             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5544           enddo
5545         endif
5546         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5547              'etor',i,etors_ii
5548         if (lprn)
5549      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5550      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5551      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5552         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5553 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5554       enddo
5555 ! 6/20/98 - dihedral angle constraints
5556       edihcnstr=0.0d0
5557       do i=1,ndih_constr
5558         itori=idih_constr(i)
5559         phii=phi(itori)
5560         difi=phii-phi0(i)
5561         if (difi.gt.drange(i)) then
5562           difi=difi-drange(i)
5563           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5564           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5565         else if (difi.lt.-drange(i)) then
5566           difi=difi+drange(i)
5567           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5568           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5569         endif
5570 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5571 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5572       enddo
5573 !      write (iout,*) 'edihcnstr',edihcnstr
5574       return
5575       end
5576 c------------------------------------------------------------------------------
5577       subroutine etor_d(etors_d)
5578       etors_d=0.0d0
5579       return
5580       end
5581 c----------------------------------------------------------------------------
5582 #else
5583       subroutine etor(etors,edihcnstr)
5584       implicit real*8 (a-h,o-z)
5585       include 'DIMENSIONS'
5586       include 'COMMON.VAR'
5587       include 'COMMON.GEO'
5588       include 'COMMON.LOCAL'
5589       include 'COMMON.TORSION'
5590       include 'COMMON.INTERACT'
5591       include 'COMMON.DERIV'
5592       include 'COMMON.CHAIN'
5593       include 'COMMON.NAMES'
5594       include 'COMMON.IOUNITS'
5595       include 'COMMON.FFIELD'
5596       include 'COMMON.TORCNSTR'
5597       include 'COMMON.CONTROL'
5598       logical lprn
5599 C Set lprn=.true. for debugging
5600       lprn=.false.
5601 c     lprn=.true.
5602       etors=0.0D0
5603       do i=iphi_start,iphi_end
5604         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5605      &       .or. itype(i).eq.ntyp1) cycle
5606         etors_ii=0.0D0
5607          if (iabs(itype(i)).eq.20) then
5608          iblock=2
5609          else
5610          iblock=1
5611          endif
5612         itori=itortyp(itype(i-2))
5613         itori1=itortyp(itype(i-1))
5614         phii=phi(i)
5615         gloci=0.0D0
5616 C Regular cosine and sine terms
5617         do j=1,nterm(itori,itori1,iblock)
5618           v1ij=v1(j,itori,itori1,iblock)
5619           v2ij=v2(j,itori,itori1,iblock)
5620           cosphi=dcos(j*phii)
5621           sinphi=dsin(j*phii)
5622           etors=etors+v1ij*cosphi+v2ij*sinphi
5623           if (energy_dec) etors_ii=etors_ii+
5624      &                v1ij*cosphi+v2ij*sinphi
5625           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5626         enddo
5627 C Lorentz terms
5628 C                         v1
5629 C  E = SUM ----------------------------------- - v1
5630 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5631 C
5632         cosphi=dcos(0.5d0*phii)
5633         sinphi=dsin(0.5d0*phii)
5634         do j=1,nlor(itori,itori1,iblock)
5635           vl1ij=vlor1(j,itori,itori1)
5636           vl2ij=vlor2(j,itori,itori1)
5637           vl3ij=vlor3(j,itori,itori1)
5638           pom=vl2ij*cosphi+vl3ij*sinphi
5639           pom1=1.0d0/(pom*pom+1.0d0)
5640           etors=etors+vl1ij*pom1
5641           if (energy_dec) etors_ii=etors_ii+
5642      &                vl1ij*pom1
5643           pom=-pom*pom1*pom1
5644           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5645         enddo
5646 C Subtract the constant term
5647         etors=etors-v0(itori,itori1,iblock)
5648           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5649      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5650         if (lprn)
5651      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5652      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5653      &  (v1(j,itori,itori1,iblock),j=1,6),
5654      &  (v2(j,itori,itori1,iblock),j=1,6)
5655         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5656 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5657       enddo
5658 ! 6/20/98 - dihedral angle constraints
5659       edihcnstr=0.0d0
5660 c      do i=1,ndih_constr
5661       do i=idihconstr_start,idihconstr_end
5662         itori=idih_constr(i)
5663         phii=phi(itori)
5664         difi=pinorm(phii-phi0(i))
5665         if (difi.gt.drange(i)) then
5666           difi=difi-drange(i)
5667           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5668           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5669         else if (difi.lt.-drange(i)) then
5670           difi=difi+drange(i)
5671           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5672           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5673         else
5674           difi=0.0
5675         endif
5676 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5677 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5678 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5679       enddo
5680 cd       write (iout,*) 'edihcnstr',edihcnstr
5681       return
5682       end
5683 c----------------------------------------------------------------------------
5684       subroutine etor_d(etors_d)
5685 C 6/23/01 Compute double torsional energy
5686       implicit real*8 (a-h,o-z)
5687       include 'DIMENSIONS'
5688       include 'COMMON.VAR'
5689       include 'COMMON.GEO'
5690       include 'COMMON.LOCAL'
5691       include 'COMMON.TORSION'
5692       include 'COMMON.INTERACT'
5693       include 'COMMON.DERIV'
5694       include 'COMMON.CHAIN'
5695       include 'COMMON.NAMES'
5696       include 'COMMON.IOUNITS'
5697       include 'COMMON.FFIELD'
5698       include 'COMMON.TORCNSTR'
5699       logical lprn
5700 C Set lprn=.true. for debugging
5701       lprn=.false.
5702 c     lprn=.true.
5703       etors_d=0.0D0
5704 c      write(iout,*) "a tu??"
5705       do i=iphid_start,iphid_end
5706         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5707      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5708         itori=itortyp(itype(i-2))
5709         itori1=itortyp(itype(i-1))
5710         itori2=itortyp(itype(i))
5711         phii=phi(i)
5712         phii1=phi(i+1)
5713         gloci1=0.0D0
5714         gloci2=0.0D0
5715         iblock=1
5716         if (iabs(itype(i+1)).eq.20) iblock=2
5717
5718 C Regular cosine and sine terms
5719         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5720           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5721           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5722           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5723           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5724           cosphi1=dcos(j*phii)
5725           sinphi1=dsin(j*phii)
5726           cosphi2=dcos(j*phii1)
5727           sinphi2=dsin(j*phii1)
5728           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5729      &     v2cij*cosphi2+v2sij*sinphi2
5730           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5731           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5732         enddo
5733         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5734           do l=1,k-1
5735             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5736             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5737             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5738             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5739             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5740             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5741             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5742             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5743             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5744      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5745             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5746      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5747             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5748      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5749           enddo
5750         enddo
5751         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5752         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5753       enddo
5754       return
5755       end
5756 #endif
5757 c------------------------------------------------------------------------------
5758       subroutine eback_sc_corr(esccor)
5759 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5760 c        conformational states; temporarily implemented as differences
5761 c        between UNRES torsional potentials (dependent on three types of
5762 c        residues) and the torsional potentials dependent on all 20 types
5763 c        of residues computed from AM1  energy surfaces of terminally-blocked
5764 c        amino-acid residues.
5765       implicit real*8 (a-h,o-z)
5766       include 'DIMENSIONS'
5767       include 'COMMON.VAR'
5768       include 'COMMON.GEO'
5769       include 'COMMON.LOCAL'
5770       include 'COMMON.TORSION'
5771       include 'COMMON.SCCOR'
5772       include 'COMMON.INTERACT'
5773       include 'COMMON.DERIV'
5774       include 'COMMON.CHAIN'
5775       include 'COMMON.NAMES'
5776       include 'COMMON.IOUNITS'
5777       include 'COMMON.FFIELD'
5778       include 'COMMON.CONTROL'
5779       logical lprn
5780 C Set lprn=.true. for debugging
5781       lprn=.false.
5782 c      lprn=.true.
5783 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5784       esccor=0.0D0
5785       do i=itau_start,itau_end
5786         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5787         esccor_ii=0.0D0
5788         isccori=isccortyp(itype(i-2))
5789         isccori1=isccortyp(itype(i-1))
5790 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5791         phii=phi(i)
5792         do intertyp=1,3 !intertyp
5793 cc Added 09 May 2012 (Adasko)
5794 cc  Intertyp means interaction type of backbone mainchain correlation:
5795 c   1 = SC...Ca...Ca...Ca
5796 c   2 = Ca...Ca...Ca...SC
5797 c   3 = SC...Ca...Ca...SCi
5798         gloci=0.0D0
5799         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5800      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5801      &      (itype(i-1).eq.ntyp1)))
5802      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5803      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5804      &     .or.(itype(i).eq.ntyp1)))
5805      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5806      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5807      &      (itype(i-3).eq.ntyp1)))) cycle
5808         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5809         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5810      & cycle
5811        do j=1,nterm_sccor(isccori,isccori1)
5812           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5813           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5814           cosphi=dcos(j*tauangle(intertyp,i))
5815           sinphi=dsin(j*tauangle(intertyp,i))
5816           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5817           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5818         enddo
5819 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5820         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5821         if (lprn)
5822      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5823      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5824      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5825      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5826         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5827        enddo !intertyp
5828       enddo
5829
5830       return
5831       end
5832 c----------------------------------------------------------------------------
5833       subroutine multibody(ecorr)
5834 C This subroutine calculates multi-body contributions to energy following
5835 C the idea of Skolnick et al. If side chains I and J make a contact and
5836 C at the same time side chains I+1 and J+1 make a contact, an extra
5837 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5838       implicit real*8 (a-h,o-z)
5839       include 'DIMENSIONS'
5840       include 'COMMON.IOUNITS'
5841       include 'COMMON.DERIV'
5842       include 'COMMON.INTERACT'
5843       include 'COMMON.CONTACTS'
5844       double precision gx(3),gx1(3)
5845       logical lprn
5846
5847 C Set lprn=.true. for debugging
5848       lprn=.false.
5849
5850       if (lprn) then
5851         write (iout,'(a)') 'Contact function values:'
5852         do i=nnt,nct-2
5853           write (iout,'(i2,20(1x,i2,f10.5))')
5854      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5855         enddo
5856       endif
5857       ecorr=0.0D0
5858       do i=nnt,nct
5859         do j=1,3
5860           gradcorr(j,i)=0.0D0
5861           gradxorr(j,i)=0.0D0
5862         enddo
5863       enddo
5864       do i=nnt,nct-2
5865
5866         DO ISHIFT = 3,4
5867
5868         i1=i+ishift
5869         num_conti=num_cont(i)
5870         num_conti1=num_cont(i1)
5871         do jj=1,num_conti
5872           j=jcont(jj,i)
5873           do kk=1,num_conti1
5874             j1=jcont(kk,i1)
5875             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5876 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5877 cd   &                   ' ishift=',ishift
5878 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5879 C The system gains extra energy.
5880               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5881             endif   ! j1==j+-ishift
5882           enddo     ! kk
5883         enddo       ! jj
5884
5885         ENDDO ! ISHIFT
5886
5887       enddo         ! i
5888       return
5889       end
5890 c------------------------------------------------------------------------------
5891       double precision function esccorr(i,j,k,l,jj,kk)
5892       implicit real*8 (a-h,o-z)
5893       include 'DIMENSIONS'
5894       include 'COMMON.IOUNITS'
5895       include 'COMMON.DERIV'
5896       include 'COMMON.INTERACT'
5897       include 'COMMON.CONTACTS'
5898       double precision gx(3),gx1(3)
5899       logical lprn
5900       lprn=.false.
5901       eij=facont(jj,i)
5902       ekl=facont(kk,k)
5903 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5904 C Calculate the multi-body contribution to energy.
5905 C Calculate multi-body contributions to the gradient.
5906 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5907 cd   & k,l,(gacont(m,kk,k),m=1,3)
5908       do m=1,3
5909         gx(m) =ekl*gacont(m,jj,i)
5910         gx1(m)=eij*gacont(m,kk,k)
5911         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5912         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5913         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5914         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5915       enddo
5916       do m=i,j-1
5917         do ll=1,3
5918           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5919         enddo
5920       enddo
5921       do m=k,l-1
5922         do ll=1,3
5923           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5924         enddo
5925       enddo
5926       esccorr=-eij*ekl
5927       return
5928       end
5929 c------------------------------------------------------------------------------
5930       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5931 C This subroutine calculates multi-body contributions to hydrogen-bonding
5932       implicit real*8 (a-h,o-z)
5933       include 'DIMENSIONS'
5934       include 'COMMON.IOUNITS'
5935 #ifdef MPI
5936       include "mpif.h"
5937       parameter (max_cont=maxconts)
5938       parameter (max_dim=26)
5939       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5940       double precision zapas(max_dim,maxconts,max_fg_procs),
5941      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5942       common /przechowalnia/ zapas
5943       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5944      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5945 #endif
5946       include 'COMMON.SETUP'
5947       include 'COMMON.FFIELD'
5948       include 'COMMON.DERIV'
5949       include 'COMMON.INTERACT'
5950       include 'COMMON.CONTACTS'
5951       include 'COMMON.CONTROL'
5952       include 'COMMON.LOCAL'
5953       double precision gx(3),gx1(3),time00
5954       logical lprn,ldone
5955
5956 C Set lprn=.true. for debugging
5957       lprn=.false.
5958 #ifdef MPI
5959       n_corr=0
5960       n_corr1=0
5961       if (nfgtasks.le.1) goto 30
5962       if (lprn) then
5963         write (iout,'(a)') 'Contact function values before RECEIVE:'
5964         do i=nnt,nct-2
5965           write (iout,'(2i3,50(1x,i2,f5.2))')
5966      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5967      &    j=1,num_cont_hb(i))
5968         enddo
5969       endif
5970       call flush(iout)
5971       do i=1,ntask_cont_from
5972         ncont_recv(i)=0
5973       enddo
5974       do i=1,ntask_cont_to
5975         ncont_sent(i)=0
5976       enddo
5977 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5978 c     & ntask_cont_to
5979 C Make the list of contacts to send to send to other procesors
5980 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5981 c      call flush(iout)
5982       do i=iturn3_start,iturn3_end
5983 c        write (iout,*) "make contact list turn3",i," num_cont",
5984 c     &    num_cont_hb(i)
5985         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5986       enddo
5987       do i=iturn4_start,iturn4_end
5988 c        write (iout,*) "make contact list turn4",i," num_cont",
5989 c     &   num_cont_hb(i)
5990         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5991       enddo
5992       do ii=1,nat_sent
5993         i=iat_sent(ii)
5994 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5995 c     &    num_cont_hb(i)
5996         do j=1,num_cont_hb(i)
5997         do k=1,4
5998           jjc=jcont_hb(j,i)
5999           iproc=iint_sent_local(k,jjc,ii)
6000 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6001           if (iproc.gt.0) then
6002             ncont_sent(iproc)=ncont_sent(iproc)+1
6003             nn=ncont_sent(iproc)
6004             zapas(1,nn,iproc)=i
6005             zapas(2,nn,iproc)=jjc
6006             zapas(3,nn,iproc)=facont_hb(j,i)
6007             zapas(4,nn,iproc)=ees0p(j,i)
6008             zapas(5,nn,iproc)=ees0m(j,i)
6009             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6010             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6011             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6012             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6013             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6014             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6015             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6016             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6017             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6018             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6019             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6020             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6021             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6022             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6023             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6024             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6025             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6026             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6027             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6028             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6029             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6030           endif
6031         enddo
6032         enddo
6033       enddo
6034       if (lprn) then
6035       write (iout,*)
6036      &  "Numbers of contacts to be sent to other processors",
6037      &  (ncont_sent(i),i=1,ntask_cont_to)
6038       write (iout,*) "Contacts sent"
6039       do ii=1,ntask_cont_to
6040         nn=ncont_sent(ii)
6041         iproc=itask_cont_to(ii)
6042         write (iout,*) nn," contacts to processor",iproc,
6043      &   " of CONT_TO_COMM group"
6044         do i=1,nn
6045           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6046         enddo
6047       enddo
6048       call flush(iout)
6049       endif
6050       CorrelType=477
6051       CorrelID=fg_rank+1
6052       CorrelType1=478
6053       CorrelID1=nfgtasks+fg_rank+1
6054       ireq=0
6055 C Receive the numbers of needed contacts from other processors
6056       do ii=1,ntask_cont_from
6057         iproc=itask_cont_from(ii)
6058         ireq=ireq+1
6059         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6060      &    FG_COMM,req(ireq),IERR)
6061       enddo
6062 c      write (iout,*) "IRECV ended"
6063 c      call flush(iout)
6064 C Send the number of contacts needed by other processors
6065       do ii=1,ntask_cont_to
6066         iproc=itask_cont_to(ii)
6067         ireq=ireq+1
6068         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6069      &    FG_COMM,req(ireq),IERR)
6070       enddo
6071 c      write (iout,*) "ISEND ended"
6072 c      write (iout,*) "number of requests (nn)",ireq
6073       call flush(iout)
6074       if (ireq.gt.0)
6075      &  call MPI_Waitall(ireq,req,status_array,ierr)
6076 c      write (iout,*)
6077 c     &  "Numbers of contacts to be received from other processors",
6078 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6079 c      call flush(iout)
6080 C Receive contacts
6081       ireq=0
6082       do ii=1,ntask_cont_from
6083         iproc=itask_cont_from(ii)
6084         nn=ncont_recv(ii)
6085 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6086 c     &   " of CONT_TO_COMM group"
6087         call flush(iout)
6088         if (nn.gt.0) then
6089           ireq=ireq+1
6090           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6091      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6092 c          write (iout,*) "ireq,req",ireq,req(ireq)
6093         endif
6094       enddo
6095 C Send the contacts to processors that need them
6096       do ii=1,ntask_cont_to
6097         iproc=itask_cont_to(ii)
6098         nn=ncont_sent(ii)
6099 c        write (iout,*) nn," contacts to processor",iproc,
6100 c     &   " of CONT_TO_COMM group"
6101         if (nn.gt.0) then
6102           ireq=ireq+1
6103           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6104      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6105 c          write (iout,*) "ireq,req",ireq,req(ireq)
6106 c          do i=1,nn
6107 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6108 c          enddo
6109         endif
6110       enddo
6111 c      write (iout,*) "number of requests (contacts)",ireq
6112 c      write (iout,*) "req",(req(i),i=1,4)
6113 c      call flush(iout)
6114       if (ireq.gt.0)
6115      & call MPI_Waitall(ireq,req,status_array,ierr)
6116       do iii=1,ntask_cont_from
6117         iproc=itask_cont_from(iii)
6118         nn=ncont_recv(iii)
6119         if (lprn) then
6120         write (iout,*) "Received",nn," contacts from processor",iproc,
6121      &   " of CONT_FROM_COMM group"
6122         call flush(iout)
6123         do i=1,nn
6124           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6125         enddo
6126         call flush(iout)
6127         endif
6128         do i=1,nn
6129           ii=zapas_recv(1,i,iii)
6130 c Flag the received contacts to prevent double-counting
6131           jj=-zapas_recv(2,i,iii)
6132 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6133 c          call flush(iout)
6134           nnn=num_cont_hb(ii)+1
6135           num_cont_hb(ii)=nnn
6136           jcont_hb(nnn,ii)=jj
6137           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6138           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6139           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6140           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6141           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6142           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6143           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6144           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6145           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6146           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6147           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6148           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6149           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6150           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6151           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6152           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6153           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6154           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6155           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6156           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6157           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6158           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6159           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6160           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6161         enddo
6162       enddo
6163       call flush(iout)
6164       if (lprn) then
6165         write (iout,'(a)') 'Contact function values after receive:'
6166         do i=nnt,nct-2
6167           write (iout,'(2i3,50(1x,i3,f5.2))')
6168      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6169      &    j=1,num_cont_hb(i))
6170         enddo
6171         call flush(iout)
6172       endif
6173    30 continue
6174 #endif
6175       if (lprn) then
6176         write (iout,'(a)') 'Contact function values:'
6177         do i=nnt,nct-2
6178           write (iout,'(2i3,50(1x,i3,f5.2))')
6179      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6180      &    j=1,num_cont_hb(i))
6181         enddo
6182       endif
6183       ecorr=0.0D0
6184 C Remove the loop below after debugging !!!
6185       do i=nnt,nct
6186         do j=1,3
6187           gradcorr(j,i)=0.0D0
6188           gradxorr(j,i)=0.0D0
6189         enddo
6190       enddo
6191 C Calculate the local-electrostatic correlation terms
6192       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6193         i1=i+1
6194         num_conti=num_cont_hb(i)
6195         num_conti1=num_cont_hb(i+1)
6196         do jj=1,num_conti
6197           j=jcont_hb(jj,i)
6198           jp=iabs(j)
6199           do kk=1,num_conti1
6200             j1=jcont_hb(kk,i1)
6201             jp1=iabs(j1)
6202 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6203 c     &         ' jj=',jj,' kk=',kk
6204             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6205      &          .or. j.lt.0 .and. j1.gt.0) .and.
6206      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6207 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6208 C The system gains extra energy.
6209               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6210               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6211      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6212               n_corr=n_corr+1
6213             else if (j1.eq.j) then
6214 C Contacts I-J and I-(J+1) occur simultaneously.
6215 C The system loses extra energy.
6216 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6217             endif
6218           enddo ! kk
6219           do kk=1,num_conti
6220             j1=jcont_hb(kk,i)
6221 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6222 c    &         ' jj=',jj,' kk=',kk
6223             if (j1.eq.j+1) then
6224 C Contacts I-J and (I+1)-J occur simultaneously.
6225 C The system loses extra energy.
6226 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6227             endif ! j1==j+1
6228           enddo ! kk
6229         enddo ! jj
6230       enddo ! i
6231       return
6232       end
6233 c------------------------------------------------------------------------------
6234       subroutine add_hb_contact(ii,jj,itask)
6235       implicit real*8 (a-h,o-z)
6236       include "DIMENSIONS"
6237       include "COMMON.IOUNITS"
6238       integer max_cont
6239       integer max_dim
6240       parameter (max_cont=maxconts)
6241       parameter (max_dim=26)
6242       include "COMMON.CONTACTS"
6243       double precision zapas(max_dim,maxconts,max_fg_procs),
6244      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6245       common /przechowalnia/ zapas
6246       integer i,j,ii,jj,iproc,itask(4),nn
6247 c      write (iout,*) "itask",itask
6248       do i=1,2
6249         iproc=itask(i)
6250         if (iproc.gt.0) then
6251           do j=1,num_cont_hb(ii)
6252             jjc=jcont_hb(j,ii)
6253 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6254             if (jjc.eq.jj) then
6255               ncont_sent(iproc)=ncont_sent(iproc)+1
6256               nn=ncont_sent(iproc)
6257               zapas(1,nn,iproc)=ii
6258               zapas(2,nn,iproc)=jjc
6259               zapas(3,nn,iproc)=facont_hb(j,ii)
6260               zapas(4,nn,iproc)=ees0p(j,ii)
6261               zapas(5,nn,iproc)=ees0m(j,ii)
6262               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6263               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6264               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6265               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6266               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6267               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6268               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6269               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6270               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6271               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6272               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6273               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6274               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6275               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6276               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6277               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6278               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6279               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6280               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6281               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6282               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6283               exit
6284             endif
6285           enddo
6286         endif
6287       enddo
6288       return
6289       end
6290 c------------------------------------------------------------------------------
6291       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6292      &  n_corr1)
6293 C This subroutine calculates multi-body contributions to hydrogen-bonding
6294       implicit real*8 (a-h,o-z)
6295       include 'DIMENSIONS'
6296       include 'COMMON.IOUNITS'
6297 #ifdef MPI
6298       include "mpif.h"
6299       parameter (max_cont=maxconts)
6300       parameter (max_dim=70)
6301       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6302       double precision zapas(max_dim,maxconts,max_fg_procs),
6303      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6304       common /przechowalnia/ zapas
6305       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6306      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6307 #endif
6308       include 'COMMON.SETUP'
6309       include 'COMMON.FFIELD'
6310       include 'COMMON.DERIV'
6311       include 'COMMON.LOCAL'
6312       include 'COMMON.INTERACT'
6313       include 'COMMON.CONTACTS'
6314       include 'COMMON.CHAIN'
6315       include 'COMMON.CONTROL'
6316       double precision gx(3),gx1(3)
6317       integer num_cont_hb_old(maxres)
6318       logical lprn,ldone
6319       double precision eello4,eello5,eelo6,eello_turn6
6320       external eello4,eello5,eello6,eello_turn6
6321 C Set lprn=.true. for debugging
6322       lprn=.false.
6323       eturn6=0.0d0
6324 #ifdef MPI
6325       do i=1,nres
6326         num_cont_hb_old(i)=num_cont_hb(i)
6327       enddo
6328       n_corr=0
6329       n_corr1=0
6330       if (nfgtasks.le.1) goto 30
6331       if (lprn) then
6332         write (iout,'(a)') 'Contact function values before RECEIVE:'
6333         do i=nnt,nct-2
6334           write (iout,'(2i3,50(1x,i2,f5.2))')
6335      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6336      &    j=1,num_cont_hb(i))
6337         enddo
6338       endif
6339       call flush(iout)
6340       do i=1,ntask_cont_from
6341         ncont_recv(i)=0
6342       enddo
6343       do i=1,ntask_cont_to
6344         ncont_sent(i)=0
6345       enddo
6346 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6347 c     & ntask_cont_to
6348 C Make the list of contacts to send to send to other procesors
6349       do i=iturn3_start,iturn3_end
6350 c        write (iout,*) "make contact list turn3",i," num_cont",
6351 c     &    num_cont_hb(i)
6352         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6353       enddo
6354       do i=iturn4_start,iturn4_end
6355 c        write (iout,*) "make contact list turn4",i," num_cont",
6356 c     &   num_cont_hb(i)
6357         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6358       enddo
6359       do ii=1,nat_sent
6360         i=iat_sent(ii)
6361 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6362 c     &    num_cont_hb(i)
6363         do j=1,num_cont_hb(i)
6364         do k=1,4
6365           jjc=jcont_hb(j,i)
6366           iproc=iint_sent_local(k,jjc,ii)
6367 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6368           if (iproc.ne.0) then
6369             ncont_sent(iproc)=ncont_sent(iproc)+1
6370             nn=ncont_sent(iproc)
6371             zapas(1,nn,iproc)=i
6372             zapas(2,nn,iproc)=jjc
6373             zapas(3,nn,iproc)=d_cont(j,i)
6374             ind=3
6375             do kk=1,3
6376               ind=ind+1
6377               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6378             enddo
6379             do kk=1,2
6380               do ll=1,2
6381                 ind=ind+1
6382                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6383               enddo
6384             enddo
6385             do jj=1,5
6386               do kk=1,3
6387                 do ll=1,2
6388                   do mm=1,2
6389                     ind=ind+1
6390                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6391                   enddo
6392                 enddo
6393               enddo
6394             enddo
6395           endif
6396         enddo
6397         enddo
6398       enddo
6399       if (lprn) then
6400       write (iout,*)
6401      &  "Numbers of contacts to be sent to other processors",
6402      &  (ncont_sent(i),i=1,ntask_cont_to)
6403       write (iout,*) "Contacts sent"
6404       do ii=1,ntask_cont_to
6405         nn=ncont_sent(ii)
6406         iproc=itask_cont_to(ii)
6407         write (iout,*) nn," contacts to processor",iproc,
6408      &   " of CONT_TO_COMM group"
6409         do i=1,nn
6410           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6411         enddo
6412       enddo
6413       call flush(iout)
6414       endif
6415       CorrelType=477
6416       CorrelID=fg_rank+1
6417       CorrelType1=478
6418       CorrelID1=nfgtasks+fg_rank+1
6419       ireq=0
6420 C Receive the numbers of needed contacts from other processors
6421       do ii=1,ntask_cont_from
6422         iproc=itask_cont_from(ii)
6423         ireq=ireq+1
6424         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6425      &    FG_COMM,req(ireq),IERR)
6426       enddo
6427 c      write (iout,*) "IRECV ended"
6428 c      call flush(iout)
6429 C Send the number of contacts needed by other processors
6430       do ii=1,ntask_cont_to
6431         iproc=itask_cont_to(ii)
6432         ireq=ireq+1
6433         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6434      &    FG_COMM,req(ireq),IERR)
6435       enddo
6436 c      write (iout,*) "ISEND ended"
6437 c      write (iout,*) "number of requests (nn)",ireq
6438       call flush(iout)
6439       if (ireq.gt.0)
6440      &  call MPI_Waitall(ireq,req,status_array,ierr)
6441 c      write (iout,*)
6442 c     &  "Numbers of contacts to be received from other processors",
6443 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6444 c      call flush(iout)
6445 C Receive contacts
6446       ireq=0
6447       do ii=1,ntask_cont_from
6448         iproc=itask_cont_from(ii)
6449         nn=ncont_recv(ii)
6450 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6451 c     &   " of CONT_TO_COMM group"
6452         call flush(iout)
6453         if (nn.gt.0) then
6454           ireq=ireq+1
6455           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6456      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6457 c          write (iout,*) "ireq,req",ireq,req(ireq)
6458         endif
6459       enddo
6460 C Send the contacts to processors that need them
6461       do ii=1,ntask_cont_to
6462         iproc=itask_cont_to(ii)
6463         nn=ncont_sent(ii)
6464 c        write (iout,*) nn," contacts to processor",iproc,
6465 c     &   " of CONT_TO_COMM group"
6466         if (nn.gt.0) then
6467           ireq=ireq+1
6468           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6469      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6470 c          write (iout,*) "ireq,req",ireq,req(ireq)
6471 c          do i=1,nn
6472 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6473 c          enddo
6474         endif
6475       enddo
6476 c      write (iout,*) "number of requests (contacts)",ireq
6477 c      write (iout,*) "req",(req(i),i=1,4)
6478 c      call flush(iout)
6479       if (ireq.gt.0)
6480      & call MPI_Waitall(ireq,req,status_array,ierr)
6481       do iii=1,ntask_cont_from
6482         iproc=itask_cont_from(iii)
6483         nn=ncont_recv(iii)
6484         if (lprn) then
6485         write (iout,*) "Received",nn," contacts from processor",iproc,
6486      &   " of CONT_FROM_COMM group"
6487         call flush(iout)
6488         do i=1,nn
6489           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6490         enddo
6491         call flush(iout)
6492         endif
6493         do i=1,nn
6494           ii=zapas_recv(1,i,iii)
6495 c Flag the received contacts to prevent double-counting
6496           jj=-zapas_recv(2,i,iii)
6497 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6498 c          call flush(iout)
6499           nnn=num_cont_hb(ii)+1
6500           num_cont_hb(ii)=nnn
6501           jcont_hb(nnn,ii)=jj
6502           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6503           ind=3
6504           do kk=1,3
6505             ind=ind+1
6506             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6507           enddo
6508           do kk=1,2
6509             do ll=1,2
6510               ind=ind+1
6511               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6512             enddo
6513           enddo
6514           do jj=1,5
6515             do kk=1,3
6516               do ll=1,2
6517                 do mm=1,2
6518                   ind=ind+1
6519                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6520                 enddo
6521               enddo
6522             enddo
6523           enddo
6524         enddo
6525       enddo
6526       call flush(iout)
6527       if (lprn) then
6528         write (iout,'(a)') 'Contact function values after receive:'
6529         do i=nnt,nct-2
6530           write (iout,'(2i3,50(1x,i3,5f6.3))')
6531      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6532      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6533         enddo
6534         call flush(iout)
6535       endif
6536    30 continue
6537 #endif
6538       if (lprn) then
6539         write (iout,'(a)') 'Contact function values:'
6540         do i=nnt,nct-2
6541           write (iout,'(2i3,50(1x,i2,5f6.3))')
6542      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6543      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6544         enddo
6545       endif
6546       ecorr=0.0D0
6547       ecorr5=0.0d0
6548       ecorr6=0.0d0
6549 C Remove the loop below after debugging !!!
6550       do i=nnt,nct
6551         do j=1,3
6552           gradcorr(j,i)=0.0D0
6553           gradxorr(j,i)=0.0D0
6554         enddo
6555       enddo
6556 C Calculate the dipole-dipole interaction energies
6557       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6558       do i=iatel_s,iatel_e+1
6559         num_conti=num_cont_hb(i)
6560         do jj=1,num_conti
6561           j=jcont_hb(jj,i)
6562 #ifdef MOMENT
6563           call dipole(i,j,jj)
6564 #endif
6565         enddo
6566       enddo
6567       endif
6568 C Calculate the local-electrostatic correlation terms
6569 c                write (iout,*) "gradcorr5 in eello5 before loop"
6570 c                do iii=1,nres
6571 c                  write (iout,'(i5,3f10.5)')
6572 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6573 c                enddo
6574       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6575 c        write (iout,*) "corr loop i",i
6576         i1=i+1
6577         num_conti=num_cont_hb(i)
6578         num_conti1=num_cont_hb(i+1)
6579         do jj=1,num_conti
6580           j=jcont_hb(jj,i)
6581           jp=iabs(j)
6582           do kk=1,num_conti1
6583             j1=jcont_hb(kk,i1)
6584             jp1=iabs(j1)
6585 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6586 c     &         ' jj=',jj,' kk=',kk
6587 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6588             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6589      &          .or. j.lt.0 .and. j1.gt.0) .and.
6590      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6591 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6592 C The system gains extra energy.
6593               n_corr=n_corr+1
6594               sqd1=dsqrt(d_cont(jj,i))
6595               sqd2=dsqrt(d_cont(kk,i1))
6596               sred_geom = sqd1*sqd2
6597               IF (sred_geom.lt.cutoff_corr) THEN
6598                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6599      &            ekont,fprimcont)
6600 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6601 cd     &         ' jj=',jj,' kk=',kk
6602                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6603                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6604                 do l=1,3
6605                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6606                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6607                 enddo
6608                 n_corr1=n_corr1+1
6609 cd               write (iout,*) 'sred_geom=',sred_geom,
6610 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6611 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6612 cd               write (iout,*) "g_contij",g_contij
6613 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6614 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6615                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6616                 if (wcorr4.gt.0.0d0)
6617      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6618                   if (energy_dec.and.wcorr4.gt.0.0d0)
6619      1                 write (iout,'(a6,4i5,0pf7.3)')
6620      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6621 c                write (iout,*) "gradcorr5 before eello5"
6622 c                do iii=1,nres
6623 c                  write (iout,'(i5,3f10.5)')
6624 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6625 c                enddo
6626                 if (wcorr5.gt.0.0d0)
6627      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6628 c                write (iout,*) "gradcorr5 after eello5"
6629 c                do iii=1,nres
6630 c                  write (iout,'(i5,3f10.5)')
6631 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6632 c                enddo
6633                   if (energy_dec.and.wcorr5.gt.0.0d0)
6634      1                 write (iout,'(a6,4i5,0pf7.3)')
6635      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6636 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6637 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6638                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6639      &               .or. wturn6.eq.0.0d0))then
6640 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6641                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6642                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6643      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6644 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6645 cd     &            'ecorr6=',ecorr6
6646 cd                write (iout,'(4e15.5)') sred_geom,
6647 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6648 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6649 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6650                 else if (wturn6.gt.0.0d0
6651      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6652 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6653                   eturn6=eturn6+eello_turn6(i,jj,kk)
6654                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6655      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6656 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6657                 endif
6658               ENDIF
6659 1111          continue
6660             endif
6661           enddo ! kk
6662         enddo ! jj
6663       enddo ! i
6664       do i=1,nres
6665         num_cont_hb(i)=num_cont_hb_old(i)
6666       enddo
6667 c                write (iout,*) "gradcorr5 in eello5"
6668 c                do iii=1,nres
6669 c                  write (iout,'(i5,3f10.5)')
6670 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6671 c                enddo
6672       return
6673       end
6674 c------------------------------------------------------------------------------
6675       subroutine add_hb_contact_eello(ii,jj,itask)
6676       implicit real*8 (a-h,o-z)
6677       include "DIMENSIONS"
6678       include "COMMON.IOUNITS"
6679       integer max_cont
6680       integer max_dim
6681       parameter (max_cont=maxconts)
6682       parameter (max_dim=70)
6683       include "COMMON.CONTACTS"
6684       double precision zapas(max_dim,maxconts,max_fg_procs),
6685      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6686       common /przechowalnia/ zapas
6687       integer i,j,ii,jj,iproc,itask(4),nn
6688 c      write (iout,*) "itask",itask
6689       do i=1,2
6690         iproc=itask(i)
6691         if (iproc.gt.0) then
6692           do j=1,num_cont_hb(ii)
6693             jjc=jcont_hb(j,ii)
6694 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6695             if (jjc.eq.jj) then
6696               ncont_sent(iproc)=ncont_sent(iproc)+1
6697               nn=ncont_sent(iproc)
6698               zapas(1,nn,iproc)=ii
6699               zapas(2,nn,iproc)=jjc
6700               zapas(3,nn,iproc)=d_cont(j,ii)
6701               ind=3
6702               do kk=1,3
6703                 ind=ind+1
6704                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6705               enddo
6706               do kk=1,2
6707                 do ll=1,2
6708                   ind=ind+1
6709                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6710                 enddo
6711               enddo
6712               do jj=1,5
6713                 do kk=1,3
6714                   do ll=1,2
6715                     do mm=1,2
6716                       ind=ind+1
6717                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6718                     enddo
6719                   enddo
6720                 enddo
6721               enddo
6722               exit
6723             endif
6724           enddo
6725         endif
6726       enddo
6727       return
6728       end
6729 c------------------------------------------------------------------------------
6730       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6731       implicit real*8 (a-h,o-z)
6732       include 'DIMENSIONS'
6733       include 'COMMON.IOUNITS'
6734       include 'COMMON.DERIV'
6735       include 'COMMON.INTERACT'
6736       include 'COMMON.CONTACTS'
6737       double precision gx(3),gx1(3)
6738       logical lprn
6739       lprn=.false.
6740       eij=facont_hb(jj,i)
6741       ekl=facont_hb(kk,k)
6742       ees0pij=ees0p(jj,i)
6743       ees0pkl=ees0p(kk,k)
6744       ees0mij=ees0m(jj,i)
6745       ees0mkl=ees0m(kk,k)
6746       ekont=eij*ekl
6747       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6748 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6749 C Following 4 lines for diagnostics.
6750 cd    ees0pkl=0.0D0
6751 cd    ees0pij=1.0D0
6752 cd    ees0mkl=0.0D0
6753 cd    ees0mij=1.0D0
6754 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6755 c     & 'Contacts ',i,j,
6756 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6757 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6758 c     & 'gradcorr_long'
6759 C Calculate the multi-body contribution to energy.
6760 c      ecorr=ecorr+ekont*ees
6761 C Calculate multi-body contributions to the gradient.
6762       coeffpees0pij=coeffp*ees0pij
6763       coeffmees0mij=coeffm*ees0mij
6764       coeffpees0pkl=coeffp*ees0pkl
6765       coeffmees0mkl=coeffm*ees0mkl
6766       do ll=1,3
6767 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6768         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6769      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6770      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6771         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6772      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6773      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6774 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6775         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6776      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6777      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6778         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6779      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6780      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6781         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6782      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6783      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6784         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6785         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6786         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6787      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6788      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6789         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6790         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6791 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6792       enddo
6793 c      write (iout,*)
6794 cgrad      do m=i+1,j-1
6795 cgrad        do ll=1,3
6796 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6797 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6798 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6799 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6800 cgrad        enddo
6801 cgrad      enddo
6802 cgrad      do m=k+1,l-1
6803 cgrad        do ll=1,3
6804 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6805 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6806 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6807 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6808 cgrad        enddo
6809 cgrad      enddo
6810 c      write (iout,*) "ehbcorr",ekont*ees
6811       ehbcorr=ekont*ees
6812       return
6813       end
6814 #ifdef MOMENT
6815 C---------------------------------------------------------------------------
6816       subroutine dipole(i,j,jj)
6817       implicit real*8 (a-h,o-z)
6818       include 'DIMENSIONS'
6819       include 'COMMON.IOUNITS'
6820       include 'COMMON.CHAIN'
6821       include 'COMMON.FFIELD'
6822       include 'COMMON.DERIV'
6823       include 'COMMON.INTERACT'
6824       include 'COMMON.CONTACTS'
6825       include 'COMMON.TORSION'
6826       include 'COMMON.VAR'
6827       include 'COMMON.GEO'
6828       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6829      &  auxmat(2,2)
6830       iti1 = itortyp(itype(i+1))
6831       if (j.lt.nres-1) then
6832         itj1 = itortyp(itype(j+1))
6833       else
6834         itj1=ntortyp+1
6835       endif
6836       do iii=1,2
6837         dipi(iii,1)=Ub2(iii,i)
6838         dipderi(iii)=Ub2der(iii,i)
6839         dipi(iii,2)=b1(iii,iti1)
6840         dipj(iii,1)=Ub2(iii,j)
6841         dipderj(iii)=Ub2der(iii,j)
6842         dipj(iii,2)=b1(iii,itj1)
6843       enddo
6844       kkk=0
6845       do iii=1,2
6846         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6847         do jjj=1,2
6848           kkk=kkk+1
6849           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6850         enddo
6851       enddo
6852       do kkk=1,5
6853         do lll=1,3
6854           mmm=0
6855           do iii=1,2
6856             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6857      &        auxvec(1))
6858             do jjj=1,2
6859               mmm=mmm+1
6860               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6861             enddo
6862           enddo
6863         enddo
6864       enddo
6865       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6866       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6867       do iii=1,2
6868         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6869       enddo
6870       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6871       do iii=1,2
6872         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6873       enddo
6874       return
6875       end
6876 #endif
6877 C---------------------------------------------------------------------------
6878       subroutine calc_eello(i,j,k,l,jj,kk)
6879 C
6880 C This subroutine computes matrices and vectors needed to calculate
6881 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6882 C
6883       implicit real*8 (a-h,o-z)
6884       include 'DIMENSIONS'
6885       include 'COMMON.IOUNITS'
6886       include 'COMMON.CHAIN'
6887       include 'COMMON.DERIV'
6888       include 'COMMON.INTERACT'
6889       include 'COMMON.CONTACTS'
6890       include 'COMMON.TORSION'
6891       include 'COMMON.VAR'
6892       include 'COMMON.GEO'
6893       include 'COMMON.FFIELD'
6894       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6895      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6896       logical lprn
6897       common /kutas/ lprn
6898 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6899 cd     & ' jj=',jj,' kk=',kk
6900 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6901 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6902 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6903       do iii=1,2
6904         do jjj=1,2
6905           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6906           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6907         enddo
6908       enddo
6909       call transpose2(aa1(1,1),aa1t(1,1))
6910       call transpose2(aa2(1,1),aa2t(1,1))
6911       do kkk=1,5
6912         do lll=1,3
6913           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6914      &      aa1tder(1,1,lll,kkk))
6915           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6916      &      aa2tder(1,1,lll,kkk))
6917         enddo
6918       enddo
6919       if (l.eq.j+1) then
6920 C parallel orientation of the two CA-CA-CA frames.
6921         if (i.gt.1) then
6922           iti=itortyp(itype(i))
6923         else
6924           iti=ntortyp+1
6925         endif
6926         itk1=itortyp(itype(k+1))
6927         itj=itortyp(itype(j))
6928         if (l.lt.nres-1) then
6929           itl1=itortyp(itype(l+1))
6930         else
6931           itl1=ntortyp+1
6932         endif
6933 C A1 kernel(j+1) A2T
6934 cd        do iii=1,2
6935 cd          write (iout,'(3f10.5,5x,3f10.5)')
6936 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6937 cd        enddo
6938         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6939      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6940      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6941 C Following matrices are needed only for 6-th order cumulants
6942         IF (wcorr6.gt.0.0d0) THEN
6943         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6944      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6945      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6946         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6947      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6948      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6949      &   ADtEAderx(1,1,1,1,1,1))
6950         lprn=.false.
6951         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6952      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6953      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6954      &   ADtEA1derx(1,1,1,1,1,1))
6955         ENDIF
6956 C End 6-th order cumulants
6957 cd        lprn=.false.
6958 cd        if (lprn) then
6959 cd        write (2,*) 'In calc_eello6'
6960 cd        do iii=1,2
6961 cd          write (2,*) 'iii=',iii
6962 cd          do kkk=1,5
6963 cd            write (2,*) 'kkk=',kkk
6964 cd            do jjj=1,2
6965 cd              write (2,'(3(2f10.5),5x)')
6966 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6967 cd            enddo
6968 cd          enddo
6969 cd        enddo
6970 cd        endif
6971         call transpose2(EUgder(1,1,k),auxmat(1,1))
6972         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6973         call transpose2(EUg(1,1,k),auxmat(1,1))
6974         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6975         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6976         do iii=1,2
6977           do kkk=1,5
6978             do lll=1,3
6979               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6980      &          EAEAderx(1,1,lll,kkk,iii,1))
6981             enddo
6982           enddo
6983         enddo
6984 C A1T kernel(i+1) A2
6985         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6986      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6987      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6988 C Following matrices are needed only for 6-th order cumulants
6989         IF (wcorr6.gt.0.0d0) THEN
6990         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6991      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6992      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6993         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6994      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6995      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6996      &   ADtEAderx(1,1,1,1,1,2))
6997         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6998      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6999      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7000      &   ADtEA1derx(1,1,1,1,1,2))
7001         ENDIF
7002 C End 6-th order cumulants
7003         call transpose2(EUgder(1,1,l),auxmat(1,1))
7004         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7005         call transpose2(EUg(1,1,l),auxmat(1,1))
7006         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7007         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7008         do iii=1,2
7009           do kkk=1,5
7010             do lll=1,3
7011               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7012      &          EAEAderx(1,1,lll,kkk,iii,2))
7013             enddo
7014           enddo
7015         enddo
7016 C AEAb1 and AEAb2
7017 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7018 C They are needed only when the fifth- or the sixth-order cumulants are
7019 C indluded.
7020         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7021         call transpose2(AEA(1,1,1),auxmat(1,1))
7022         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7023         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7024         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7025         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7026         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7027         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7028         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7029         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7030         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7031         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7032         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7033         call transpose2(AEA(1,1,2),auxmat(1,1))
7034         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7035         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7036         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7037         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7038         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7039         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7040         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7041         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7042         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7043         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7044         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7045 C Calculate the Cartesian derivatives of the vectors.
7046         do iii=1,2
7047           do kkk=1,5
7048             do lll=1,3
7049               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7050               call matvec2(auxmat(1,1),b1(1,iti),
7051      &          AEAb1derx(1,lll,kkk,iii,1,1))
7052               call matvec2(auxmat(1,1),Ub2(1,i),
7053      &          AEAb2derx(1,lll,kkk,iii,1,1))
7054               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7055      &          AEAb1derx(1,lll,kkk,iii,2,1))
7056               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7057      &          AEAb2derx(1,lll,kkk,iii,2,1))
7058               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7059               call matvec2(auxmat(1,1),b1(1,itj),
7060      &          AEAb1derx(1,lll,kkk,iii,1,2))
7061               call matvec2(auxmat(1,1),Ub2(1,j),
7062      &          AEAb2derx(1,lll,kkk,iii,1,2))
7063               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7064      &          AEAb1derx(1,lll,kkk,iii,2,2))
7065               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7066      &          AEAb2derx(1,lll,kkk,iii,2,2))
7067             enddo
7068           enddo
7069         enddo
7070         ENDIF
7071 C End vectors
7072       else
7073 C Antiparallel orientation of the two CA-CA-CA frames.
7074         if (i.gt.1) then
7075           iti=itortyp(itype(i))
7076         else
7077           iti=ntortyp+1
7078         endif
7079         itk1=itortyp(itype(k+1))
7080         itl=itortyp(itype(l))
7081         itj=itortyp(itype(j))
7082         if (j.lt.nres-1) then
7083           itj1=itortyp(itype(j+1))
7084         else
7085           itj1=ntortyp+1
7086         endif
7087 C A2 kernel(j-1)T A1T
7088         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7089      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7090      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7091 C Following matrices are needed only for 6-th order cumulants
7092         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7093      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7094         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7095      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7096      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7097         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7098      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7099      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7100      &   ADtEAderx(1,1,1,1,1,1))
7101         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7102      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7103      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7104      &   ADtEA1derx(1,1,1,1,1,1))
7105         ENDIF
7106 C End 6-th order cumulants
7107         call transpose2(EUgder(1,1,k),auxmat(1,1))
7108         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7109         call transpose2(EUg(1,1,k),auxmat(1,1))
7110         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7111         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7112         do iii=1,2
7113           do kkk=1,5
7114             do lll=1,3
7115               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7116      &          EAEAderx(1,1,lll,kkk,iii,1))
7117             enddo
7118           enddo
7119         enddo
7120 C A2T kernel(i+1)T A1
7121         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7122      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7123      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7124 C Following matrices are needed only for 6-th order cumulants
7125         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7126      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7127         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7128      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7129      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7130         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7131      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7132      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7133      &   ADtEAderx(1,1,1,1,1,2))
7134         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7135      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7136      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7137      &   ADtEA1derx(1,1,1,1,1,2))
7138         ENDIF
7139 C End 6-th order cumulants
7140         call transpose2(EUgder(1,1,j),auxmat(1,1))
7141         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7142         call transpose2(EUg(1,1,j),auxmat(1,1))
7143         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7144         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7145         do iii=1,2
7146           do kkk=1,5
7147             do lll=1,3
7148               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7149      &          EAEAderx(1,1,lll,kkk,iii,2))
7150             enddo
7151           enddo
7152         enddo
7153 C AEAb1 and AEAb2
7154 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7155 C They are needed only when the fifth- or the sixth-order cumulants are
7156 C indluded.
7157         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7158      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7159         call transpose2(AEA(1,1,1),auxmat(1,1))
7160         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7161         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7162         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7163         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7164         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7165         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7166         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7167         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7168         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7169         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7170         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7171         call transpose2(AEA(1,1,2),auxmat(1,1))
7172         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7173         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7174         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7175         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7176         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7177         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7178         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7179         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7180         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7181         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7182         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7183 C Calculate the Cartesian derivatives of the vectors.
7184         do iii=1,2
7185           do kkk=1,5
7186             do lll=1,3
7187               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7188               call matvec2(auxmat(1,1),b1(1,iti),
7189      &          AEAb1derx(1,lll,kkk,iii,1,1))
7190               call matvec2(auxmat(1,1),Ub2(1,i),
7191      &          AEAb2derx(1,lll,kkk,iii,1,1))
7192               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7193      &          AEAb1derx(1,lll,kkk,iii,2,1))
7194               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7195      &          AEAb2derx(1,lll,kkk,iii,2,1))
7196               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7197               call matvec2(auxmat(1,1),b1(1,itl),
7198      &          AEAb1derx(1,lll,kkk,iii,1,2))
7199               call matvec2(auxmat(1,1),Ub2(1,l),
7200      &          AEAb2derx(1,lll,kkk,iii,1,2))
7201               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7202      &          AEAb1derx(1,lll,kkk,iii,2,2))
7203               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7204      &          AEAb2derx(1,lll,kkk,iii,2,2))
7205             enddo
7206           enddo
7207         enddo
7208         ENDIF
7209 C End vectors
7210       endif
7211       return
7212       end
7213 C---------------------------------------------------------------------------
7214       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7215      &  KK,KKderg,AKA,AKAderg,AKAderx)
7216       implicit none
7217       integer nderg
7218       logical transp
7219       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7220      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7221      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7222       integer iii,kkk,lll
7223       integer jjj,mmm
7224       logical lprn
7225       common /kutas/ lprn
7226       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7227       do iii=1,nderg
7228         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7229      &    AKAderg(1,1,iii))
7230       enddo
7231 cd      if (lprn) write (2,*) 'In kernel'
7232       do kkk=1,5
7233 cd        if (lprn) write (2,*) 'kkk=',kkk
7234         do lll=1,3
7235           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7236      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7237 cd          if (lprn) then
7238 cd            write (2,*) 'lll=',lll
7239 cd            write (2,*) 'iii=1'
7240 cd            do jjj=1,2
7241 cd              write (2,'(3(2f10.5),5x)')
7242 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7243 cd            enddo
7244 cd          endif
7245           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7246      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7247 cd          if (lprn) then
7248 cd            write (2,*) 'lll=',lll
7249 cd            write (2,*) 'iii=2'
7250 cd            do jjj=1,2
7251 cd              write (2,'(3(2f10.5),5x)')
7252 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7253 cd            enddo
7254 cd          endif
7255         enddo
7256       enddo
7257       return
7258       end
7259 C---------------------------------------------------------------------------
7260       double precision function eello4(i,j,k,l,jj,kk)
7261       implicit real*8 (a-h,o-z)
7262       include 'DIMENSIONS'
7263       include 'COMMON.IOUNITS'
7264       include 'COMMON.CHAIN'
7265       include 'COMMON.DERIV'
7266       include 'COMMON.INTERACT'
7267       include 'COMMON.CONTACTS'
7268       include 'COMMON.TORSION'
7269       include 'COMMON.VAR'
7270       include 'COMMON.GEO'
7271       double precision pizda(2,2),ggg1(3),ggg2(3)
7272 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7273 cd        eello4=0.0d0
7274 cd        return
7275 cd      endif
7276 cd      print *,'eello4:',i,j,k,l,jj,kk
7277 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7278 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7279 cold      eij=facont_hb(jj,i)
7280 cold      ekl=facont_hb(kk,k)
7281 cold      ekont=eij*ekl
7282       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7283 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7284       gcorr_loc(k-1)=gcorr_loc(k-1)
7285      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7286       if (l.eq.j+1) then
7287         gcorr_loc(l-1)=gcorr_loc(l-1)
7288      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7289       else
7290         gcorr_loc(j-1)=gcorr_loc(j-1)
7291      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7292       endif
7293       do iii=1,2
7294         do kkk=1,5
7295           do lll=1,3
7296             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7297      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7298 cd            derx(lll,kkk,iii)=0.0d0
7299           enddo
7300         enddo
7301       enddo
7302 cd      gcorr_loc(l-1)=0.0d0
7303 cd      gcorr_loc(j-1)=0.0d0
7304 cd      gcorr_loc(k-1)=0.0d0
7305 cd      eel4=1.0d0
7306 cd      write (iout,*)'Contacts have occurred for peptide groups',
7307 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7308 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7309       if (j.lt.nres-1) then
7310         j1=j+1
7311         j2=j-1
7312       else
7313         j1=j-1
7314         j2=j-2
7315       endif
7316       if (l.lt.nres-1) then
7317         l1=l+1
7318         l2=l-1
7319       else
7320         l1=l-1
7321         l2=l-2
7322       endif
7323       do ll=1,3
7324 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7325 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7326         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7327         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7328 cgrad        ghalf=0.5d0*ggg1(ll)
7329         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7330         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7331         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7332         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7333         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7334         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7335 cgrad        ghalf=0.5d0*ggg2(ll)
7336         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7337         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7338         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7339         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7340         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7341         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7342       enddo
7343 cgrad      do m=i+1,j-1
7344 cgrad        do ll=1,3
7345 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7346 cgrad        enddo
7347 cgrad      enddo
7348 cgrad      do m=k+1,l-1
7349 cgrad        do ll=1,3
7350 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7351 cgrad        enddo
7352 cgrad      enddo
7353 cgrad      do m=i+2,j2
7354 cgrad        do ll=1,3
7355 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7356 cgrad        enddo
7357 cgrad      enddo
7358 cgrad      do m=k+2,l2
7359 cgrad        do ll=1,3
7360 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7361 cgrad        enddo
7362 cgrad      enddo
7363 cd      do iii=1,nres-3
7364 cd        write (2,*) iii,gcorr_loc(iii)
7365 cd      enddo
7366       eello4=ekont*eel4
7367 cd      write (2,*) 'ekont',ekont
7368 cd      write (iout,*) 'eello4',ekont*eel4
7369       return
7370       end
7371 C---------------------------------------------------------------------------
7372       double precision function eello5(i,j,k,l,jj,kk)
7373       implicit real*8 (a-h,o-z)
7374       include 'DIMENSIONS'
7375       include 'COMMON.IOUNITS'
7376       include 'COMMON.CHAIN'
7377       include 'COMMON.DERIV'
7378       include 'COMMON.INTERACT'
7379       include 'COMMON.CONTACTS'
7380       include 'COMMON.TORSION'
7381       include 'COMMON.VAR'
7382       include 'COMMON.GEO'
7383       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7384       double precision ggg1(3),ggg2(3)
7385 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7386 C                                                                              C
7387 C                            Parallel chains                                   C
7388 C                                                                              C
7389 C          o             o                   o             o                   C
7390 C         /l\           / \             \   / \           / \   /              C
7391 C        /   \         /   \             \ /   \         /   \ /               C
7392 C       j| o |l1       | o |              o| o |         | o |o                C
7393 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7394 C      \i/   \         /   \ /             /   \         /   \                 C
7395 C       o    k1             o                                                  C
7396 C         (I)          (II)                (III)          (IV)                 C
7397 C                                                                              C
7398 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7399 C                                                                              C
7400 C                            Antiparallel chains                               C
7401 C                                                                              C
7402 C          o             o                   o             o                   C
7403 C         /j\           / \             \   / \           / \   /              C
7404 C        /   \         /   \             \ /   \         /   \ /               C
7405 C      j1| o |l        | o |              o| o |         | o |o                C
7406 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7407 C      \i/   \         /   \ /             /   \         /   \                 C
7408 C       o     k1            o                                                  C
7409 C         (I)          (II)                (III)          (IV)                 C
7410 C                                                                              C
7411 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7412 C                                                                              C
7413 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7414 C                                                                              C
7415 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7416 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7417 cd        eello5=0.0d0
7418 cd        return
7419 cd      endif
7420 cd      write (iout,*)
7421 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7422 cd     &   ' and',k,l
7423       itk=itortyp(itype(k))
7424       itl=itortyp(itype(l))
7425       itj=itortyp(itype(j))
7426       eello5_1=0.0d0
7427       eello5_2=0.0d0
7428       eello5_3=0.0d0
7429       eello5_4=0.0d0
7430 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7431 cd     &   eel5_3_num,eel5_4_num)
7432       do iii=1,2
7433         do kkk=1,5
7434           do lll=1,3
7435             derx(lll,kkk,iii)=0.0d0
7436           enddo
7437         enddo
7438       enddo
7439 cd      eij=facont_hb(jj,i)
7440 cd      ekl=facont_hb(kk,k)
7441 cd      ekont=eij*ekl
7442 cd      write (iout,*)'Contacts have occurred for peptide groups',
7443 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7444 cd      goto 1111
7445 C Contribution from the graph I.
7446 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7447 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7448       call transpose2(EUg(1,1,k),auxmat(1,1))
7449       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7450       vv(1)=pizda(1,1)-pizda(2,2)
7451       vv(2)=pizda(1,2)+pizda(2,1)
7452       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7453      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7454 C Explicit gradient in virtual-dihedral angles.
7455       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7456      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7457      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7458       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7459       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7460       vv(1)=pizda(1,1)-pizda(2,2)
7461       vv(2)=pizda(1,2)+pizda(2,1)
7462       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7463      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7464      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7465       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7466       vv(1)=pizda(1,1)-pizda(2,2)
7467       vv(2)=pizda(1,2)+pizda(2,1)
7468       if (l.eq.j+1) then
7469         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7470      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7471      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7472       else
7473         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7474      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7475      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7476       endif
7477 C Cartesian gradient
7478       do iii=1,2
7479         do kkk=1,5
7480           do lll=1,3
7481             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7482      &        pizda(1,1))
7483             vv(1)=pizda(1,1)-pizda(2,2)
7484             vv(2)=pizda(1,2)+pizda(2,1)
7485             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7486      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7487      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7488           enddo
7489         enddo
7490       enddo
7491 c      goto 1112
7492 c1111  continue
7493 C Contribution from graph II
7494       call transpose2(EE(1,1,itk),auxmat(1,1))
7495       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7496       vv(1)=pizda(1,1)+pizda(2,2)
7497       vv(2)=pizda(2,1)-pizda(1,2)
7498       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7499      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7500 C Explicit gradient in virtual-dihedral angles.
7501       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7502      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7503       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7504       vv(1)=pizda(1,1)+pizda(2,2)
7505       vv(2)=pizda(2,1)-pizda(1,2)
7506       if (l.eq.j+1) then
7507         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7508      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7509      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7510       else
7511         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7512      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7513      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7514       endif
7515 C Cartesian gradient
7516       do iii=1,2
7517         do kkk=1,5
7518           do lll=1,3
7519             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7520      &        pizda(1,1))
7521             vv(1)=pizda(1,1)+pizda(2,2)
7522             vv(2)=pizda(2,1)-pizda(1,2)
7523             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7524      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7525      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7526           enddo
7527         enddo
7528       enddo
7529 cd      goto 1112
7530 cd1111  continue
7531       if (l.eq.j+1) then
7532 cd        goto 1110
7533 C Parallel orientation
7534 C Contribution from graph III
7535         call transpose2(EUg(1,1,l),auxmat(1,1))
7536         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7537         vv(1)=pizda(1,1)-pizda(2,2)
7538         vv(2)=pizda(1,2)+pizda(2,1)
7539         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7540      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7541 C Explicit gradient in virtual-dihedral angles.
7542         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7543      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7544      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7545         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7546         vv(1)=pizda(1,1)-pizda(2,2)
7547         vv(2)=pizda(1,2)+pizda(2,1)
7548         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7549      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7550      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7551         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7552         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7553         vv(1)=pizda(1,1)-pizda(2,2)
7554         vv(2)=pizda(1,2)+pizda(2,1)
7555         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7556      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7557      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7558 C Cartesian gradient
7559         do iii=1,2
7560           do kkk=1,5
7561             do lll=1,3
7562               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7563      &          pizda(1,1))
7564               vv(1)=pizda(1,1)-pizda(2,2)
7565               vv(2)=pizda(1,2)+pizda(2,1)
7566               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7567      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7568      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7569             enddo
7570           enddo
7571         enddo
7572 cd        goto 1112
7573 C Contribution from graph IV
7574 cd1110    continue
7575         call transpose2(EE(1,1,itl),auxmat(1,1))
7576         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7577         vv(1)=pizda(1,1)+pizda(2,2)
7578         vv(2)=pizda(2,1)-pizda(1,2)
7579         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7580      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7581 C Explicit gradient in virtual-dihedral angles.
7582         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7583      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7584         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7585         vv(1)=pizda(1,1)+pizda(2,2)
7586         vv(2)=pizda(2,1)-pizda(1,2)
7587         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7588      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7589      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7590 C Cartesian gradient
7591         do iii=1,2
7592           do kkk=1,5
7593             do lll=1,3
7594               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7595      &          pizda(1,1))
7596               vv(1)=pizda(1,1)+pizda(2,2)
7597               vv(2)=pizda(2,1)-pizda(1,2)
7598               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7599      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7600      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7601             enddo
7602           enddo
7603         enddo
7604       else
7605 C Antiparallel orientation
7606 C Contribution from graph III
7607 c        goto 1110
7608         call transpose2(EUg(1,1,j),auxmat(1,1))
7609         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7610         vv(1)=pizda(1,1)-pizda(2,2)
7611         vv(2)=pizda(1,2)+pizda(2,1)
7612         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7613      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7614 C Explicit gradient in virtual-dihedral angles.
7615         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7616      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7617      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7618         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7619         vv(1)=pizda(1,1)-pizda(2,2)
7620         vv(2)=pizda(1,2)+pizda(2,1)
7621         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7622      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7623      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7624         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7625         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7626         vv(1)=pizda(1,1)-pizda(2,2)
7627         vv(2)=pizda(1,2)+pizda(2,1)
7628         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7629      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7630      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7631 C Cartesian gradient
7632         do iii=1,2
7633           do kkk=1,5
7634             do lll=1,3
7635               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7636      &          pizda(1,1))
7637               vv(1)=pizda(1,1)-pizda(2,2)
7638               vv(2)=pizda(1,2)+pizda(2,1)
7639               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7640      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7641      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7642             enddo
7643           enddo
7644         enddo
7645 cd        goto 1112
7646 C Contribution from graph IV
7647 1110    continue
7648         call transpose2(EE(1,1,itj),auxmat(1,1))
7649         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7650         vv(1)=pizda(1,1)+pizda(2,2)
7651         vv(2)=pizda(2,1)-pizda(1,2)
7652         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7653      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7654 C Explicit gradient in virtual-dihedral angles.
7655         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7656      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7657         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7658         vv(1)=pizda(1,1)+pizda(2,2)
7659         vv(2)=pizda(2,1)-pizda(1,2)
7660         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7661      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7662      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7663 C Cartesian gradient
7664         do iii=1,2
7665           do kkk=1,5
7666             do lll=1,3
7667               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7668      &          pizda(1,1))
7669               vv(1)=pizda(1,1)+pizda(2,2)
7670               vv(2)=pizda(2,1)-pizda(1,2)
7671               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7672      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7673      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7674             enddo
7675           enddo
7676         enddo
7677       endif
7678 1112  continue
7679       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7680 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7681 cd        write (2,*) 'ijkl',i,j,k,l
7682 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7683 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7684 cd      endif
7685 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7686 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7687 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7688 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7689       if (j.lt.nres-1) then
7690         j1=j+1
7691         j2=j-1
7692       else
7693         j1=j-1
7694         j2=j-2
7695       endif
7696       if (l.lt.nres-1) then
7697         l1=l+1
7698         l2=l-1
7699       else
7700         l1=l-1
7701         l2=l-2
7702       endif
7703 cd      eij=1.0d0
7704 cd      ekl=1.0d0
7705 cd      ekont=1.0d0
7706 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7707 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7708 C        summed up outside the subrouine as for the other subroutines
7709 C        handling long-range interactions. The old code is commented out
7710 C        with "cgrad" to keep track of changes.
7711       do ll=1,3
7712 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7713 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7714         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7715         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7716 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7717 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7718 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7719 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7720 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7721 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7722 c     &   gradcorr5ij,
7723 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7724 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7725 cgrad        ghalf=0.5d0*ggg1(ll)
7726 cd        ghalf=0.0d0
7727         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7728         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7729         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7730         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7731         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7732         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7733 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7734 cgrad        ghalf=0.5d0*ggg2(ll)
7735 cd        ghalf=0.0d0
7736         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7737         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7738         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7739         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7740         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7741         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7742       enddo
7743 cd      goto 1112
7744 cgrad      do m=i+1,j-1
7745 cgrad        do ll=1,3
7746 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7747 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7748 cgrad        enddo
7749 cgrad      enddo
7750 cgrad      do m=k+1,l-1
7751 cgrad        do ll=1,3
7752 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7753 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7754 cgrad        enddo
7755 cgrad      enddo
7756 c1112  continue
7757 cgrad      do m=i+2,j2
7758 cgrad        do ll=1,3
7759 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7760 cgrad        enddo
7761 cgrad      enddo
7762 cgrad      do m=k+2,l2
7763 cgrad        do ll=1,3
7764 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7765 cgrad        enddo
7766 cgrad      enddo
7767 cd      do iii=1,nres-3
7768 cd        write (2,*) iii,g_corr5_loc(iii)
7769 cd      enddo
7770       eello5=ekont*eel5
7771 cd      write (2,*) 'ekont',ekont
7772 cd      write (iout,*) 'eello5',ekont*eel5
7773       return
7774       end
7775 c--------------------------------------------------------------------------
7776       double precision function eello6(i,j,k,l,jj,kk)
7777       implicit real*8 (a-h,o-z)
7778       include 'DIMENSIONS'
7779       include 'COMMON.IOUNITS'
7780       include 'COMMON.CHAIN'
7781       include 'COMMON.DERIV'
7782       include 'COMMON.INTERACT'
7783       include 'COMMON.CONTACTS'
7784       include 'COMMON.TORSION'
7785       include 'COMMON.VAR'
7786       include 'COMMON.GEO'
7787       include 'COMMON.FFIELD'
7788       double precision ggg1(3),ggg2(3)
7789 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7790 cd        eello6=0.0d0
7791 cd        return
7792 cd      endif
7793 cd      write (iout,*)
7794 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7795 cd     &   ' and',k,l
7796       eello6_1=0.0d0
7797       eello6_2=0.0d0
7798       eello6_3=0.0d0
7799       eello6_4=0.0d0
7800       eello6_5=0.0d0
7801       eello6_6=0.0d0
7802 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7803 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7804       do iii=1,2
7805         do kkk=1,5
7806           do lll=1,3
7807             derx(lll,kkk,iii)=0.0d0
7808           enddo
7809         enddo
7810       enddo
7811 cd      eij=facont_hb(jj,i)
7812 cd      ekl=facont_hb(kk,k)
7813 cd      ekont=eij*ekl
7814 cd      eij=1.0d0
7815 cd      ekl=1.0d0
7816 cd      ekont=1.0d0
7817       if (l.eq.j+1) then
7818         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7819         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7820         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7821         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7822         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7823         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7824       else
7825         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7826         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7827         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7828         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7829         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7830           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7831         else
7832           eello6_5=0.0d0
7833         endif
7834         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7835       endif
7836 C If turn contributions are considered, they will be handled separately.
7837       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7838 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7839 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7840 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7841 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7842 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7843 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7844 cd      goto 1112
7845       if (j.lt.nres-1) then
7846         j1=j+1
7847         j2=j-1
7848       else
7849         j1=j-1
7850         j2=j-2
7851       endif
7852       if (l.lt.nres-1) then
7853         l1=l+1
7854         l2=l-1
7855       else
7856         l1=l-1
7857         l2=l-2
7858       endif
7859       do ll=1,3
7860 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7861 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7862 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7863 cgrad        ghalf=0.5d0*ggg1(ll)
7864 cd        ghalf=0.0d0
7865         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7866         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7867         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7868         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7869         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7870         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7871         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7872         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7873 cgrad        ghalf=0.5d0*ggg2(ll)
7874 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7875 cd        ghalf=0.0d0
7876         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7877         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7878         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7879         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7880         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7881         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7882       enddo
7883 cd      goto 1112
7884 cgrad      do m=i+1,j-1
7885 cgrad        do ll=1,3
7886 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7887 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7888 cgrad        enddo
7889 cgrad      enddo
7890 cgrad      do m=k+1,l-1
7891 cgrad        do ll=1,3
7892 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7893 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7894 cgrad        enddo
7895 cgrad      enddo
7896 cgrad1112  continue
7897 cgrad      do m=i+2,j2
7898 cgrad        do ll=1,3
7899 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7900 cgrad        enddo
7901 cgrad      enddo
7902 cgrad      do m=k+2,l2
7903 cgrad        do ll=1,3
7904 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7905 cgrad        enddo
7906 cgrad      enddo
7907 cd      do iii=1,nres-3
7908 cd        write (2,*) iii,g_corr6_loc(iii)
7909 cd      enddo
7910       eello6=ekont*eel6
7911 cd      write (2,*) 'ekont',ekont
7912 cd      write (iout,*) 'eello6',ekont*eel6
7913       return
7914       end
7915 c--------------------------------------------------------------------------
7916       double precision function eello6_graph1(i,j,k,l,imat,swap)
7917       implicit real*8 (a-h,o-z)
7918       include 'DIMENSIONS'
7919       include 'COMMON.IOUNITS'
7920       include 'COMMON.CHAIN'
7921       include 'COMMON.DERIV'
7922       include 'COMMON.INTERACT'
7923       include 'COMMON.CONTACTS'
7924       include 'COMMON.TORSION'
7925       include 'COMMON.VAR'
7926       include 'COMMON.GEO'
7927       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7928       logical swap
7929       logical lprn
7930       common /kutas/ lprn
7931 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7932 C                                                                              C
7933 C      Parallel       Antiparallel                                             C
7934 C                                                                              C
7935 C          o             o                                                     C
7936 C         /l\           /j\                                                    C
7937 C        /   \         /   \                                                   C
7938 C       /| o |         | o |\                                                  C
7939 C     \ j|/k\|  /   \  |/k\|l /                                                C
7940 C      \ /   \ /     \ /   \ /                                                 C
7941 C       o     o       o     o                                                  C
7942 C       i             i                                                        C
7943 C                                                                              C
7944 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7945       itk=itortyp(itype(k))
7946       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7947       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7948       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7949       call transpose2(EUgC(1,1,k),auxmat(1,1))
7950       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7951       vv1(1)=pizda1(1,1)-pizda1(2,2)
7952       vv1(2)=pizda1(1,2)+pizda1(2,1)
7953       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7954       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7955       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7956       s5=scalar2(vv(1),Dtobr2(1,i))
7957 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7958       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7959       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7960      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7961      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7962      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7963      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7964      & +scalar2(vv(1),Dtobr2der(1,i)))
7965       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7966       vv1(1)=pizda1(1,1)-pizda1(2,2)
7967       vv1(2)=pizda1(1,2)+pizda1(2,1)
7968       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7969       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7970       if (l.eq.j+1) then
7971         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7972      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7973      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7974      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7975      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7976       else
7977         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7978      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7979      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7980      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7981      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7982       endif
7983       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7984       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7985       vv1(1)=pizda1(1,1)-pizda1(2,2)
7986       vv1(2)=pizda1(1,2)+pizda1(2,1)
7987       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7988      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7989      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7990      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7991       do iii=1,2
7992         if (swap) then
7993           ind=3-iii
7994         else
7995           ind=iii
7996         endif
7997         do kkk=1,5
7998           do lll=1,3
7999             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8000             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8001             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8002             call transpose2(EUgC(1,1,k),auxmat(1,1))
8003             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8004      &        pizda1(1,1))
8005             vv1(1)=pizda1(1,1)-pizda1(2,2)
8006             vv1(2)=pizda1(1,2)+pizda1(2,1)
8007             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8008             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8009      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8010             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8011      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8012             s5=scalar2(vv(1),Dtobr2(1,i))
8013             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8014           enddo
8015         enddo
8016       enddo
8017       return
8018       end
8019 c----------------------------------------------------------------------------
8020       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8021       implicit real*8 (a-h,o-z)
8022       include 'DIMENSIONS'
8023       include 'COMMON.IOUNITS'
8024       include 'COMMON.CHAIN'
8025       include 'COMMON.DERIV'
8026       include 'COMMON.INTERACT'
8027       include 'COMMON.CONTACTS'
8028       include 'COMMON.TORSION'
8029       include 'COMMON.VAR'
8030       include 'COMMON.GEO'
8031       logical swap
8032       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8033      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8034       logical lprn
8035       common /kutas/ lprn
8036 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8037 C                                                                              C
8038 C      Parallel       Antiparallel                                             C
8039 C                                                                              C
8040 C          o             o                                                     C
8041 C     \   /l\           /j\   /                                                C
8042 C      \ /   \         /   \ /                                                 C
8043 C       o| o |         | o |o                                                  C
8044 C     \ j|/k\|      \  |/k\|l                                                  C
8045 C      \ /   \       \ /   \                                                   C
8046 C       o             o                                                        C
8047 C       i             i                                                        C
8048 C                                                                              C
8049 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8050 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8051 C AL 7/4/01 s1 would occur in the sixth-order moment,
8052 C           but not in a cluster cumulant
8053 #ifdef MOMENT
8054       s1=dip(1,jj,i)*dip(1,kk,k)
8055 #endif
8056       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8057       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8058       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8059       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8060       call transpose2(EUg(1,1,k),auxmat(1,1))
8061       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8062       vv(1)=pizda(1,1)-pizda(2,2)
8063       vv(2)=pizda(1,2)+pizda(2,1)
8064       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8065 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8066 #ifdef MOMENT
8067       eello6_graph2=-(s1+s2+s3+s4)
8068 #else
8069       eello6_graph2=-(s2+s3+s4)
8070 #endif
8071 c      eello6_graph2=-s3
8072 C Derivatives in gamma(i-1)
8073       if (i.gt.1) then
8074 #ifdef MOMENT
8075         s1=dipderg(1,jj,i)*dip(1,kk,k)
8076 #endif
8077         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8078         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8079         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8080         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8081 #ifdef MOMENT
8082         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8083 #else
8084         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8085 #endif
8086 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8087       endif
8088 C Derivatives in gamma(k-1)
8089 #ifdef MOMENT
8090       s1=dip(1,jj,i)*dipderg(1,kk,k)
8091 #endif
8092       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8093       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8094       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8095       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8096       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8097       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8098       vv(1)=pizda(1,1)-pizda(2,2)
8099       vv(2)=pizda(1,2)+pizda(2,1)
8100       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8101 #ifdef MOMENT
8102       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8103 #else
8104       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8105 #endif
8106 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8107 C Derivatives in gamma(j-1) or gamma(l-1)
8108       if (j.gt.1) then
8109 #ifdef MOMENT
8110         s1=dipderg(3,jj,i)*dip(1,kk,k)
8111 #endif
8112         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8113         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8114         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8115         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8116         vv(1)=pizda(1,1)-pizda(2,2)
8117         vv(2)=pizda(1,2)+pizda(2,1)
8118         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8119 #ifdef MOMENT
8120         if (swap) then
8121           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8122         else
8123           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8124         endif
8125 #endif
8126         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8127 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8128       endif
8129 C Derivatives in gamma(l-1) or gamma(j-1)
8130       if (l.gt.1) then
8131 #ifdef MOMENT
8132         s1=dip(1,jj,i)*dipderg(3,kk,k)
8133 #endif
8134         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8135         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8136         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8137         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8138         call matmat2(ADtEA1derg(1,1,2,1),auxmat(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         if (swap) then
8144           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8145         else
8146           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8147         endif
8148 #endif
8149         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8150 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8151       endif
8152 C Cartesian derivatives.
8153       if (lprn) then
8154         write (2,*) 'In eello6_graph2'
8155         do iii=1,2
8156           write (2,*) 'iii=',iii
8157           do kkk=1,5
8158             write (2,*) 'kkk=',kkk
8159             do jjj=1,2
8160               write (2,'(3(2f10.5),5x)')
8161      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8162             enddo
8163           enddo
8164         enddo
8165       endif
8166       do iii=1,2
8167         do kkk=1,5
8168           do lll=1,3
8169 #ifdef MOMENT
8170             if (iii.eq.1) then
8171               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8172             else
8173               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8174             endif
8175 #endif
8176             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8177      &        auxvec(1))
8178             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8179             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8180      &        auxvec(1))
8181             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8182             call transpose2(EUg(1,1,k),auxmat(1,1))
8183             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8184      &        pizda(1,1))
8185             vv(1)=pizda(1,1)-pizda(2,2)
8186             vv(2)=pizda(1,2)+pizda(2,1)
8187             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8188 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8189 #ifdef MOMENT
8190             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8191 #else
8192             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8193 #endif
8194             if (swap) then
8195               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8196             else
8197               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8198             endif
8199           enddo
8200         enddo
8201       enddo
8202       return
8203       end
8204 c----------------------------------------------------------------------------
8205       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8206       implicit real*8 (a-h,o-z)
8207       include 'DIMENSIONS'
8208       include 'COMMON.IOUNITS'
8209       include 'COMMON.CHAIN'
8210       include 'COMMON.DERIV'
8211       include 'COMMON.INTERACT'
8212       include 'COMMON.CONTACTS'
8213       include 'COMMON.TORSION'
8214       include 'COMMON.VAR'
8215       include 'COMMON.GEO'
8216       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8217       logical swap
8218 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8219 C                                                                              C
8220 C      Parallel       Antiparallel                                             C
8221 C                                                                              C
8222 C          o             o                                                     C
8223 C         /l\   /   \   /j\                                                    C
8224 C        /   \ /     \ /   \                                                   C
8225 C       /| o |o       o| o |\                                                  C
8226 C       j|/k\|  /      |/k\|l /                                                C
8227 C        /   \ /       /   \ /                                                 C
8228 C       /     o       /     o                                                  C
8229 C       i             i                                                        C
8230 C                                                                              C
8231 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8232 C
8233 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8234 C           energy moment and not to the cluster cumulant.
8235       iti=itortyp(itype(i))
8236       if (j.lt.nres-1) then
8237         itj1=itortyp(itype(j+1))
8238       else
8239         itj1=ntortyp+1
8240       endif
8241       itk=itortyp(itype(k))
8242       itk1=itortyp(itype(k+1))
8243       if (l.lt.nres-1) then
8244         itl1=itortyp(itype(l+1))
8245       else
8246         itl1=ntortyp+1
8247       endif
8248 #ifdef MOMENT
8249       s1=dip(4,jj,i)*dip(4,kk,k)
8250 #endif
8251       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8252       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8253       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8254       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8255       call transpose2(EE(1,1,itk),auxmat(1,1))
8256       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8257       vv(1)=pizda(1,1)+pizda(2,2)
8258       vv(2)=pizda(2,1)-pizda(1,2)
8259       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8260 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8261 cd     & "sum",-(s2+s3+s4)
8262 #ifdef MOMENT
8263       eello6_graph3=-(s1+s2+s3+s4)
8264 #else
8265       eello6_graph3=-(s2+s3+s4)
8266 #endif
8267 c      eello6_graph3=-s4
8268 C Derivatives in gamma(k-1)
8269       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8270       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8271       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8272       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8273 C Derivatives in gamma(l-1)
8274       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8275       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8276       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8277       vv(1)=pizda(1,1)+pizda(2,2)
8278       vv(2)=pizda(2,1)-pizda(1,2)
8279       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8280       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8281 C Cartesian derivatives.
8282       do iii=1,2
8283         do kkk=1,5
8284           do lll=1,3
8285 #ifdef MOMENT
8286             if (iii.eq.1) then
8287               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8288             else
8289               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8290             endif
8291 #endif
8292             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8293      &        auxvec(1))
8294             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8295             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8296      &        auxvec(1))
8297             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8298             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8299      &        pizda(1,1))
8300             vv(1)=pizda(1,1)+pizda(2,2)
8301             vv(2)=pizda(2,1)-pizda(1,2)
8302             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8303 #ifdef MOMENT
8304             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8305 #else
8306             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8307 #endif
8308             if (swap) then
8309               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8310             else
8311               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8312             endif
8313 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8314           enddo
8315         enddo
8316       enddo
8317       return
8318       end
8319 c----------------------------------------------------------------------------
8320       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8321       implicit real*8 (a-h,o-z)
8322       include 'DIMENSIONS'
8323       include 'COMMON.IOUNITS'
8324       include 'COMMON.CHAIN'
8325       include 'COMMON.DERIV'
8326       include 'COMMON.INTERACT'
8327       include 'COMMON.CONTACTS'
8328       include 'COMMON.TORSION'
8329       include 'COMMON.VAR'
8330       include 'COMMON.GEO'
8331       include 'COMMON.FFIELD'
8332       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8333      & auxvec1(2),auxmat1(2,2)
8334       logical swap
8335 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8336 C                                                                              C
8337 C      Parallel       Antiparallel                                             C
8338 C                                                                              C
8339 C          o             o                                                     C
8340 C         /l\   /   \   /j\                                                    C
8341 C        /   \ /     \ /   \                                                   C
8342 C       /| o |o       o| o |\                                                  C
8343 C     \ j|/k\|      \  |/k\|l                                                  C
8344 C      \ /   \       \ /   \                                                   C
8345 C       o     \       o     \                                                  C
8346 C       i             i                                                        C
8347 C                                                                              C
8348 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8349 C
8350 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8351 C           energy moment and not to the cluster cumulant.
8352 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8353       iti=itortyp(itype(i))
8354       itj=itortyp(itype(j))
8355       if (j.lt.nres-1) then
8356         itj1=itortyp(itype(j+1))
8357       else
8358         itj1=ntortyp+1
8359       endif
8360       itk=itortyp(itype(k))
8361       if (k.lt.nres-1) then
8362         itk1=itortyp(itype(k+1))
8363       else
8364         itk1=ntortyp+1
8365       endif
8366       itl=itortyp(itype(l))
8367       if (l.lt.nres-1) then
8368         itl1=itortyp(itype(l+1))
8369       else
8370         itl1=ntortyp+1
8371       endif
8372 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8373 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8374 cd     & ' itl',itl,' itl1',itl1
8375 #ifdef MOMENT
8376       if (imat.eq.1) then
8377         s1=dip(3,jj,i)*dip(3,kk,k)
8378       else
8379         s1=dip(2,jj,j)*dip(2,kk,l)
8380       endif
8381 #endif
8382       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8383       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8384       if (j.eq.l+1) then
8385         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8386         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8387       else
8388         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8389         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8390       endif
8391       call transpose2(EUg(1,1,k),auxmat(1,1))
8392       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8393       vv(1)=pizda(1,1)-pizda(2,2)
8394       vv(2)=pizda(2,1)+pizda(1,2)
8395       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8396 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8397 #ifdef MOMENT
8398       eello6_graph4=-(s1+s2+s3+s4)
8399 #else
8400       eello6_graph4=-(s2+s3+s4)
8401 #endif
8402 C Derivatives in gamma(i-1)
8403       if (i.gt.1) then
8404 #ifdef MOMENT
8405         if (imat.eq.1) then
8406           s1=dipderg(2,jj,i)*dip(3,kk,k)
8407         else
8408           s1=dipderg(4,jj,j)*dip(2,kk,l)
8409         endif
8410 #endif
8411         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8412         if (j.eq.l+1) then
8413           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8414           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8415         else
8416           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8417           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8418         endif
8419         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8420         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8421 cd          write (2,*) 'turn6 derivatives'
8422 #ifdef MOMENT
8423           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8424 #else
8425           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8426 #endif
8427         else
8428 #ifdef MOMENT
8429           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8430 #else
8431           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8432 #endif
8433         endif
8434       endif
8435 C Derivatives in gamma(k-1)
8436 #ifdef MOMENT
8437       if (imat.eq.1) then
8438         s1=dip(3,jj,i)*dipderg(2,kk,k)
8439       else
8440         s1=dip(2,jj,j)*dipderg(4,kk,l)
8441       endif
8442 #endif
8443       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8444       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8445       if (j.eq.l+1) then
8446         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8447         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8448       else
8449         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8450         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8451       endif
8452       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8453       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8454       vv(1)=pizda(1,1)-pizda(2,2)
8455       vv(2)=pizda(2,1)+pizda(1,2)
8456       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8457       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8458 #ifdef MOMENT
8459         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8460 #else
8461         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8462 #endif
8463       else
8464 #ifdef MOMENT
8465         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8466 #else
8467         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8468 #endif
8469       endif
8470 C Derivatives in gamma(j-1) or gamma(l-1)
8471       if (l.eq.j+1 .and. l.gt.1) then
8472         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8473         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8474         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8475         vv(1)=pizda(1,1)-pizda(2,2)
8476         vv(2)=pizda(2,1)+pizda(1,2)
8477         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8478         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8479       else if (j.gt.1) then
8480         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8481         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8482         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8483         vv(1)=pizda(1,1)-pizda(2,2)
8484         vv(2)=pizda(2,1)+pizda(1,2)
8485         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8486         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8487           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8488         else
8489           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8490         endif
8491       endif
8492 C Cartesian derivatives.
8493       do iii=1,2
8494         do kkk=1,5
8495           do lll=1,3
8496 #ifdef MOMENT
8497             if (iii.eq.1) then
8498               if (imat.eq.1) then
8499                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8500               else
8501                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8502               endif
8503             else
8504               if (imat.eq.1) then
8505                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8506               else
8507                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8508               endif
8509             endif
8510 #endif
8511             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8512      &        auxvec(1))
8513             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8514             if (j.eq.l+1) then
8515               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8516      &          b1(1,itj1),auxvec(1))
8517               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8518             else
8519               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8520      &          b1(1,itl1),auxvec(1))
8521               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8522             endif
8523             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8524      &        pizda(1,1))
8525             vv(1)=pizda(1,1)-pizda(2,2)
8526             vv(2)=pizda(2,1)+pizda(1,2)
8527             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8528             if (swap) then
8529               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8530 #ifdef MOMENT
8531                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8532      &             -(s1+s2+s4)
8533 #else
8534                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8535      &             -(s2+s4)
8536 #endif
8537                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8538               else
8539 #ifdef MOMENT
8540                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8541 #else
8542                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8543 #endif
8544                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8545               endif
8546             else
8547 #ifdef MOMENT
8548               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8549 #else
8550               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8551 #endif
8552               if (l.eq.j+1) then
8553                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8554               else
8555                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8556               endif
8557             endif
8558           enddo
8559         enddo
8560       enddo
8561       return
8562       end
8563 c----------------------------------------------------------------------------
8564       double precision function eello_turn6(i,jj,kk)
8565       implicit real*8 (a-h,o-z)
8566       include 'DIMENSIONS'
8567       include 'COMMON.IOUNITS'
8568       include 'COMMON.CHAIN'
8569       include 'COMMON.DERIV'
8570       include 'COMMON.INTERACT'
8571       include 'COMMON.CONTACTS'
8572       include 'COMMON.TORSION'
8573       include 'COMMON.VAR'
8574       include 'COMMON.GEO'
8575       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8576      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8577      &  ggg1(3),ggg2(3)
8578       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8579      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8580 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8581 C           the respective energy moment and not to the cluster cumulant.
8582       s1=0.0d0
8583       s8=0.0d0
8584       s13=0.0d0
8585 c
8586       eello_turn6=0.0d0
8587       j=i+4
8588       k=i+1
8589       l=i+3
8590       iti=itortyp(itype(i))
8591       itk=itortyp(itype(k))
8592       itk1=itortyp(itype(k+1))
8593       itl=itortyp(itype(l))
8594       itj=itortyp(itype(j))
8595 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8596 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8597 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8598 cd        eello6=0.0d0
8599 cd        return
8600 cd      endif
8601 cd      write (iout,*)
8602 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8603 cd     &   ' and',k,l
8604 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8605       do iii=1,2
8606         do kkk=1,5
8607           do lll=1,3
8608             derx_turn(lll,kkk,iii)=0.0d0
8609           enddo
8610         enddo
8611       enddo
8612 cd      eij=1.0d0
8613 cd      ekl=1.0d0
8614 cd      ekont=1.0d0
8615       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8616 cd      eello6_5=0.0d0
8617 cd      write (2,*) 'eello6_5',eello6_5
8618 #ifdef MOMENT
8619       call transpose2(AEA(1,1,1),auxmat(1,1))
8620       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8621       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8622       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8623 #endif
8624       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8625       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8626       s2 = scalar2(b1(1,itk),vtemp1(1))
8627 #ifdef MOMENT
8628       call transpose2(AEA(1,1,2),atemp(1,1))
8629       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8630       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8631       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8632 #endif
8633       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8634       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8635       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8636 #ifdef MOMENT
8637       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8638       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8639       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8640       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8641       ss13 = scalar2(b1(1,itk),vtemp4(1))
8642       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8643 #endif
8644 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8645 c      s1=0.0d0
8646 c      s2=0.0d0
8647 c      s8=0.0d0
8648 c      s12=0.0d0
8649 c      s13=0.0d0
8650       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8651 C Derivatives in gamma(i+2)
8652       s1d =0.0d0
8653       s8d =0.0d0
8654 #ifdef MOMENT
8655       call transpose2(AEA(1,1,1),auxmatd(1,1))
8656       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8657       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8658       call transpose2(AEAderg(1,1,2),atempd(1,1))
8659       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8660       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8661 #endif
8662       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8663       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8664       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8665 c      s1d=0.0d0
8666 c      s2d=0.0d0
8667 c      s8d=0.0d0
8668 c      s12d=0.0d0
8669 c      s13d=0.0d0
8670       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8671 C Derivatives in gamma(i+3)
8672 #ifdef MOMENT
8673       call transpose2(AEA(1,1,1),auxmatd(1,1))
8674       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8675       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8676       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8677 #endif
8678       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8679       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8680       s2d = scalar2(b1(1,itk),vtemp1d(1))
8681 #ifdef MOMENT
8682       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8683       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8684 #endif
8685       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8686 #ifdef MOMENT
8687       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8688       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8689       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8690 #endif
8691 c      s1d=0.0d0
8692 c      s2d=0.0d0
8693 c      s8d=0.0d0
8694 c      s12d=0.0d0
8695 c      s13d=0.0d0
8696 #ifdef MOMENT
8697       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8698      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8699 #else
8700       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8701      &               -0.5d0*ekont*(s2d+s12d)
8702 #endif
8703 C Derivatives in gamma(i+4)
8704       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8705       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8706       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8707 #ifdef MOMENT
8708       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8709       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8710       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8711 #endif
8712 c      s1d=0.0d0
8713 c      s2d=0.0d0
8714 c      s8d=0.0d0
8715 C      s12d=0.0d0
8716 c      s13d=0.0d0
8717 #ifdef MOMENT
8718       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8719 #else
8720       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8721 #endif
8722 C Derivatives in gamma(i+5)
8723 #ifdef MOMENT
8724       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8725       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8726       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8727 #endif
8728       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8729       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8730       s2d = scalar2(b1(1,itk),vtemp1d(1))
8731 #ifdef MOMENT
8732       call transpose2(AEA(1,1,2),atempd(1,1))
8733       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8734       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8735 #endif
8736       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8737       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8738 #ifdef MOMENT
8739       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8740       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8741       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8742 #endif
8743 c      s1d=0.0d0
8744 c      s2d=0.0d0
8745 c      s8d=0.0d0
8746 c      s12d=0.0d0
8747 c      s13d=0.0d0
8748 #ifdef MOMENT
8749       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8750      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8751 #else
8752       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8753      &               -0.5d0*ekont*(s2d+s12d)
8754 #endif
8755 C Cartesian derivatives
8756       do iii=1,2
8757         do kkk=1,5
8758           do lll=1,3
8759 #ifdef MOMENT
8760             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8761             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8762             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8763 #endif
8764             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8765             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8766      &          vtemp1d(1))
8767             s2d = scalar2(b1(1,itk),vtemp1d(1))
8768 #ifdef MOMENT
8769             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8770             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8771             s8d = -(atempd(1,1)+atempd(2,2))*
8772      &           scalar2(cc(1,1,itl),vtemp2(1))
8773 #endif
8774             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8775      &           auxmatd(1,1))
8776             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8777             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8778 c      s1d=0.0d0
8779 c      s2d=0.0d0
8780 c      s8d=0.0d0
8781 c      s12d=0.0d0
8782 c      s13d=0.0d0
8783 #ifdef MOMENT
8784             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8785      &        - 0.5d0*(s1d+s2d)
8786 #else
8787             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8788      &        - 0.5d0*s2d
8789 #endif
8790 #ifdef MOMENT
8791             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8792      &        - 0.5d0*(s8d+s12d)
8793 #else
8794             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8795      &        - 0.5d0*s12d
8796 #endif
8797           enddo
8798         enddo
8799       enddo
8800 #ifdef MOMENT
8801       do kkk=1,5
8802         do lll=1,3
8803           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8804      &      achuj_tempd(1,1))
8805           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8806           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8807           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8808           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8809           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8810      &      vtemp4d(1))
8811           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8812           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8813           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8814         enddo
8815       enddo
8816 #endif
8817 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8818 cd     &  16*eel_turn6_num
8819 cd      goto 1112
8820       if (j.lt.nres-1) then
8821         j1=j+1
8822         j2=j-1
8823       else
8824         j1=j-1
8825         j2=j-2
8826       endif
8827       if (l.lt.nres-1) then
8828         l1=l+1
8829         l2=l-1
8830       else
8831         l1=l-1
8832         l2=l-2
8833       endif
8834       do ll=1,3
8835 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8836 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8837 cgrad        ghalf=0.5d0*ggg1(ll)
8838 cd        ghalf=0.0d0
8839         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8840         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8841         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8842      &    +ekont*derx_turn(ll,2,1)
8843         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8844         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8845      &    +ekont*derx_turn(ll,4,1)
8846         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8847         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8848         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8849 cgrad        ghalf=0.5d0*ggg2(ll)
8850 cd        ghalf=0.0d0
8851         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8852      &    +ekont*derx_turn(ll,2,2)
8853         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8854         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8855      &    +ekont*derx_turn(ll,4,2)
8856         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8857         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8858         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8859       enddo
8860 cd      goto 1112
8861 cgrad      do m=i+1,j-1
8862 cgrad        do ll=1,3
8863 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8864 cgrad        enddo
8865 cgrad      enddo
8866 cgrad      do m=k+1,l-1
8867 cgrad        do ll=1,3
8868 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8869 cgrad        enddo
8870 cgrad      enddo
8871 cgrad1112  continue
8872 cgrad      do m=i+2,j2
8873 cgrad        do ll=1,3
8874 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8875 cgrad        enddo
8876 cgrad      enddo
8877 cgrad      do m=k+2,l2
8878 cgrad        do ll=1,3
8879 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8880 cgrad        enddo
8881 cgrad      enddo
8882 cd      do iii=1,nres-3
8883 cd        write (2,*) iii,g_corr6_loc(iii)
8884 cd      enddo
8885       eello_turn6=ekont*eel_turn6
8886 cd      write (2,*) 'ekont',ekont
8887 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8888       return
8889       end
8890
8891 C-----------------------------------------------------------------------------
8892       double precision function scalar(u,v)
8893 !DIR$ INLINEALWAYS scalar
8894 #ifndef OSF
8895 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8896 #endif
8897       implicit none
8898       double precision u(3),v(3)
8899 cd      double precision sc
8900 cd      integer i
8901 cd      sc=0.0d0
8902 cd      do i=1,3
8903 cd        sc=sc+u(i)*v(i)
8904 cd      enddo
8905 cd      scalar=sc
8906
8907       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8908       return
8909       end
8910 crc-------------------------------------------------
8911       SUBROUTINE MATVEC2(A1,V1,V2)
8912 !DIR$ INLINEALWAYS MATVEC2
8913 #ifndef OSF
8914 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8915 #endif
8916       implicit real*8 (a-h,o-z)
8917       include 'DIMENSIONS'
8918       DIMENSION A1(2,2),V1(2),V2(2)
8919 c      DO 1 I=1,2
8920 c        VI=0.0
8921 c        DO 3 K=1,2
8922 c    3     VI=VI+A1(I,K)*V1(K)
8923 c        Vaux(I)=VI
8924 c    1 CONTINUE
8925
8926       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8927       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8928
8929       v2(1)=vaux1
8930       v2(2)=vaux2
8931       END
8932 C---------------------------------------
8933       SUBROUTINE MATMAT2(A1,A2,A3)
8934 #ifndef OSF
8935 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8936 #endif
8937       implicit real*8 (a-h,o-z)
8938       include 'DIMENSIONS'
8939       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8940 c      DIMENSION AI3(2,2)
8941 c        DO  J=1,2
8942 c          A3IJ=0.0
8943 c          DO K=1,2
8944 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8945 c          enddo
8946 c          A3(I,J)=A3IJ
8947 c       enddo
8948 c      enddo
8949
8950       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8951       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8952       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8953       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8954
8955       A3(1,1)=AI3_11
8956       A3(2,1)=AI3_21
8957       A3(1,2)=AI3_12
8958       A3(2,2)=AI3_22
8959       END
8960
8961 c-------------------------------------------------------------------------
8962       double precision function scalar2(u,v)
8963 !DIR$ INLINEALWAYS scalar2
8964       implicit none
8965       double precision u(2),v(2)
8966       double precision sc
8967       integer i
8968       scalar2=u(1)*v(1)+u(2)*v(2)
8969       return
8970       end
8971
8972 C-----------------------------------------------------------------------------
8973
8974       subroutine transpose2(a,at)
8975 !DIR$ INLINEALWAYS transpose2
8976 #ifndef OSF
8977 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8978 #endif
8979       implicit none
8980       double precision a(2,2),at(2,2)
8981       at(1,1)=a(1,1)
8982       at(1,2)=a(2,1)
8983       at(2,1)=a(1,2)
8984       at(2,2)=a(2,2)
8985       return
8986       end
8987 c--------------------------------------------------------------------------
8988       subroutine transpose(n,a,at)
8989       implicit none
8990       integer n,i,j
8991       double precision a(n,n),at(n,n)
8992       do i=1,n
8993         do j=1,n
8994           at(j,i)=a(i,j)
8995         enddo
8996       enddo
8997       return
8998       end
8999 C---------------------------------------------------------------------------
9000       subroutine prodmat3(a1,a2,kk,transp,prod)
9001 !DIR$ INLINEALWAYS prodmat3
9002 #ifndef OSF
9003 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9004 #endif
9005       implicit none
9006       integer i,j
9007       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9008       logical transp
9009 crc      double precision auxmat(2,2),prod_(2,2)
9010
9011       if (transp) then
9012 crc        call transpose2(kk(1,1),auxmat(1,1))
9013 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9014 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9015
9016            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9017      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9018            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9019      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9020            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9021      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9022            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9023      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9024
9025       else
9026 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9027 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9028
9029            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9030      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9031            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9032      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9033            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9034      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9035            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9036      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9037
9038       endif
9039 c      call transpose2(a2(1,1),a2t(1,1))
9040
9041 crc      print *,transp
9042 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9043 crc      print *,((prod(i,j),i=1,2),j=1,2)
9044
9045       return
9046       end
9047