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 <<<<<<< HEAD
4085          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4086      & iabs(itype(jjj)).eq.1) then
4087 =======
4088          if (ii.gt.nres
4089      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4090 >>>>>>> prerelease-3.2.1
4091           call ssbond_ene(iii,jjj,eij)
4092           ehpb=ehpb+2*eij
4093          endif
4094 cd          write (iout,*) "eij",eij
4095          endif
4096         else
4097 C Calculate the distance between the two points and its difference from the
4098 C target distance.
4099           dd=dist(ii,jj)
4100             rdis=dd-dhpb(i)
4101 C Get the force constant corresponding to this distance.
4102             waga=forcon(i)
4103 C Calculate the contribution to energy.
4104             ehpb=ehpb+waga*rdis*rdis
4105 C
4106 C Evaluate gradient.
4107 C
4108             fac=waga*rdis/dd
4109 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4110 cd   &   ' waga=',waga,' fac=',fac
4111             do j=1,3
4112               ggg(j)=fac*(c(j,jj)-c(j,ii))
4113             enddo
4114 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4115 C If this is a SC-SC distance, we need to calculate the contributions to the
4116 C Cartesian gradient in the SC vectors (ghpbx).
4117           if (iii.lt.ii) then
4118           do j=1,3
4119             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4120             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4121           enddo
4122           endif
4123 cgrad        do j=iii,jjj-1
4124 cgrad          do k=1,3
4125 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4126 cgrad          enddo
4127 cgrad        enddo
4128           do k=1,3
4129             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4130             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4131           enddo
4132         endif
4133       enddo
4134       ehpb=0.5D0*ehpb
4135       return
4136       end
4137 C--------------------------------------------------------------------------
4138       subroutine ssbond_ene(i,j,eij)
4139 C
4140 C Calculate the distance and angle dependent SS-bond potential energy
4141 C using a free-energy function derived based on RHF/6-31G** ab initio
4142 C calculations of diethyl disulfide.
4143 C
4144 C A. Liwo and U. Kozlowska, 11/24/03
4145 C
4146       implicit real*8 (a-h,o-z)
4147       include 'DIMENSIONS'
4148       include 'COMMON.SBRIDGE'
4149       include 'COMMON.CHAIN'
4150       include 'COMMON.DERIV'
4151       include 'COMMON.LOCAL'
4152       include 'COMMON.INTERACT'
4153       include 'COMMON.VAR'
4154       include 'COMMON.IOUNITS'
4155       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4156       itypi=iabs(itype(i))
4157       xi=c(1,nres+i)
4158       yi=c(2,nres+i)
4159       zi=c(3,nres+i)
4160       dxi=dc_norm(1,nres+i)
4161       dyi=dc_norm(2,nres+i)
4162       dzi=dc_norm(3,nres+i)
4163 c      dsci_inv=dsc_inv(itypi)
4164       dsci_inv=vbld_inv(nres+i)
4165       itypj=iabs(itype(j))
4166 c      dscj_inv=dsc_inv(itypj)
4167       dscj_inv=vbld_inv(nres+j)
4168       xj=c(1,nres+j)-xi
4169       yj=c(2,nres+j)-yi
4170       zj=c(3,nres+j)-zi
4171       dxj=dc_norm(1,nres+j)
4172       dyj=dc_norm(2,nres+j)
4173       dzj=dc_norm(3,nres+j)
4174       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4175       rij=dsqrt(rrij)
4176       erij(1)=xj*rij
4177       erij(2)=yj*rij
4178       erij(3)=zj*rij
4179       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4180       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4181       om12=dxi*dxj+dyi*dyj+dzi*dzj
4182       do k=1,3
4183         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4184         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4185       enddo
4186       rij=1.0d0/rij
4187       deltad=rij-d0cm
4188       deltat1=1.0d0-om1
4189       deltat2=1.0d0+om2
4190       deltat12=om2-om1+2.0d0
4191       cosphi=om12-om1*om2
4192       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4193      &  +akct*deltad*deltat12
4194      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4195 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4196 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4197 c     &  " deltat12",deltat12," eij",eij
4198       ed=2*akcm*deltad+akct*deltat12
4199       pom1=akct*deltad
4200       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4201       eom1=-2*akth*deltat1-pom1-om2*pom2
4202       eom2= 2*akth*deltat2+pom1-om1*pom2
4203       eom12=pom2
4204       do k=1,3
4205         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4206         ghpbx(k,i)=ghpbx(k,i)-ggk
4207      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4208      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4209         ghpbx(k,j)=ghpbx(k,j)+ggk
4210      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4211      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4212         ghpbc(k,i)=ghpbc(k,i)-ggk
4213         ghpbc(k,j)=ghpbc(k,j)+ggk
4214       enddo
4215 C
4216 C Calculate the components of the gradient in DC and X
4217 C
4218 cgrad      do k=i,j-1
4219 cgrad        do l=1,3
4220 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4221 cgrad        enddo
4222 cgrad      enddo
4223       return
4224       end
4225 C--------------------------------------------------------------------------
4226       subroutine ebond(estr)
4227 c
4228 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4229 c
4230       implicit real*8 (a-h,o-z)
4231       include 'DIMENSIONS'
4232       include 'COMMON.LOCAL'
4233       include 'COMMON.GEO'
4234       include 'COMMON.INTERACT'
4235       include 'COMMON.DERIV'
4236       include 'COMMON.VAR'
4237       include 'COMMON.CHAIN'
4238       include 'COMMON.IOUNITS'
4239       include 'COMMON.NAMES'
4240       include 'COMMON.FFIELD'
4241       include 'COMMON.CONTROL'
4242       include 'COMMON.SETUP'
4243       double precision u(3),ud(3)
4244       estr=0.0d0
4245       estr1=0.0d0
4246       do i=ibondp_start,ibondp_end
4247         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4248           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4249           do j=1,3
4250           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4251      &      *dc(j,i-1)/vbld(i)
4252           enddo
4253           if (energy_dec) write(iout,*)
4254      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4255         else
4256         diff = vbld(i)-vbldp0
4257         if (energy_dec) write (iout,*)
4258      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4259         estr=estr+diff*diff
4260         do j=1,3
4261           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4262         enddo
4263 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4264         endif
4265       enddo
4266       estr=0.5d0*AKP*estr+estr1
4267 c
4268 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4269 c
4270       do i=ibond_start,ibond_end
4271         iti=iabs(itype(i))
4272         if (iti.ne.10 .and. iti.ne.ntyp1) then
4273           nbi=nbondterm(iti)
4274           if (nbi.eq.1) then
4275             diff=vbld(i+nres)-vbldsc0(1,iti)
4276             if (energy_dec) write (iout,*)
4277      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4278      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4279             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4280             do j=1,3
4281               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4282             enddo
4283           else
4284             do j=1,nbi
4285               diff=vbld(i+nres)-vbldsc0(j,iti)
4286               ud(j)=aksc(j,iti)*diff
4287               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4288             enddo
4289             uprod=u(1)
4290             do j=2,nbi
4291               uprod=uprod*u(j)
4292             enddo
4293             usum=0.0d0
4294             usumsqder=0.0d0
4295             do j=1,nbi
4296               uprod1=1.0d0
4297               uprod2=1.0d0
4298               do k=1,nbi
4299                 if (k.ne.j) then
4300                   uprod1=uprod1*u(k)
4301                   uprod2=uprod2*u(k)*u(k)
4302                 endif
4303               enddo
4304               usum=usum+uprod1
4305               usumsqder=usumsqder+ud(j)*uprod2
4306             enddo
4307             estr=estr+uprod/usum
4308             do j=1,3
4309              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4310             enddo
4311           endif
4312         endif
4313       enddo
4314       return
4315       end
4316 #ifdef CRYST_THETA
4317 C--------------------------------------------------------------------------
4318       subroutine ebend(etheta)
4319 C
4320 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4321 C angles gamma and its derivatives in consecutive thetas and gammas.
4322 C
4323       implicit real*8 (a-h,o-z)
4324       include 'DIMENSIONS'
4325       include 'COMMON.LOCAL'
4326       include 'COMMON.GEO'
4327       include 'COMMON.INTERACT'
4328       include 'COMMON.DERIV'
4329       include 'COMMON.VAR'
4330       include 'COMMON.CHAIN'
4331       include 'COMMON.IOUNITS'
4332       include 'COMMON.NAMES'
4333       include 'COMMON.FFIELD'
4334       include 'COMMON.CONTROL'
4335       common /calcthet/ term1,term2,termm,diffak,ratak,
4336      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4337      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4338       double precision y(2),z(2)
4339       delta=0.02d0*pi
4340 c      time11=dexp(-2*time)
4341 c      time12=1.0d0
4342       etheta=0.0D0
4343 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4344       do i=ithet_start,ithet_end
4345         if (itype(i-1).eq.ntyp1) cycle
4346 C Zero the energy function and its derivative at 0 or pi.
4347         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4348         it=itype(i-1)
4349         ichir1=isign(1,itype(i-2))
4350         ichir2=isign(1,itype(i))
4351          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4352          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4353          if (itype(i-1).eq.10) then
4354           itype1=isign(10,itype(i-2))
4355           ichir11=isign(1,itype(i-2))
4356           ichir12=isign(1,itype(i-2))
4357           itype2=isign(10,itype(i))
4358           ichir21=isign(1,itype(i))
4359           ichir22=isign(1,itype(i))
4360          endif
4361
4362         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4363 #ifdef OSF
4364           phii=phi(i)
4365           if (phii.ne.phii) phii=150.0
4366 #else
4367           phii=phi(i)
4368 #endif
4369           y(1)=dcos(phii)
4370           y(2)=dsin(phii)
4371         else
4372           y(1)=0.0D0
4373           y(2)=0.0D0
4374         endif
4375         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4376 #ifdef OSF
4377           phii1=phi(i+1)
4378           if (phii1.ne.phii1) phii1=150.0
4379           phii1=pinorm(phii1)
4380           z(1)=cos(phii1)
4381 #else
4382           phii1=phi(i+1)
4383           z(1)=dcos(phii1)
4384 #endif
4385           z(2)=dsin(phii1)
4386         else
4387           z(1)=0.0D0
4388           z(2)=0.0D0
4389         endif
4390 C Calculate the "mean" value of theta from the part of the distribution
4391 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4392 C In following comments this theta will be referred to as t_c.
4393         thet_pred_mean=0.0d0
4394         do k=1,2
4395             athetk=athet(k,it,ichir1,ichir2)
4396             bthetk=bthet(k,it,ichir1,ichir2)
4397           if (it.eq.10) then
4398              athetk=athet(k,itype1,ichir11,ichir12)
4399              bthetk=bthet(k,itype2,ichir21,ichir22)
4400           endif
4401          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4402         enddo
4403         dthett=thet_pred_mean*ssd
4404         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4405 C Derivatives of the "mean" values in gamma1 and gamma2.
4406         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4407      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4408          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4409      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4410          if (it.eq.10) then
4411       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4412      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4413         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4414      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4415          endif
4416         if (theta(i).gt.pi-delta) then
4417           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4418      &         E_tc0)
4419           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4420           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4421           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4422      &        E_theta)
4423           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4424      &        E_tc)
4425         else if (theta(i).lt.delta) then
4426           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4427           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4428           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4429      &        E_theta)
4430           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4431           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4432      &        E_tc)
4433         else
4434           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4435      &        E_theta,E_tc)
4436         endif
4437         etheta=etheta+ethetai
4438         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4439      &      'ebend',i,ethetai
4440         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4441         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4442         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4443       enddo
4444 C Ufff.... We've done all this!!!
4445       return
4446       end
4447 C---------------------------------------------------------------------------
4448       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4449      &     E_tc)
4450       implicit real*8 (a-h,o-z)
4451       include 'DIMENSIONS'
4452       include 'COMMON.LOCAL'
4453       include 'COMMON.IOUNITS'
4454       common /calcthet/ term1,term2,termm,diffak,ratak,
4455      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4456      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4457 C Calculate the contributions to both Gaussian lobes.
4458 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4459 C The "polynomial part" of the "standard deviation" of this part of
4460 C the distribution.
4461         sig=polthet(3,it)
4462         do j=2,0,-1
4463           sig=sig*thet_pred_mean+polthet(j,it)
4464         enddo
4465 C Derivative of the "interior part" of the "standard deviation of the"
4466 C gamma-dependent Gaussian lobe in t_c.
4467         sigtc=3*polthet(3,it)
4468         do j=2,1,-1
4469           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4470         enddo
4471         sigtc=sig*sigtc
4472 C Set the parameters of both Gaussian lobes of the distribution.
4473 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4474         fac=sig*sig+sigc0(it)
4475         sigcsq=fac+fac
4476         sigc=1.0D0/sigcsq
4477 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4478         sigsqtc=-4.0D0*sigcsq*sigtc
4479 c       print *,i,sig,sigtc,sigsqtc
4480 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4481         sigtc=-sigtc/(fac*fac)
4482 C Following variable is sigma(t_c)**(-2)
4483         sigcsq=sigcsq*sigcsq
4484         sig0i=sig0(it)
4485         sig0inv=1.0D0/sig0i**2
4486         delthec=thetai-thet_pred_mean
4487         delthe0=thetai-theta0i
4488         term1=-0.5D0*sigcsq*delthec*delthec
4489         term2=-0.5D0*sig0inv*delthe0*delthe0
4490 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4491 C NaNs in taking the logarithm. We extract the largest exponent which is added
4492 C to the energy (this being the log of the distribution) at the end of energy
4493 C term evaluation for this virtual-bond angle.
4494         if (term1.gt.term2) then
4495           termm=term1
4496           term2=dexp(term2-termm)
4497           term1=1.0d0
4498         else
4499           termm=term2
4500           term1=dexp(term1-termm)
4501           term2=1.0d0
4502         endif
4503 C The ratio between the gamma-independent and gamma-dependent lobes of
4504 C the distribution is a Gaussian function of thet_pred_mean too.
4505         diffak=gthet(2,it)-thet_pred_mean
4506         ratak=diffak/gthet(3,it)**2
4507         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4508 C Let's differentiate it in thet_pred_mean NOW.
4509         aktc=ak*ratak
4510 C Now put together the distribution terms to make complete distribution.
4511         termexp=term1+ak*term2
4512         termpre=sigc+ak*sig0i
4513 C Contribution of the bending energy from this theta is just the -log of
4514 C the sum of the contributions from the two lobes and the pre-exponential
4515 C factor. Simple enough, isn't it?
4516         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4517 C NOW the derivatives!!!
4518 C 6/6/97 Take into account the deformation.
4519         E_theta=(delthec*sigcsq*term1
4520      &       +ak*delthe0*sig0inv*term2)/termexp
4521         E_tc=((sigtc+aktc*sig0i)/termpre
4522      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4523      &       aktc*term2)/termexp)
4524       return
4525       end
4526 c-----------------------------------------------------------------------------
4527       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4528       implicit real*8 (a-h,o-z)
4529       include 'DIMENSIONS'
4530       include 'COMMON.LOCAL'
4531       include 'COMMON.IOUNITS'
4532       common /calcthet/ term1,term2,termm,diffak,ratak,
4533      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4534      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4535       delthec=thetai-thet_pred_mean
4536       delthe0=thetai-theta0i
4537 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4538       t3 = thetai-thet_pred_mean
4539       t6 = t3**2
4540       t9 = term1
4541       t12 = t3*sigcsq
4542       t14 = t12+t6*sigsqtc
4543       t16 = 1.0d0
4544       t21 = thetai-theta0i
4545       t23 = t21**2
4546       t26 = term2
4547       t27 = t21*t26
4548       t32 = termexp
4549       t40 = t32**2
4550       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4551      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4552      & *(-t12*t9-ak*sig0inv*t27)
4553       return
4554       end
4555 #else
4556 C--------------------------------------------------------------------------
4557       subroutine ebend(etheta)
4558 C
4559 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4560 C angles gamma and its derivatives in consecutive thetas and gammas.
4561 C ab initio-derived potentials from
4562 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4563 C
4564       implicit real*8 (a-h,o-z)
4565       include 'DIMENSIONS'
4566       include 'COMMON.LOCAL'
4567       include 'COMMON.GEO'
4568       include 'COMMON.INTERACT'
4569       include 'COMMON.DERIV'
4570       include 'COMMON.VAR'
4571       include 'COMMON.CHAIN'
4572       include 'COMMON.IOUNITS'
4573       include 'COMMON.NAMES'
4574       include 'COMMON.FFIELD'
4575       include 'COMMON.CONTROL'
4576       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4577      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4578      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4579      & sinph1ph2(maxdouble,maxdouble)
4580       logical lprn /.false./, lprn1 /.false./
4581       etheta=0.0D0
4582       do i=ithet_start,ithet_end
4583         if (itype(i-1).eq.ntyp1) cycle
4584         if (iabs(itype(i+1)).eq.20) iblock=2
4585         if (iabs(itype(i+1)).ne.20) iblock=1
4586         dethetai=0.0d0
4587         dephii=0.0d0
4588         dephii1=0.0d0
4589         theti2=0.5d0*theta(i)
4590         ityp2=ithetyp((itype(i-1)))
4591         do k=1,nntheterm
4592           coskt(k)=dcos(k*theti2)
4593           sinkt(k)=dsin(k*theti2)
4594         enddo
4595         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4596 #ifdef OSF
4597           phii=phi(i)
4598           if (phii.ne.phii) phii=150.0
4599 #else
4600           phii=phi(i)
4601 #endif
4602           ityp1=ithetyp((itype(i-2)))
4603 C propagation of chirality for glycine type
4604           do k=1,nsingle
4605             cosph1(k)=dcos(k*phii)
4606             sinph1(k)=dsin(k*phii)
4607           enddo
4608         else
4609           phii=0.0d0
4610           ityp1=nthetyp+1
4611           do k=1,nsingle
4612             cosph1(k)=0.0d0
4613             sinph1(k)=0.0d0
4614           enddo
4615         endif
4616         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4617 #ifdef OSF
4618           phii1=phi(i+1)
4619           if (phii1.ne.phii1) phii1=150.0
4620           phii1=pinorm(phii1)
4621 #else
4622           phii1=phi(i+1)
4623 #endif
4624           ityp3=ithetyp((itype(i)))
4625           do k=1,nsingle
4626             cosph2(k)=dcos(k*phii1)
4627             sinph2(k)=dsin(k*phii1)
4628           enddo
4629         else
4630           phii1=0.0d0
4631           ityp3=nthetyp+1
4632           do k=1,nsingle
4633             cosph2(k)=0.0d0
4634             sinph2(k)=0.0d0
4635           enddo
4636         endif
4637         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4638         do k=1,ndouble
4639           do l=1,k-1
4640             ccl=cosph1(l)*cosph2(k-l)
4641             ssl=sinph1(l)*sinph2(k-l)
4642             scl=sinph1(l)*cosph2(k-l)
4643             csl=cosph1(l)*sinph2(k-l)
4644             cosph1ph2(l,k)=ccl-ssl
4645             cosph1ph2(k,l)=ccl+ssl
4646             sinph1ph2(l,k)=scl+csl
4647             sinph1ph2(k,l)=scl-csl
4648           enddo
4649         enddo
4650         if (lprn) then
4651         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4652      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4653         write (iout,*) "coskt and sinkt"
4654         do k=1,nntheterm
4655           write (iout,*) k,coskt(k),sinkt(k)
4656         enddo
4657         endif
4658         do k=1,ntheterm
4659           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4660           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4661      &      *coskt(k)
4662           if (lprn)
4663      &    write (iout,*) "k",k,"
4664      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4665      &     " ethetai",ethetai
4666         enddo
4667         if (lprn) then
4668         write (iout,*) "cosph and sinph"
4669         do k=1,nsingle
4670           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4671         enddo
4672         write (iout,*) "cosph1ph2 and sinph2ph2"
4673         do k=2,ndouble
4674           do l=1,k-1
4675             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4676      &         sinph1ph2(l,k),sinph1ph2(k,l)
4677           enddo
4678         enddo
4679         write(iout,*) "ethetai",ethetai
4680         endif
4681         do m=1,ntheterm2
4682           do k=1,nsingle
4683             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4684      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4685      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4686      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4687             ethetai=ethetai+sinkt(m)*aux
4688             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4689             dephii=dephii+k*sinkt(m)*(
4690      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4691      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4692             dephii1=dephii1+k*sinkt(m)*(
4693      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4694      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4695             if (lprn)
4696      &      write (iout,*) "m",m," k",k," bbthet",
4697      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4698      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4699      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4700      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4701           enddo
4702         enddo
4703         if (lprn)
4704      &  write(iout,*) "ethetai",ethetai
4705         do m=1,ntheterm3
4706           do k=2,ndouble
4707             do l=1,k-1
4708               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4709      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4710      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4711      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4712               ethetai=ethetai+sinkt(m)*aux
4713               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4714               dephii=dephii+l*sinkt(m)*(
4715      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4716      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4717      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4718      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4719               dephii1=dephii1+(k-l)*sinkt(m)*(
4720      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4721      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4722      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4723      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4724               if (lprn) then
4725               write (iout,*) "m",m," k",k," l",l," ffthet",
4726      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4727      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4728      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4729      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4730      &            " ethetai",ethetai
4731               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4732      &            cosph1ph2(k,l)*sinkt(m),
4733      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4734               endif
4735             enddo
4736           enddo
4737         enddo
4738 10      continue
4739 c        lprn1=.true.
4740         if (lprn1)
4741      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4742      &   i,theta(i)*rad2deg,phii*rad2deg,
4743      &   phii1*rad2deg,ethetai
4744 c        lprn1=.false.
4745         etheta=etheta+ethetai
4746         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4747         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4748         gloc(nphi+i-2,icg)=wang*dethetai
4749       enddo
4750       return
4751       end
4752 #endif
4753 #ifdef CRYST_SC
4754 c-----------------------------------------------------------------------------
4755       subroutine esc(escloc)
4756 C Calculate the local energy of a side chain and its derivatives in the
4757 C corresponding virtual-bond valence angles THETA and the spherical angles
4758 C ALPHA and OMEGA.
4759       implicit real*8 (a-h,o-z)
4760       include 'DIMENSIONS'
4761       include 'COMMON.GEO'
4762       include 'COMMON.LOCAL'
4763       include 'COMMON.VAR'
4764       include 'COMMON.INTERACT'
4765       include 'COMMON.DERIV'
4766       include 'COMMON.CHAIN'
4767       include 'COMMON.IOUNITS'
4768       include 'COMMON.NAMES'
4769       include 'COMMON.FFIELD'
4770       include 'COMMON.CONTROL'
4771       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4772      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4773       common /sccalc/ time11,time12,time112,theti,it,nlobit
4774       delta=0.02d0*pi
4775       escloc=0.0D0
4776 c     write (iout,'(a)') 'ESC'
4777       do i=loc_start,loc_end
4778         it=itype(i)
4779         if (it.eq.ntyp1) cycle
4780         if (it.eq.10) goto 1
4781         nlobit=nlob(iabs(it))
4782 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4783 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4784         theti=theta(i+1)-pipol
4785         x(1)=dtan(theti)
4786         x(2)=alph(i)
4787         x(3)=omeg(i)
4788
4789         if (x(2).gt.pi-delta) then
4790           xtemp(1)=x(1)
4791           xtemp(2)=pi-delta
4792           xtemp(3)=x(3)
4793           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4794           xtemp(2)=pi
4795           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4796           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4797      &        escloci,dersc(2))
4798           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4799      &        ddersc0(1),dersc(1))
4800           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4801      &        ddersc0(3),dersc(3))
4802           xtemp(2)=pi-delta
4803           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4804           xtemp(2)=pi
4805           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4806           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4807      &            dersc0(2),esclocbi,dersc02)
4808           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4809      &            dersc12,dersc01)
4810           call splinthet(x(2),0.5d0*delta,ss,ssd)
4811           dersc0(1)=dersc01
4812           dersc0(2)=dersc02
4813           dersc0(3)=0.0d0
4814           do k=1,3
4815             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4816           enddo
4817           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4818 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4819 c    &             esclocbi,ss,ssd
4820           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4821 c         escloci=esclocbi
4822 c         write (iout,*) escloci
4823         else if (x(2).lt.delta) then
4824           xtemp(1)=x(1)
4825           xtemp(2)=delta
4826           xtemp(3)=x(3)
4827           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4828           xtemp(2)=0.0d0
4829           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4830           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4831      &        escloci,dersc(2))
4832           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4833      &        ddersc0(1),dersc(1))
4834           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4835      &        ddersc0(3),dersc(3))
4836           xtemp(2)=delta
4837           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4838           xtemp(2)=0.0d0
4839           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4840           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4841      &            dersc0(2),esclocbi,dersc02)
4842           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4843      &            dersc12,dersc01)
4844           dersc0(1)=dersc01
4845           dersc0(2)=dersc02
4846           dersc0(3)=0.0d0
4847           call splinthet(x(2),0.5d0*delta,ss,ssd)
4848           do k=1,3
4849             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4850           enddo
4851           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4852 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4853 c    &             esclocbi,ss,ssd
4854           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4855 c         write (iout,*) escloci
4856         else
4857           call enesc(x,escloci,dersc,ddummy,.false.)
4858         endif
4859
4860         escloc=escloc+escloci
4861         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4862      &     'escloc',i,escloci
4863 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4864
4865         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4866      &   wscloc*dersc(1)
4867         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4868         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4869     1   continue
4870       enddo
4871       return
4872       end
4873 C---------------------------------------------------------------------------
4874       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4875       implicit real*8 (a-h,o-z)
4876       include 'DIMENSIONS'
4877       include 'COMMON.GEO'
4878       include 'COMMON.LOCAL'
4879       include 'COMMON.IOUNITS'
4880       common /sccalc/ time11,time12,time112,theti,it,nlobit
4881       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4882       double precision contr(maxlob,-1:1)
4883       logical mixed
4884 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4885         escloc_i=0.0D0
4886         do j=1,3
4887           dersc(j)=0.0D0
4888           if (mixed) ddersc(j)=0.0d0
4889         enddo
4890         x3=x(3)
4891
4892 C Because of periodicity of the dependence of the SC energy in omega we have
4893 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4894 C To avoid underflows, first compute & store the exponents.
4895
4896         do iii=-1,1
4897
4898           x(3)=x3+iii*dwapi
4899
4900           do j=1,nlobit
4901             do k=1,3
4902               z(k)=x(k)-censc(k,j,it)
4903             enddo
4904             do k=1,3
4905               Axk=0.0D0
4906               do l=1,3
4907                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4908               enddo
4909               Ax(k,j,iii)=Axk
4910             enddo
4911             expfac=0.0D0
4912             do k=1,3
4913               expfac=expfac+Ax(k,j,iii)*z(k)
4914             enddo
4915             contr(j,iii)=expfac
4916           enddo ! j
4917
4918         enddo ! iii
4919
4920         x(3)=x3
4921 C As in the case of ebend, we want to avoid underflows in exponentiation and
4922 C subsequent NaNs and INFs in energy calculation.
4923 C Find the largest exponent
4924         emin=contr(1,-1)
4925         do iii=-1,1
4926           do j=1,nlobit
4927             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4928           enddo
4929         enddo
4930         emin=0.5D0*emin
4931 cd      print *,'it=',it,' emin=',emin
4932
4933 C Compute the contribution to SC energy and derivatives
4934         do iii=-1,1
4935
4936           do j=1,nlobit
4937 #ifdef OSF
4938             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4939             if(adexp.ne.adexp) adexp=1.0
4940             expfac=dexp(adexp)
4941 #else
4942             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4943 #endif
4944 cd          print *,'j=',j,' expfac=',expfac
4945             escloc_i=escloc_i+expfac
4946             do k=1,3
4947               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4948             enddo
4949             if (mixed) then
4950               do k=1,3,2
4951                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4952      &            +gaussc(k,2,j,it))*expfac
4953               enddo
4954             endif
4955           enddo
4956
4957         enddo ! iii
4958
4959         dersc(1)=dersc(1)/cos(theti)**2
4960         ddersc(1)=ddersc(1)/cos(theti)**2
4961         ddersc(3)=ddersc(3)
4962
4963         escloci=-(dlog(escloc_i)-emin)
4964         do j=1,3
4965           dersc(j)=dersc(j)/escloc_i
4966         enddo
4967         if (mixed) then
4968           do j=1,3,2
4969             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4970           enddo
4971         endif
4972       return
4973       end
4974 C------------------------------------------------------------------------------
4975       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4976       implicit real*8 (a-h,o-z)
4977       include 'DIMENSIONS'
4978       include 'COMMON.GEO'
4979       include 'COMMON.LOCAL'
4980       include 'COMMON.IOUNITS'
4981       common /sccalc/ time11,time12,time112,theti,it,nlobit
4982       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4983       double precision contr(maxlob)
4984       logical mixed
4985
4986       escloc_i=0.0D0
4987
4988       do j=1,3
4989         dersc(j)=0.0D0
4990       enddo
4991
4992       do j=1,nlobit
4993         do k=1,2
4994           z(k)=x(k)-censc(k,j,it)
4995         enddo
4996         z(3)=dwapi
4997         do k=1,3
4998           Axk=0.0D0
4999           do l=1,3
5000             Axk=Axk+gaussc(l,k,j,it)*z(l)
5001           enddo
5002           Ax(k,j)=Axk
5003         enddo
5004         expfac=0.0D0
5005         do k=1,3
5006           expfac=expfac+Ax(k,j)*z(k)
5007         enddo
5008         contr(j)=expfac
5009       enddo ! j
5010
5011 C As in the case of ebend, we want to avoid underflows in exponentiation and
5012 C subsequent NaNs and INFs in energy calculation.
5013 C Find the largest exponent
5014       emin=contr(1)
5015       do j=1,nlobit
5016         if (emin.gt.contr(j)) emin=contr(j)
5017       enddo
5018       emin=0.5D0*emin
5019
5020 C Compute the contribution to SC energy and derivatives
5021
5022       dersc12=0.0d0
5023       do j=1,nlobit
5024         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5025         escloc_i=escloc_i+expfac
5026         do k=1,2
5027           dersc(k)=dersc(k)+Ax(k,j)*expfac
5028         enddo
5029         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5030      &            +gaussc(1,2,j,it))*expfac
5031         dersc(3)=0.0d0
5032       enddo
5033
5034       dersc(1)=dersc(1)/cos(theti)**2
5035       dersc12=dersc12/cos(theti)**2
5036       escloci=-(dlog(escloc_i)-emin)
5037       do j=1,2
5038         dersc(j)=dersc(j)/escloc_i
5039       enddo
5040       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5041       return
5042       end
5043 #else
5044 c----------------------------------------------------------------------------------
5045       subroutine esc(escloc)
5046 C Calculate the local energy of a side chain and its derivatives in the
5047 C corresponding virtual-bond valence angles THETA and the spherical angles
5048 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5049 C added by Urszula Kozlowska. 07/11/2007
5050 C
5051       implicit real*8 (a-h,o-z)
5052       include 'DIMENSIONS'
5053       include 'COMMON.GEO'
5054       include 'COMMON.LOCAL'
5055       include 'COMMON.VAR'
5056       include 'COMMON.SCROT'
5057       include 'COMMON.INTERACT'
5058       include 'COMMON.DERIV'
5059       include 'COMMON.CHAIN'
5060       include 'COMMON.IOUNITS'
5061       include 'COMMON.NAMES'
5062       include 'COMMON.FFIELD'
5063       include 'COMMON.CONTROL'
5064       include 'COMMON.VECTORS'
5065       double precision x_prime(3),y_prime(3),z_prime(3)
5066      &    , sumene,dsc_i,dp2_i,x(65),
5067      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5068      &    de_dxx,de_dyy,de_dzz,de_dt
5069       double precision s1_t,s1_6_t,s2_t,s2_6_t
5070       double precision
5071      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5072      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5073      & dt_dCi(3),dt_dCi1(3)
5074       common /sccalc/ time11,time12,time112,theti,it,nlobit
5075       delta=0.02d0*pi
5076       escloc=0.0D0
5077       do i=loc_start,loc_end
5078         if (itype(i).eq.ntyp1) cycle
5079         costtab(i+1) =dcos(theta(i+1))
5080         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5081         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5082         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5083         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5084         cosfac=dsqrt(cosfac2)
5085         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5086         sinfac=dsqrt(sinfac2)
5087         it=iabs(itype(i))
5088         if (it.eq.10) goto 1
5089 c
5090 C  Compute the axes of tghe local cartesian coordinates system; store in
5091 c   x_prime, y_prime and z_prime
5092 c
5093         do j=1,3
5094           x_prime(j) = 0.00
5095           y_prime(j) = 0.00
5096           z_prime(j) = 0.00
5097         enddo
5098 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5099 C     &   dc_norm(3,i+nres)
5100         do j = 1,3
5101           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5102           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5103         enddo
5104         do j = 1,3
5105           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5106         enddo
5107 c       write (2,*) "i",i
5108 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5109 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5110 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5111 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5112 c      & " xy",scalar(x_prime(1),y_prime(1)),
5113 c      & " xz",scalar(x_prime(1),z_prime(1)),
5114 c      & " yy",scalar(y_prime(1),y_prime(1)),
5115 c      & " yz",scalar(y_prime(1),z_prime(1)),
5116 c      & " zz",scalar(z_prime(1),z_prime(1))
5117 c
5118 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5119 C to local coordinate system. Store in xx, yy, zz.
5120 c
5121         xx=0.0d0
5122         yy=0.0d0
5123         zz=0.0d0
5124         do j = 1,3
5125           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5126           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5127           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5128         enddo
5129
5130         xxtab(i)=xx
5131         yytab(i)=yy
5132         zztab(i)=zz
5133 C
5134 C Compute the energy of the ith side cbain
5135 C
5136 c        write (2,*) "xx",xx," yy",yy," zz",zz
5137         it=iabs(itype(i))
5138         do j = 1,65
5139           x(j) = sc_parmin(j,it)
5140         enddo
5141 #ifdef CHECK_COORD
5142 Cc diagnostics - remove later
5143         xx1 = dcos(alph(2))
5144         yy1 = dsin(alph(2))*dcos(omeg(2))
5145         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5146         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5147      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5148      &    xx1,yy1,zz1
5149 C,"  --- ", xx_w,yy_w,zz_w
5150 c end diagnostics
5151 #endif
5152         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5153      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5154      &   + x(10)*yy*zz
5155         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5156      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5157      & + x(20)*yy*zz
5158         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5159      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5160      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5161      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5162      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5163      &  +x(40)*xx*yy*zz
5164         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5165      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5166      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5167      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5168      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5169      &  +x(60)*xx*yy*zz
5170         dsc_i   = 0.743d0+x(61)
5171         dp2_i   = 1.9d0+x(62)
5172         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5173      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5174         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5175      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5176         s1=(1+x(63))/(0.1d0 + dscp1)
5177         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5178         s2=(1+x(65))/(0.1d0 + dscp2)
5179         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5180         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5181      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5182 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5183 c     &   sumene4,
5184 c     &   dscp1,dscp2,sumene
5185 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5186         escloc = escloc + sumene
5187 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5188 c     & ,zz,xx,yy
5189 c#define DEBUG
5190 #ifdef DEBUG
5191 C
5192 C This section to check the numerical derivatives of the energy of ith side
5193 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5194 C #define DEBUG in the code to turn it on.
5195 C
5196         write (2,*) "sumene               =",sumene
5197         aincr=1.0d-7
5198         xxsave=xx
5199         xx=xx+aincr
5200         write (2,*) xx,yy,zz
5201         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5202         de_dxx_num=(sumenep-sumene)/aincr
5203         xx=xxsave
5204         write (2,*) "xx+ sumene from enesc=",sumenep
5205         yysave=yy
5206         yy=yy+aincr
5207         write (2,*) xx,yy,zz
5208         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5209         de_dyy_num=(sumenep-sumene)/aincr
5210         yy=yysave
5211         write (2,*) "yy+ sumene from enesc=",sumenep
5212         zzsave=zz
5213         zz=zz+aincr
5214         write (2,*) xx,yy,zz
5215         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5216         de_dzz_num=(sumenep-sumene)/aincr
5217         zz=zzsave
5218         write (2,*) "zz+ sumene from enesc=",sumenep
5219         costsave=cost2tab(i+1)
5220         sintsave=sint2tab(i+1)
5221         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5222         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5223         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5224         de_dt_num=(sumenep-sumene)/aincr
5225         write (2,*) " t+ sumene from enesc=",sumenep
5226         cost2tab(i+1)=costsave
5227         sint2tab(i+1)=sintsave
5228 C End of diagnostics section.
5229 #endif
5230 C
5231 C Compute the gradient of esc
5232 C
5233 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5234         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5235         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5236         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5237         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5238         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5239         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5240         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5241         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5242         pom1=(sumene3*sint2tab(i+1)+sumene1)
5243      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5244         pom2=(sumene4*cost2tab(i+1)+sumene2)
5245      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5246         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5247         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5248      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5249      &  +x(40)*yy*zz
5250         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5251         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5252      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5253      &  +x(60)*yy*zz
5254         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5255      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5256      &        +(pom1+pom2)*pom_dx
5257 #ifdef DEBUG
5258         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5259 #endif
5260 C
5261         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5262         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5263      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5264      &  +x(40)*xx*zz
5265         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5266         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5267      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5268      &  +x(59)*zz**2 +x(60)*xx*zz
5269         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5270      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5271      &        +(pom1-pom2)*pom_dy
5272 #ifdef DEBUG
5273         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5274 #endif
5275 C
5276         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5277      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5278      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5279      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5280      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5281      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5282      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5283      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5284 #ifdef DEBUG
5285         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5286 #endif
5287 C
5288         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5289      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5290      &  +pom1*pom_dt1+pom2*pom_dt2
5291 #ifdef DEBUG
5292         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5293 #endif
5294 c#undef DEBUG
5295 c
5296 C
5297        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5298        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5299        cosfac2xx=cosfac2*xx
5300        sinfac2yy=sinfac2*yy
5301        do k = 1,3
5302          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5303      &      vbld_inv(i+1)
5304          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5305      &      vbld_inv(i)
5306          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5307          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5308 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5309 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5310 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5311 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5312          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5313          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5314          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5315          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5316          dZZ_Ci1(k)=0.0d0
5317          dZZ_Ci(k)=0.0d0
5318          do j=1,3
5319            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5320      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5321            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5322      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5323          enddo
5324
5325          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5326          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5327          dZZ_XYZ(k)=vbld_inv(i+nres)*
5328      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5329 c
5330          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5331          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5332        enddo
5333
5334        do k=1,3
5335          dXX_Ctab(k,i)=dXX_Ci(k)
5336          dXX_C1tab(k,i)=dXX_Ci1(k)
5337          dYY_Ctab(k,i)=dYY_Ci(k)
5338          dYY_C1tab(k,i)=dYY_Ci1(k)
5339          dZZ_Ctab(k,i)=dZZ_Ci(k)
5340          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5341          dXX_XYZtab(k,i)=dXX_XYZ(k)
5342          dYY_XYZtab(k,i)=dYY_XYZ(k)
5343          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5344        enddo
5345
5346        do k = 1,3
5347 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5348 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5349 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5350 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5351 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5352 c     &    dt_dci(k)
5353 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5354 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5355          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5356      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5357          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5358      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5359          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5360      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5361        enddo
5362 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5363 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5364
5365 C to check gradient call subroutine check_grad
5366
5367     1 continue
5368       enddo
5369       return
5370       end
5371 c------------------------------------------------------------------------------
5372       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5373       implicit none
5374       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5375      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5376       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5377      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5378      &   + x(10)*yy*zz
5379       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5380      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5381      & + x(20)*yy*zz
5382       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5383      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5384      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5385      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5386      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5387      &  +x(40)*xx*yy*zz
5388       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5389      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5390      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5391      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5392      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5393      &  +x(60)*xx*yy*zz
5394       dsc_i   = 0.743d0+x(61)
5395       dp2_i   = 1.9d0+x(62)
5396       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5397      &          *(xx*cost2+yy*sint2))
5398       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5399      &          *(xx*cost2-yy*sint2))
5400       s1=(1+x(63))/(0.1d0 + dscp1)
5401       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5402       s2=(1+x(65))/(0.1d0 + dscp2)
5403       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5404       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5405      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5406       enesc=sumene
5407       return
5408       end
5409 #endif
5410 c------------------------------------------------------------------------------
5411       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5412 C
5413 C This procedure calculates two-body contact function g(rij) and its derivative:
5414 C
5415 C           eps0ij                                     !       x < -1
5416 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5417 C            0                                         !       x > 1
5418 C
5419 C where x=(rij-r0ij)/delta
5420 C
5421 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5422 C
5423       implicit none
5424       double precision rij,r0ij,eps0ij,fcont,fprimcont
5425       double precision x,x2,x4,delta
5426 c     delta=0.02D0*r0ij
5427 c      delta=0.2D0*r0ij
5428       x=(rij-r0ij)/delta
5429       if (x.lt.-1.0D0) then
5430         fcont=eps0ij
5431         fprimcont=0.0D0
5432       else if (x.le.1.0D0) then
5433         x2=x*x
5434         x4=x2*x2
5435         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5436         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5437       else
5438         fcont=0.0D0
5439         fprimcont=0.0D0
5440       endif
5441       return
5442       end
5443 c------------------------------------------------------------------------------
5444       subroutine splinthet(theti,delta,ss,ssder)
5445       implicit real*8 (a-h,o-z)
5446       include 'DIMENSIONS'
5447       include 'COMMON.VAR'
5448       include 'COMMON.GEO'
5449       thetup=pi-delta
5450       thetlow=delta
5451       if (theti.gt.pipol) then
5452         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5453       else
5454         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5455         ssder=-ssder
5456       endif
5457       return
5458       end
5459 c------------------------------------------------------------------------------
5460       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5461       implicit none
5462       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5463       double precision ksi,ksi2,ksi3,a1,a2,a3
5464       a1=fprim0*delta/(f1-f0)
5465       a2=3.0d0-2.0d0*a1
5466       a3=a1-2.0d0
5467       ksi=(x-x0)/delta
5468       ksi2=ksi*ksi
5469       ksi3=ksi2*ksi
5470       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5471       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5472       return
5473       end
5474 c------------------------------------------------------------------------------
5475       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5476       implicit none
5477       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5478       double precision ksi,ksi2,ksi3,a1,a2,a3
5479       ksi=(x-x0)/delta
5480       ksi2=ksi*ksi
5481       ksi3=ksi2*ksi
5482       a1=fprim0x*delta
5483       a2=3*(f1x-f0x)-2*fprim0x*delta
5484       a3=fprim0x*delta-2*(f1x-f0x)
5485       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5486       return
5487       end
5488 C-----------------------------------------------------------------------------
5489 #ifdef CRYST_TOR
5490 C-----------------------------------------------------------------------------
5491       subroutine etor(etors,edihcnstr)
5492       implicit real*8 (a-h,o-z)
5493       include 'DIMENSIONS'
5494       include 'COMMON.VAR'
5495       include 'COMMON.GEO'
5496       include 'COMMON.LOCAL'
5497       include 'COMMON.TORSION'
5498       include 'COMMON.INTERACT'
5499       include 'COMMON.DERIV'
5500       include 'COMMON.CHAIN'
5501       include 'COMMON.NAMES'
5502       include 'COMMON.IOUNITS'
5503       include 'COMMON.FFIELD'
5504       include 'COMMON.TORCNSTR'
5505       include 'COMMON.CONTROL'
5506       logical lprn
5507 C Set lprn=.true. for debugging
5508       lprn=.false.
5509 c      lprn=.true.
5510       etors=0.0D0
5511       do i=iphi_start,iphi_end
5512       etors_ii=0.0D0
5513         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5514      &      .or. itype(i).eq.ntyp1) cycle
5515         itori=itortyp(itype(i-2))
5516         itori1=itortyp(itype(i-1))
5517         phii=phi(i)
5518         gloci=0.0D0
5519 C Proline-Proline pair is a special case...
5520         if (itori.eq.3 .and. itori1.eq.3) then
5521           if (phii.gt.-dwapi3) then
5522             cosphi=dcos(3*phii)
5523             fac=1.0D0/(1.0D0-cosphi)
5524             etorsi=v1(1,3,3)*fac
5525             etorsi=etorsi+etorsi
5526             etors=etors+etorsi-v1(1,3,3)
5527             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5528             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5529           endif
5530           do j=1,3
5531             v1ij=v1(j+1,itori,itori1)
5532             v2ij=v2(j+1,itori,itori1)
5533             cosphi=dcos(j*phii)
5534             sinphi=dsin(j*phii)
5535             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5536             if (energy_dec) etors_ii=etors_ii+
5537      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5538             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5539           enddo
5540         else
5541           do j=1,nterm_old
5542             v1ij=v1(j,itori,itori1)
5543             v2ij=v2(j,itori,itori1)
5544             cosphi=dcos(j*phii)
5545             sinphi=dsin(j*phii)
5546             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5547             if (energy_dec) etors_ii=etors_ii+
5548      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5549             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5550           enddo
5551         endif
5552         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5553              'etor',i,etors_ii
5554         if (lprn)
5555      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5556      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5557      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5558         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5559 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5560       enddo
5561 ! 6/20/98 - dihedral angle constraints
5562       edihcnstr=0.0d0
5563       do i=1,ndih_constr
5564         itori=idih_constr(i)
5565         phii=phi(itori)
5566         difi=phii-phi0(i)
5567         if (difi.gt.drange(i)) then
5568           difi=difi-drange(i)
5569           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5570           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5571         else if (difi.lt.-drange(i)) then
5572           difi=difi+drange(i)
5573           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5574           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5575         endif
5576 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5577 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5578       enddo
5579 !      write (iout,*) 'edihcnstr',edihcnstr
5580       return
5581       end
5582 c------------------------------------------------------------------------------
5583       subroutine etor_d(etors_d)
5584       etors_d=0.0d0
5585       return
5586       end
5587 c----------------------------------------------------------------------------
5588 #else
5589       subroutine etor(etors,edihcnstr)
5590       implicit real*8 (a-h,o-z)
5591       include 'DIMENSIONS'
5592       include 'COMMON.VAR'
5593       include 'COMMON.GEO'
5594       include 'COMMON.LOCAL'
5595       include 'COMMON.TORSION'
5596       include 'COMMON.INTERACT'
5597       include 'COMMON.DERIV'
5598       include 'COMMON.CHAIN'
5599       include 'COMMON.NAMES'
5600       include 'COMMON.IOUNITS'
5601       include 'COMMON.FFIELD'
5602       include 'COMMON.TORCNSTR'
5603       include 'COMMON.CONTROL'
5604       logical lprn
5605 C Set lprn=.true. for debugging
5606       lprn=.false.
5607 c     lprn=.true.
5608       etors=0.0D0
5609       do i=iphi_start,iphi_end
5610         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5611      &       .or. itype(i).eq.ntyp1) cycle
5612         etors_ii=0.0D0
5613          if (iabs(itype(i)).eq.20) then
5614          iblock=2
5615          else
5616          iblock=1
5617          endif
5618         itori=itortyp(itype(i-2))
5619         itori1=itortyp(itype(i-1))
5620         phii=phi(i)
5621         gloci=0.0D0
5622 C Regular cosine and sine terms
5623         do j=1,nterm(itori,itori1,iblock)
5624           v1ij=v1(j,itori,itori1,iblock)
5625           v2ij=v2(j,itori,itori1,iblock)
5626           cosphi=dcos(j*phii)
5627           sinphi=dsin(j*phii)
5628           etors=etors+v1ij*cosphi+v2ij*sinphi
5629           if (energy_dec) etors_ii=etors_ii+
5630      &                v1ij*cosphi+v2ij*sinphi
5631           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5632         enddo
5633 C Lorentz terms
5634 C                         v1
5635 C  E = SUM ----------------------------------- - v1
5636 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5637 C
5638         cosphi=dcos(0.5d0*phii)
5639         sinphi=dsin(0.5d0*phii)
5640         do j=1,nlor(itori,itori1,iblock)
5641           vl1ij=vlor1(j,itori,itori1)
5642           vl2ij=vlor2(j,itori,itori1)
5643           vl3ij=vlor3(j,itori,itori1)
5644           pom=vl2ij*cosphi+vl3ij*sinphi
5645           pom1=1.0d0/(pom*pom+1.0d0)
5646           etors=etors+vl1ij*pom1
5647           if (energy_dec) etors_ii=etors_ii+
5648      &                vl1ij*pom1
5649           pom=-pom*pom1*pom1
5650           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5651         enddo
5652 C Subtract the constant term
5653         etors=etors-v0(itori,itori1,iblock)
5654           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5655      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5656         if (lprn)
5657      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5658      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5659      &  (v1(j,itori,itori1,iblock),j=1,6),
5660      &  (v2(j,itori,itori1,iblock),j=1,6)
5661         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5662 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5663       enddo
5664 ! 6/20/98 - dihedral angle constraints
5665       edihcnstr=0.0d0
5666 c      do i=1,ndih_constr
5667       do i=idihconstr_start,idihconstr_end
5668         itori=idih_constr(i)
5669         phii=phi(itori)
5670         difi=pinorm(phii-phi0(i))
5671         if (difi.gt.drange(i)) then
5672           difi=difi-drange(i)
5673           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5674           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5675         else if (difi.lt.-drange(i)) then
5676           difi=difi+drange(i)
5677           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5678           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5679         else
5680           difi=0.0
5681         endif
5682 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5683 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5684 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5685       enddo
5686 cd       write (iout,*) 'edihcnstr',edihcnstr
5687       return
5688       end
5689 c----------------------------------------------------------------------------
5690       subroutine etor_d(etors_d)
5691 C 6/23/01 Compute double torsional energy
5692       implicit real*8 (a-h,o-z)
5693       include 'DIMENSIONS'
5694       include 'COMMON.VAR'
5695       include 'COMMON.GEO'
5696       include 'COMMON.LOCAL'
5697       include 'COMMON.TORSION'
5698       include 'COMMON.INTERACT'
5699       include 'COMMON.DERIV'
5700       include 'COMMON.CHAIN'
5701       include 'COMMON.NAMES'
5702       include 'COMMON.IOUNITS'
5703       include 'COMMON.FFIELD'
5704       include 'COMMON.TORCNSTR'
5705       logical lprn
5706 C Set lprn=.true. for debugging
5707       lprn=.false.
5708 c     lprn=.true.
5709       etors_d=0.0D0
5710 c      write(iout,*) "a tu??"
5711       do i=iphid_start,iphid_end
5712         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5713      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5714         itori=itortyp(itype(i-2))
5715         itori1=itortyp(itype(i-1))
5716         itori2=itortyp(itype(i))
5717         phii=phi(i)
5718         phii1=phi(i+1)
5719         gloci1=0.0D0
5720         gloci2=0.0D0
5721         iblock=1
5722         if (iabs(itype(i+1)).eq.20) iblock=2
5723
5724 C Regular cosine and sine terms
5725         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5726           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5727           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5728           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5729           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5730           cosphi1=dcos(j*phii)
5731           sinphi1=dsin(j*phii)
5732           cosphi2=dcos(j*phii1)
5733           sinphi2=dsin(j*phii1)
5734           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5735      &     v2cij*cosphi2+v2sij*sinphi2
5736           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5737           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5738         enddo
5739         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5740           do l=1,k-1
5741             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5742             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5743             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5744             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5745             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5746             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5747             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5748             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5749             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5750      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5751             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5752      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5753             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5754      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5755           enddo
5756         enddo
5757         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5758         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5759       enddo
5760       return
5761       end
5762 #endif
5763 c------------------------------------------------------------------------------
5764       subroutine eback_sc_corr(esccor)
5765 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5766 c        conformational states; temporarily implemented as differences
5767 c        between UNRES torsional potentials (dependent on three types of
5768 c        residues) and the torsional potentials dependent on all 20 types
5769 c        of residues computed from AM1  energy surfaces of terminally-blocked
5770 c        amino-acid residues.
5771       implicit real*8 (a-h,o-z)
5772       include 'DIMENSIONS'
5773       include 'COMMON.VAR'
5774       include 'COMMON.GEO'
5775       include 'COMMON.LOCAL'
5776       include 'COMMON.TORSION'
5777       include 'COMMON.SCCOR'
5778       include 'COMMON.INTERACT'
5779       include 'COMMON.DERIV'
5780       include 'COMMON.CHAIN'
5781       include 'COMMON.NAMES'
5782       include 'COMMON.IOUNITS'
5783       include 'COMMON.FFIELD'
5784       include 'COMMON.CONTROL'
5785       logical lprn
5786 C Set lprn=.true. for debugging
5787       lprn=.false.
5788 c      lprn=.true.
5789 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5790       esccor=0.0D0
5791       do i=itau_start,itau_end
5792         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5793         esccor_ii=0.0D0
5794         isccori=isccortyp(itype(i-2))
5795         isccori1=isccortyp(itype(i-1))
5796 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5797         phii=phi(i)
5798         do intertyp=1,3 !intertyp
5799 cc Added 09 May 2012 (Adasko)
5800 cc  Intertyp means interaction type of backbone mainchain correlation:
5801 c   1 = SC...Ca...Ca...Ca
5802 c   2 = Ca...Ca...Ca...SC
5803 c   3 = SC...Ca...Ca...SCi
5804         gloci=0.0D0
5805         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5806      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5807      &      (itype(i-1).eq.ntyp1)))
5808      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5809      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5810      &     .or.(itype(i).eq.ntyp1)))
5811      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5812      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5813      &      (itype(i-3).eq.ntyp1)))) cycle
5814         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5815         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5816      & cycle
5817        do j=1,nterm_sccor(isccori,isccori1)
5818           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5819           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5820           cosphi=dcos(j*tauangle(intertyp,i))
5821           sinphi=dsin(j*tauangle(intertyp,i))
5822           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5823           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5824         enddo
5825 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5826         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5827         if (lprn)
5828      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5829      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5830      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5831      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5832         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5833        enddo !intertyp
5834       enddo
5835
5836       return
5837       end
5838 c----------------------------------------------------------------------------
5839       subroutine multibody(ecorr)
5840 C This subroutine calculates multi-body contributions to energy following
5841 C the idea of Skolnick et al. If side chains I and J make a contact and
5842 C at the same time side chains I+1 and J+1 make a contact, an extra
5843 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5844       implicit real*8 (a-h,o-z)
5845       include 'DIMENSIONS'
5846       include 'COMMON.IOUNITS'
5847       include 'COMMON.DERIV'
5848       include 'COMMON.INTERACT'
5849       include 'COMMON.CONTACTS'
5850       double precision gx(3),gx1(3)
5851       logical lprn
5852
5853 C Set lprn=.true. for debugging
5854       lprn=.false.
5855
5856       if (lprn) then
5857         write (iout,'(a)') 'Contact function values:'
5858         do i=nnt,nct-2
5859           write (iout,'(i2,20(1x,i2,f10.5))')
5860      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5861         enddo
5862       endif
5863       ecorr=0.0D0
5864       do i=nnt,nct
5865         do j=1,3
5866           gradcorr(j,i)=0.0D0
5867           gradxorr(j,i)=0.0D0
5868         enddo
5869       enddo
5870       do i=nnt,nct-2
5871
5872         DO ISHIFT = 3,4
5873
5874         i1=i+ishift
5875         num_conti=num_cont(i)
5876         num_conti1=num_cont(i1)
5877         do jj=1,num_conti
5878           j=jcont(jj,i)
5879           do kk=1,num_conti1
5880             j1=jcont(kk,i1)
5881             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5882 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5883 cd   &                   ' ishift=',ishift
5884 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5885 C The system gains extra energy.
5886               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5887             endif   ! j1==j+-ishift
5888           enddo     ! kk
5889         enddo       ! jj
5890
5891         ENDDO ! ISHIFT
5892
5893       enddo         ! i
5894       return
5895       end
5896 c------------------------------------------------------------------------------
5897       double precision function esccorr(i,j,k,l,jj,kk)
5898       implicit real*8 (a-h,o-z)
5899       include 'DIMENSIONS'
5900       include 'COMMON.IOUNITS'
5901       include 'COMMON.DERIV'
5902       include 'COMMON.INTERACT'
5903       include 'COMMON.CONTACTS'
5904       double precision gx(3),gx1(3)
5905       logical lprn
5906       lprn=.false.
5907       eij=facont(jj,i)
5908       ekl=facont(kk,k)
5909 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5910 C Calculate the multi-body contribution to energy.
5911 C Calculate multi-body contributions to the gradient.
5912 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5913 cd   & k,l,(gacont(m,kk,k),m=1,3)
5914       do m=1,3
5915         gx(m) =ekl*gacont(m,jj,i)
5916         gx1(m)=eij*gacont(m,kk,k)
5917         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5918         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5919         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5920         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5921       enddo
5922       do m=i,j-1
5923         do ll=1,3
5924           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5925         enddo
5926       enddo
5927       do m=k,l-1
5928         do ll=1,3
5929           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5930         enddo
5931       enddo
5932       esccorr=-eij*ekl
5933       return
5934       end
5935 c------------------------------------------------------------------------------
5936       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5937 C This subroutine calculates multi-body contributions to hydrogen-bonding
5938       implicit real*8 (a-h,o-z)
5939       include 'DIMENSIONS'
5940       include 'COMMON.IOUNITS'
5941 #ifdef MPI
5942       include "mpif.h"
5943       parameter (max_cont=maxconts)
5944       parameter (max_dim=26)
5945       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5946       double precision zapas(max_dim,maxconts,max_fg_procs),
5947      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5948       common /przechowalnia/ zapas
5949       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5950      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5951 #endif
5952       include 'COMMON.SETUP'
5953       include 'COMMON.FFIELD'
5954       include 'COMMON.DERIV'
5955       include 'COMMON.INTERACT'
5956       include 'COMMON.CONTACTS'
5957       include 'COMMON.CONTROL'
5958       include 'COMMON.LOCAL'
5959       double precision gx(3),gx1(3),time00
5960       logical lprn,ldone
5961
5962 C Set lprn=.true. for debugging
5963       lprn=.false.
5964 #ifdef MPI
5965       n_corr=0
5966       n_corr1=0
5967       if (nfgtasks.le.1) goto 30
5968       if (lprn) then
5969         write (iout,'(a)') 'Contact function values before RECEIVE:'
5970         do i=nnt,nct-2
5971           write (iout,'(2i3,50(1x,i2,f5.2))')
5972      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5973      &    j=1,num_cont_hb(i))
5974         enddo
5975       endif
5976       call flush(iout)
5977       do i=1,ntask_cont_from
5978         ncont_recv(i)=0
5979       enddo
5980       do i=1,ntask_cont_to
5981         ncont_sent(i)=0
5982       enddo
5983 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5984 c     & ntask_cont_to
5985 C Make the list of contacts to send to send to other procesors
5986 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5987 c      call flush(iout)
5988       do i=iturn3_start,iturn3_end
5989 c        write (iout,*) "make contact list turn3",i," num_cont",
5990 c     &    num_cont_hb(i)
5991         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5992       enddo
5993       do i=iturn4_start,iturn4_end
5994 c        write (iout,*) "make contact list turn4",i," num_cont",
5995 c     &   num_cont_hb(i)
5996         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5997       enddo
5998       do ii=1,nat_sent
5999         i=iat_sent(ii)
6000 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6001 c     &    num_cont_hb(i)
6002         do j=1,num_cont_hb(i)
6003         do k=1,4
6004           jjc=jcont_hb(j,i)
6005           iproc=iint_sent_local(k,jjc,ii)
6006 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6007           if (iproc.gt.0) then
6008             ncont_sent(iproc)=ncont_sent(iproc)+1
6009             nn=ncont_sent(iproc)
6010             zapas(1,nn,iproc)=i
6011             zapas(2,nn,iproc)=jjc
6012             zapas(3,nn,iproc)=facont_hb(j,i)
6013             zapas(4,nn,iproc)=ees0p(j,i)
6014             zapas(5,nn,iproc)=ees0m(j,i)
6015             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6016             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6017             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6018             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6019             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6020             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6021             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6022             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6023             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6024             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6025             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6026             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6027             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6028             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6029             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6030             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6031             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6032             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6033             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6034             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6035             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6036           endif
6037         enddo
6038         enddo
6039       enddo
6040       if (lprn) then
6041       write (iout,*)
6042      &  "Numbers of contacts to be sent to other processors",
6043      &  (ncont_sent(i),i=1,ntask_cont_to)
6044       write (iout,*) "Contacts sent"
6045       do ii=1,ntask_cont_to
6046         nn=ncont_sent(ii)
6047         iproc=itask_cont_to(ii)
6048         write (iout,*) nn," contacts to processor",iproc,
6049      &   " of CONT_TO_COMM group"
6050         do i=1,nn
6051           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6052         enddo
6053       enddo
6054       call flush(iout)
6055       endif
6056       CorrelType=477
6057       CorrelID=fg_rank+1
6058       CorrelType1=478
6059       CorrelID1=nfgtasks+fg_rank+1
6060       ireq=0
6061 C Receive the numbers of needed contacts from other processors
6062       do ii=1,ntask_cont_from
6063         iproc=itask_cont_from(ii)
6064         ireq=ireq+1
6065         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6066      &    FG_COMM,req(ireq),IERR)
6067       enddo
6068 c      write (iout,*) "IRECV ended"
6069 c      call flush(iout)
6070 C Send the number of contacts needed by other processors
6071       do ii=1,ntask_cont_to
6072         iproc=itask_cont_to(ii)
6073         ireq=ireq+1
6074         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6075      &    FG_COMM,req(ireq),IERR)
6076       enddo
6077 c      write (iout,*) "ISEND ended"
6078 c      write (iout,*) "number of requests (nn)",ireq
6079       call flush(iout)
6080       if (ireq.gt.0)
6081      &  call MPI_Waitall(ireq,req,status_array,ierr)
6082 c      write (iout,*)
6083 c     &  "Numbers of contacts to be received from other processors",
6084 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6085 c      call flush(iout)
6086 C Receive contacts
6087       ireq=0
6088       do ii=1,ntask_cont_from
6089         iproc=itask_cont_from(ii)
6090         nn=ncont_recv(ii)
6091 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6092 c     &   " of CONT_TO_COMM group"
6093         call flush(iout)
6094         if (nn.gt.0) then
6095           ireq=ireq+1
6096           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6097      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6098 c          write (iout,*) "ireq,req",ireq,req(ireq)
6099         endif
6100       enddo
6101 C Send the contacts to processors that need them
6102       do ii=1,ntask_cont_to
6103         iproc=itask_cont_to(ii)
6104         nn=ncont_sent(ii)
6105 c        write (iout,*) nn," contacts to processor",iproc,
6106 c     &   " of CONT_TO_COMM group"
6107         if (nn.gt.0) then
6108           ireq=ireq+1
6109           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6110      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6111 c          write (iout,*) "ireq,req",ireq,req(ireq)
6112 c          do i=1,nn
6113 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6114 c          enddo
6115         endif
6116       enddo
6117 c      write (iout,*) "number of requests (contacts)",ireq
6118 c      write (iout,*) "req",(req(i),i=1,4)
6119 c      call flush(iout)
6120       if (ireq.gt.0)
6121      & call MPI_Waitall(ireq,req,status_array,ierr)
6122       do iii=1,ntask_cont_from
6123         iproc=itask_cont_from(iii)
6124         nn=ncont_recv(iii)
6125         if (lprn) then
6126         write (iout,*) "Received",nn," contacts from processor",iproc,
6127      &   " of CONT_FROM_COMM group"
6128         call flush(iout)
6129         do i=1,nn
6130           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6131         enddo
6132         call flush(iout)
6133         endif
6134         do i=1,nn
6135           ii=zapas_recv(1,i,iii)
6136 c Flag the received contacts to prevent double-counting
6137           jj=-zapas_recv(2,i,iii)
6138 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6139 c          call flush(iout)
6140           nnn=num_cont_hb(ii)+1
6141           num_cont_hb(ii)=nnn
6142           jcont_hb(nnn,ii)=jj
6143           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6144           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6145           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6146           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6147           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6148           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6149           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6150           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6151           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6152           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6153           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6154           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6155           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6156           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6157           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6158           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6159           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6160           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6161           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6162           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6163           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6164           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6165           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6166           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6167         enddo
6168       enddo
6169       call flush(iout)
6170       if (lprn) then
6171         write (iout,'(a)') 'Contact function values after receive:'
6172         do i=nnt,nct-2
6173           write (iout,'(2i3,50(1x,i3,f5.2))')
6174      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6175      &    j=1,num_cont_hb(i))
6176         enddo
6177         call flush(iout)
6178       endif
6179    30 continue
6180 #endif
6181       if (lprn) then
6182         write (iout,'(a)') 'Contact function values:'
6183         do i=nnt,nct-2
6184           write (iout,'(2i3,50(1x,i3,f5.2))')
6185      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6186      &    j=1,num_cont_hb(i))
6187         enddo
6188       endif
6189       ecorr=0.0D0
6190 C Remove the loop below after debugging !!!
6191       do i=nnt,nct
6192         do j=1,3
6193           gradcorr(j,i)=0.0D0
6194           gradxorr(j,i)=0.0D0
6195         enddo
6196       enddo
6197 C Calculate the local-electrostatic correlation terms
6198       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6199         i1=i+1
6200         num_conti=num_cont_hb(i)
6201         num_conti1=num_cont_hb(i+1)
6202         do jj=1,num_conti
6203           j=jcont_hb(jj,i)
6204           jp=iabs(j)
6205           do kk=1,num_conti1
6206             j1=jcont_hb(kk,i1)
6207             jp1=iabs(j1)
6208 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6209 c     &         ' jj=',jj,' kk=',kk
6210             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6211      &          .or. j.lt.0 .and. j1.gt.0) .and.
6212      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6213 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6214 C The system gains extra energy.
6215               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6216               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6217      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6218               n_corr=n_corr+1
6219             else if (j1.eq.j) then
6220 C Contacts I-J and I-(J+1) occur simultaneously.
6221 C The system loses extra energy.
6222 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6223             endif
6224           enddo ! kk
6225           do kk=1,num_conti
6226             j1=jcont_hb(kk,i)
6227 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6228 c    &         ' jj=',jj,' kk=',kk
6229             if (j1.eq.j+1) then
6230 C Contacts I-J and (I+1)-J occur simultaneously.
6231 C The system loses extra energy.
6232 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6233             endif ! j1==j+1
6234           enddo ! kk
6235         enddo ! jj
6236       enddo ! i
6237       return
6238       end
6239 c------------------------------------------------------------------------------
6240       subroutine add_hb_contact(ii,jj,itask)
6241       implicit real*8 (a-h,o-z)
6242       include "DIMENSIONS"
6243       include "COMMON.IOUNITS"
6244       integer max_cont
6245       integer max_dim
6246       parameter (max_cont=maxconts)
6247       parameter (max_dim=26)
6248       include "COMMON.CONTACTS"
6249       double precision zapas(max_dim,maxconts,max_fg_procs),
6250      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6251       common /przechowalnia/ zapas
6252       integer i,j,ii,jj,iproc,itask(4),nn
6253 c      write (iout,*) "itask",itask
6254       do i=1,2
6255         iproc=itask(i)
6256         if (iproc.gt.0) then
6257           do j=1,num_cont_hb(ii)
6258             jjc=jcont_hb(j,ii)
6259 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6260             if (jjc.eq.jj) then
6261               ncont_sent(iproc)=ncont_sent(iproc)+1
6262               nn=ncont_sent(iproc)
6263               zapas(1,nn,iproc)=ii
6264               zapas(2,nn,iproc)=jjc
6265               zapas(3,nn,iproc)=facont_hb(j,ii)
6266               zapas(4,nn,iproc)=ees0p(j,ii)
6267               zapas(5,nn,iproc)=ees0m(j,ii)
6268               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6269               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6270               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6271               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6272               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6273               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6274               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6275               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6276               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6277               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6278               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6279               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6280               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6281               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6282               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6283               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6284               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6285               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6286               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6287               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6288               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6289               exit
6290             endif
6291           enddo
6292         endif
6293       enddo
6294       return
6295       end
6296 c------------------------------------------------------------------------------
6297       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6298      &  n_corr1)
6299 C This subroutine calculates multi-body contributions to hydrogen-bonding
6300       implicit real*8 (a-h,o-z)
6301       include 'DIMENSIONS'
6302       include 'COMMON.IOUNITS'
6303 #ifdef MPI
6304       include "mpif.h"
6305       parameter (max_cont=maxconts)
6306       parameter (max_dim=70)
6307       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6308       double precision zapas(max_dim,maxconts,max_fg_procs),
6309      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6310       common /przechowalnia/ zapas
6311       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6312      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6313 #endif
6314       include 'COMMON.SETUP'
6315       include 'COMMON.FFIELD'
6316       include 'COMMON.DERIV'
6317       include 'COMMON.LOCAL'
6318       include 'COMMON.INTERACT'
6319       include 'COMMON.CONTACTS'
6320       include 'COMMON.CHAIN'
6321       include 'COMMON.CONTROL'
6322       double precision gx(3),gx1(3)
6323       integer num_cont_hb_old(maxres)
6324       logical lprn,ldone
6325       double precision eello4,eello5,eelo6,eello_turn6
6326       external eello4,eello5,eello6,eello_turn6
6327 C Set lprn=.true. for debugging
6328       lprn=.false.
6329       eturn6=0.0d0
6330 #ifdef MPI
6331       do i=1,nres
6332         num_cont_hb_old(i)=num_cont_hb(i)
6333       enddo
6334       n_corr=0
6335       n_corr1=0
6336       if (nfgtasks.le.1) goto 30
6337       if (lprn) then
6338         write (iout,'(a)') 'Contact function values before RECEIVE:'
6339         do i=nnt,nct-2
6340           write (iout,'(2i3,50(1x,i2,f5.2))')
6341      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6342      &    j=1,num_cont_hb(i))
6343         enddo
6344       endif
6345       call flush(iout)
6346       do i=1,ntask_cont_from
6347         ncont_recv(i)=0
6348       enddo
6349       do i=1,ntask_cont_to
6350         ncont_sent(i)=0
6351       enddo
6352 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6353 c     & ntask_cont_to
6354 C Make the list of contacts to send to send to other procesors
6355       do i=iturn3_start,iturn3_end
6356 c        write (iout,*) "make contact list turn3",i," num_cont",
6357 c     &    num_cont_hb(i)
6358         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6359       enddo
6360       do i=iturn4_start,iturn4_end
6361 c        write (iout,*) "make contact list turn4",i," num_cont",
6362 c     &   num_cont_hb(i)
6363         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6364       enddo
6365       do ii=1,nat_sent
6366         i=iat_sent(ii)
6367 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6368 c     &    num_cont_hb(i)
6369         do j=1,num_cont_hb(i)
6370         do k=1,4
6371           jjc=jcont_hb(j,i)
6372           iproc=iint_sent_local(k,jjc,ii)
6373 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6374           if (iproc.ne.0) then
6375             ncont_sent(iproc)=ncont_sent(iproc)+1
6376             nn=ncont_sent(iproc)
6377             zapas(1,nn,iproc)=i
6378             zapas(2,nn,iproc)=jjc
6379             zapas(3,nn,iproc)=d_cont(j,i)
6380             ind=3
6381             do kk=1,3
6382               ind=ind+1
6383               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6384             enddo
6385             do kk=1,2
6386               do ll=1,2
6387                 ind=ind+1
6388                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6389               enddo
6390             enddo
6391             do jj=1,5
6392               do kk=1,3
6393                 do ll=1,2
6394                   do mm=1,2
6395                     ind=ind+1
6396                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6397                   enddo
6398                 enddo
6399               enddo
6400             enddo
6401           endif
6402         enddo
6403         enddo
6404       enddo
6405       if (lprn) then
6406       write (iout,*)
6407      &  "Numbers of contacts to be sent to other processors",
6408      &  (ncont_sent(i),i=1,ntask_cont_to)
6409       write (iout,*) "Contacts sent"
6410       do ii=1,ntask_cont_to
6411         nn=ncont_sent(ii)
6412         iproc=itask_cont_to(ii)
6413         write (iout,*) nn," contacts to processor",iproc,
6414      &   " of CONT_TO_COMM group"
6415         do i=1,nn
6416           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6417         enddo
6418       enddo
6419       call flush(iout)
6420       endif
6421       CorrelType=477
6422       CorrelID=fg_rank+1
6423       CorrelType1=478
6424       CorrelID1=nfgtasks+fg_rank+1
6425       ireq=0
6426 C Receive the numbers of needed contacts from other processors
6427       do ii=1,ntask_cont_from
6428         iproc=itask_cont_from(ii)
6429         ireq=ireq+1
6430         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6431      &    FG_COMM,req(ireq),IERR)
6432       enddo
6433 c      write (iout,*) "IRECV ended"
6434 c      call flush(iout)
6435 C Send the number of contacts needed by other processors
6436       do ii=1,ntask_cont_to
6437         iproc=itask_cont_to(ii)
6438         ireq=ireq+1
6439         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6440      &    FG_COMM,req(ireq),IERR)
6441       enddo
6442 c      write (iout,*) "ISEND ended"
6443 c      write (iout,*) "number of requests (nn)",ireq
6444       call flush(iout)
6445       if (ireq.gt.0)
6446      &  call MPI_Waitall(ireq,req,status_array,ierr)
6447 c      write (iout,*)
6448 c     &  "Numbers of contacts to be received from other processors",
6449 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6450 c      call flush(iout)
6451 C Receive contacts
6452       ireq=0
6453       do ii=1,ntask_cont_from
6454         iproc=itask_cont_from(ii)
6455         nn=ncont_recv(ii)
6456 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6457 c     &   " of CONT_TO_COMM group"
6458         call flush(iout)
6459         if (nn.gt.0) then
6460           ireq=ireq+1
6461           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6462      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6463 c          write (iout,*) "ireq,req",ireq,req(ireq)
6464         endif
6465       enddo
6466 C Send the contacts to processors that need them
6467       do ii=1,ntask_cont_to
6468         iproc=itask_cont_to(ii)
6469         nn=ncont_sent(ii)
6470 c        write (iout,*) nn," contacts to processor",iproc,
6471 c     &   " of CONT_TO_COMM group"
6472         if (nn.gt.0) then
6473           ireq=ireq+1
6474           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6475      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6476 c          write (iout,*) "ireq,req",ireq,req(ireq)
6477 c          do i=1,nn
6478 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6479 c          enddo
6480         endif
6481       enddo
6482 c      write (iout,*) "number of requests (contacts)",ireq
6483 c      write (iout,*) "req",(req(i),i=1,4)
6484 c      call flush(iout)
6485       if (ireq.gt.0)
6486      & call MPI_Waitall(ireq,req,status_array,ierr)
6487       do iii=1,ntask_cont_from
6488         iproc=itask_cont_from(iii)
6489         nn=ncont_recv(iii)
6490         if (lprn) then
6491         write (iout,*) "Received",nn," contacts from processor",iproc,
6492      &   " of CONT_FROM_COMM group"
6493         call flush(iout)
6494         do i=1,nn
6495           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6496         enddo
6497         call flush(iout)
6498         endif
6499         do i=1,nn
6500           ii=zapas_recv(1,i,iii)
6501 c Flag the received contacts to prevent double-counting
6502           jj=-zapas_recv(2,i,iii)
6503 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6504 c          call flush(iout)
6505           nnn=num_cont_hb(ii)+1
6506           num_cont_hb(ii)=nnn
6507           jcont_hb(nnn,ii)=jj
6508           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6509           ind=3
6510           do kk=1,3
6511             ind=ind+1
6512             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6513           enddo
6514           do kk=1,2
6515             do ll=1,2
6516               ind=ind+1
6517               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6518             enddo
6519           enddo
6520           do jj=1,5
6521             do kk=1,3
6522               do ll=1,2
6523                 do mm=1,2
6524                   ind=ind+1
6525                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6526                 enddo
6527               enddo
6528             enddo
6529           enddo
6530         enddo
6531       enddo
6532       call flush(iout)
6533       if (lprn) then
6534         write (iout,'(a)') 'Contact function values after receive:'
6535         do i=nnt,nct-2
6536           write (iout,'(2i3,50(1x,i3,5f6.3))')
6537      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6538      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6539         enddo
6540         call flush(iout)
6541       endif
6542    30 continue
6543 #endif
6544       if (lprn) then
6545         write (iout,'(a)') 'Contact function values:'
6546         do i=nnt,nct-2
6547           write (iout,'(2i3,50(1x,i2,5f6.3))')
6548      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6549      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6550         enddo
6551       endif
6552       ecorr=0.0D0
6553       ecorr5=0.0d0
6554       ecorr6=0.0d0
6555 C Remove the loop below after debugging !!!
6556       do i=nnt,nct
6557         do j=1,3
6558           gradcorr(j,i)=0.0D0
6559           gradxorr(j,i)=0.0D0
6560         enddo
6561       enddo
6562 C Calculate the dipole-dipole interaction energies
6563       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6564       do i=iatel_s,iatel_e+1
6565         num_conti=num_cont_hb(i)
6566         do jj=1,num_conti
6567           j=jcont_hb(jj,i)
6568 #ifdef MOMENT
6569           call dipole(i,j,jj)
6570 #endif
6571         enddo
6572       enddo
6573       endif
6574 C Calculate the local-electrostatic correlation terms
6575 c                write (iout,*) "gradcorr5 in eello5 before loop"
6576 c                do iii=1,nres
6577 c                  write (iout,'(i5,3f10.5)')
6578 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6579 c                enddo
6580       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6581 c        write (iout,*) "corr loop i",i
6582         i1=i+1
6583         num_conti=num_cont_hb(i)
6584         num_conti1=num_cont_hb(i+1)
6585         do jj=1,num_conti
6586           j=jcont_hb(jj,i)
6587           jp=iabs(j)
6588           do kk=1,num_conti1
6589             j1=jcont_hb(kk,i1)
6590             jp1=iabs(j1)
6591 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6592 c     &         ' jj=',jj,' kk=',kk
6593 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6594             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6595      &          .or. j.lt.0 .and. j1.gt.0) .and.
6596      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6597 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6598 C The system gains extra energy.
6599               n_corr=n_corr+1
6600               sqd1=dsqrt(d_cont(jj,i))
6601               sqd2=dsqrt(d_cont(kk,i1))
6602               sred_geom = sqd1*sqd2
6603               IF (sred_geom.lt.cutoff_corr) THEN
6604                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6605      &            ekont,fprimcont)
6606 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6607 cd     &         ' jj=',jj,' kk=',kk
6608                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6609                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6610                 do l=1,3
6611                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6612                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6613                 enddo
6614                 n_corr1=n_corr1+1
6615 cd               write (iout,*) 'sred_geom=',sred_geom,
6616 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6617 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6618 cd               write (iout,*) "g_contij",g_contij
6619 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6620 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6621                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6622                 if (wcorr4.gt.0.0d0)
6623      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6624                   if (energy_dec.and.wcorr4.gt.0.0d0)
6625      1                 write (iout,'(a6,4i5,0pf7.3)')
6626      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6627 c                write (iout,*) "gradcorr5 before eello5"
6628 c                do iii=1,nres
6629 c                  write (iout,'(i5,3f10.5)')
6630 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6631 c                enddo
6632                 if (wcorr5.gt.0.0d0)
6633      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6634 c                write (iout,*) "gradcorr5 after eello5"
6635 c                do iii=1,nres
6636 c                  write (iout,'(i5,3f10.5)')
6637 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6638 c                enddo
6639                   if (energy_dec.and.wcorr5.gt.0.0d0)
6640      1                 write (iout,'(a6,4i5,0pf7.3)')
6641      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6642 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6643 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6644                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6645      &               .or. wturn6.eq.0.0d0))then
6646 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6647                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6648                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6649      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6650 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6651 cd     &            'ecorr6=',ecorr6
6652 cd                write (iout,'(4e15.5)') sred_geom,
6653 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6654 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6655 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6656                 else if (wturn6.gt.0.0d0
6657      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6658 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6659                   eturn6=eturn6+eello_turn6(i,jj,kk)
6660                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6661      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6662 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6663                 endif
6664               ENDIF
6665 1111          continue
6666             endif
6667           enddo ! kk
6668         enddo ! jj
6669       enddo ! i
6670       do i=1,nres
6671         num_cont_hb(i)=num_cont_hb_old(i)
6672       enddo
6673 c                write (iout,*) "gradcorr5 in eello5"
6674 c                do iii=1,nres
6675 c                  write (iout,'(i5,3f10.5)')
6676 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6677 c                enddo
6678       return
6679       end
6680 c------------------------------------------------------------------------------
6681       subroutine add_hb_contact_eello(ii,jj,itask)
6682       implicit real*8 (a-h,o-z)
6683       include "DIMENSIONS"
6684       include "COMMON.IOUNITS"
6685       integer max_cont
6686       integer max_dim
6687       parameter (max_cont=maxconts)
6688       parameter (max_dim=70)
6689       include "COMMON.CONTACTS"
6690       double precision zapas(max_dim,maxconts,max_fg_procs),
6691      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6692       common /przechowalnia/ zapas
6693       integer i,j,ii,jj,iproc,itask(4),nn
6694 c      write (iout,*) "itask",itask
6695       do i=1,2
6696         iproc=itask(i)
6697         if (iproc.gt.0) then
6698           do j=1,num_cont_hb(ii)
6699             jjc=jcont_hb(j,ii)
6700 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6701             if (jjc.eq.jj) then
6702               ncont_sent(iproc)=ncont_sent(iproc)+1
6703               nn=ncont_sent(iproc)
6704               zapas(1,nn,iproc)=ii
6705               zapas(2,nn,iproc)=jjc
6706               zapas(3,nn,iproc)=d_cont(j,ii)
6707               ind=3
6708               do kk=1,3
6709                 ind=ind+1
6710                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6711               enddo
6712               do kk=1,2
6713                 do ll=1,2
6714                   ind=ind+1
6715                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6716                 enddo
6717               enddo
6718               do jj=1,5
6719                 do kk=1,3
6720                   do ll=1,2
6721                     do mm=1,2
6722                       ind=ind+1
6723                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6724                     enddo
6725                   enddo
6726                 enddo
6727               enddo
6728               exit
6729             endif
6730           enddo
6731         endif
6732       enddo
6733       return
6734       end
6735 c------------------------------------------------------------------------------
6736       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6737       implicit real*8 (a-h,o-z)
6738       include 'DIMENSIONS'
6739       include 'COMMON.IOUNITS'
6740       include 'COMMON.DERIV'
6741       include 'COMMON.INTERACT'
6742       include 'COMMON.CONTACTS'
6743       double precision gx(3),gx1(3)
6744       logical lprn
6745       lprn=.false.
6746       eij=facont_hb(jj,i)
6747       ekl=facont_hb(kk,k)
6748       ees0pij=ees0p(jj,i)
6749       ees0pkl=ees0p(kk,k)
6750       ees0mij=ees0m(jj,i)
6751       ees0mkl=ees0m(kk,k)
6752       ekont=eij*ekl
6753       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6754 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6755 C Following 4 lines for diagnostics.
6756 cd    ees0pkl=0.0D0
6757 cd    ees0pij=1.0D0
6758 cd    ees0mkl=0.0D0
6759 cd    ees0mij=1.0D0
6760 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6761 c     & 'Contacts ',i,j,
6762 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6763 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6764 c     & 'gradcorr_long'
6765 C Calculate the multi-body contribution to energy.
6766 c      ecorr=ecorr+ekont*ees
6767 C Calculate multi-body contributions to the gradient.
6768       coeffpees0pij=coeffp*ees0pij
6769       coeffmees0mij=coeffm*ees0mij
6770       coeffpees0pkl=coeffp*ees0pkl
6771       coeffmees0mkl=coeffm*ees0mkl
6772       do ll=1,3
6773 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6774         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6775      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6776      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6777         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6778      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6779      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6780 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6781         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6782      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6783      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6784         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6785      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6786      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6787         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6788      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6789      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6790         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6791         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6792         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6793      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6794      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6795         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6796         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6797 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6798       enddo
6799 c      write (iout,*)
6800 cgrad      do m=i+1,j-1
6801 cgrad        do ll=1,3
6802 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6803 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6804 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6805 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6806 cgrad        enddo
6807 cgrad      enddo
6808 cgrad      do m=k+1,l-1
6809 cgrad        do ll=1,3
6810 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6811 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6812 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6813 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6814 cgrad        enddo
6815 cgrad      enddo
6816 c      write (iout,*) "ehbcorr",ekont*ees
6817       ehbcorr=ekont*ees
6818       return
6819       end
6820 #ifdef MOMENT
6821 C---------------------------------------------------------------------------
6822       subroutine dipole(i,j,jj)
6823       implicit real*8 (a-h,o-z)
6824       include 'DIMENSIONS'
6825       include 'COMMON.IOUNITS'
6826       include 'COMMON.CHAIN'
6827       include 'COMMON.FFIELD'
6828       include 'COMMON.DERIV'
6829       include 'COMMON.INTERACT'
6830       include 'COMMON.CONTACTS'
6831       include 'COMMON.TORSION'
6832       include 'COMMON.VAR'
6833       include 'COMMON.GEO'
6834       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6835      &  auxmat(2,2)
6836       iti1 = itortyp(itype(i+1))
6837       if (j.lt.nres-1) then
6838         itj1 = itortyp(itype(j+1))
6839       else
6840         itj1=ntortyp+1
6841       endif
6842       do iii=1,2
6843         dipi(iii,1)=Ub2(iii,i)
6844         dipderi(iii)=Ub2der(iii,i)
6845         dipi(iii,2)=b1(iii,iti1)
6846         dipj(iii,1)=Ub2(iii,j)
6847         dipderj(iii)=Ub2der(iii,j)
6848         dipj(iii,2)=b1(iii,itj1)
6849       enddo
6850       kkk=0
6851       do iii=1,2
6852         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6853         do jjj=1,2
6854           kkk=kkk+1
6855           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6856         enddo
6857       enddo
6858       do kkk=1,5
6859         do lll=1,3
6860           mmm=0
6861           do iii=1,2
6862             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6863      &        auxvec(1))
6864             do jjj=1,2
6865               mmm=mmm+1
6866               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6867             enddo
6868           enddo
6869         enddo
6870       enddo
6871       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6872       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6873       do iii=1,2
6874         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6875       enddo
6876       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6877       do iii=1,2
6878         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6879       enddo
6880       return
6881       end
6882 #endif
6883 C---------------------------------------------------------------------------
6884       subroutine calc_eello(i,j,k,l,jj,kk)
6885 C
6886 C This subroutine computes matrices and vectors needed to calculate
6887 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6888 C
6889       implicit real*8 (a-h,o-z)
6890       include 'DIMENSIONS'
6891       include 'COMMON.IOUNITS'
6892       include 'COMMON.CHAIN'
6893       include 'COMMON.DERIV'
6894       include 'COMMON.INTERACT'
6895       include 'COMMON.CONTACTS'
6896       include 'COMMON.TORSION'
6897       include 'COMMON.VAR'
6898       include 'COMMON.GEO'
6899       include 'COMMON.FFIELD'
6900       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6901      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6902       logical lprn
6903       common /kutas/ lprn
6904 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6905 cd     & ' jj=',jj,' kk=',kk
6906 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6907 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6908 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6909       do iii=1,2
6910         do jjj=1,2
6911           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6912           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6913         enddo
6914       enddo
6915       call transpose2(aa1(1,1),aa1t(1,1))
6916       call transpose2(aa2(1,1),aa2t(1,1))
6917       do kkk=1,5
6918         do lll=1,3
6919           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6920      &      aa1tder(1,1,lll,kkk))
6921           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6922      &      aa2tder(1,1,lll,kkk))
6923         enddo
6924       enddo
6925       if (l.eq.j+1) then
6926 C parallel orientation of the two CA-CA-CA frames.
6927         if (i.gt.1) then
6928           iti=itortyp(itype(i))
6929         else
6930           iti=ntortyp+1
6931         endif
6932         itk1=itortyp(itype(k+1))
6933         itj=itortyp(itype(j))
6934         if (l.lt.nres-1) then
6935           itl1=itortyp(itype(l+1))
6936         else
6937           itl1=ntortyp+1
6938         endif
6939 C A1 kernel(j+1) A2T
6940 cd        do iii=1,2
6941 cd          write (iout,'(3f10.5,5x,3f10.5)')
6942 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6943 cd        enddo
6944         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6945      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6946      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6947 C Following matrices are needed only for 6-th order cumulants
6948         IF (wcorr6.gt.0.0d0) THEN
6949         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6950      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6951      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6952         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6953      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6954      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6955      &   ADtEAderx(1,1,1,1,1,1))
6956         lprn=.false.
6957         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6958      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6959      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6960      &   ADtEA1derx(1,1,1,1,1,1))
6961         ENDIF
6962 C End 6-th order cumulants
6963 cd        lprn=.false.
6964 cd        if (lprn) then
6965 cd        write (2,*) 'In calc_eello6'
6966 cd        do iii=1,2
6967 cd          write (2,*) 'iii=',iii
6968 cd          do kkk=1,5
6969 cd            write (2,*) 'kkk=',kkk
6970 cd            do jjj=1,2
6971 cd              write (2,'(3(2f10.5),5x)')
6972 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6973 cd            enddo
6974 cd          enddo
6975 cd        enddo
6976 cd        endif
6977         call transpose2(EUgder(1,1,k),auxmat(1,1))
6978         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6979         call transpose2(EUg(1,1,k),auxmat(1,1))
6980         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6981         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6982         do iii=1,2
6983           do kkk=1,5
6984             do lll=1,3
6985               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6986      &          EAEAderx(1,1,lll,kkk,iii,1))
6987             enddo
6988           enddo
6989         enddo
6990 C A1T kernel(i+1) A2
6991         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6992      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6993      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6994 C Following matrices are needed only for 6-th order cumulants
6995         IF (wcorr6.gt.0.0d0) THEN
6996         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6997      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6998      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6999         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7000      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7001      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7002      &   ADtEAderx(1,1,1,1,1,2))
7003         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7004      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7005      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7006      &   ADtEA1derx(1,1,1,1,1,2))
7007         ENDIF
7008 C End 6-th order cumulants
7009         call transpose2(EUgder(1,1,l),auxmat(1,1))
7010         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7011         call transpose2(EUg(1,1,l),auxmat(1,1))
7012         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7013         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7014         do iii=1,2
7015           do kkk=1,5
7016             do lll=1,3
7017               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7018      &          EAEAderx(1,1,lll,kkk,iii,2))
7019             enddo
7020           enddo
7021         enddo
7022 C AEAb1 and AEAb2
7023 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7024 C They are needed only when the fifth- or the sixth-order cumulants are
7025 C indluded.
7026         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7027         call transpose2(AEA(1,1,1),auxmat(1,1))
7028         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7029         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7030         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7031         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7032         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7033         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7034         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7035         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7036         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7037         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7038         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7039         call transpose2(AEA(1,1,2),auxmat(1,1))
7040         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7041         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7042         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7043         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7044         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7045         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7046         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7047         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7048         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7049         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7050         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7051 C Calculate the Cartesian derivatives of the vectors.
7052         do iii=1,2
7053           do kkk=1,5
7054             do lll=1,3
7055               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7056               call matvec2(auxmat(1,1),b1(1,iti),
7057      &          AEAb1derx(1,lll,kkk,iii,1,1))
7058               call matvec2(auxmat(1,1),Ub2(1,i),
7059      &          AEAb2derx(1,lll,kkk,iii,1,1))
7060               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7061      &          AEAb1derx(1,lll,kkk,iii,2,1))
7062               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7063      &          AEAb2derx(1,lll,kkk,iii,2,1))
7064               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7065               call matvec2(auxmat(1,1),b1(1,itj),
7066      &          AEAb1derx(1,lll,kkk,iii,1,2))
7067               call matvec2(auxmat(1,1),Ub2(1,j),
7068      &          AEAb2derx(1,lll,kkk,iii,1,2))
7069               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7070      &          AEAb1derx(1,lll,kkk,iii,2,2))
7071               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7072      &          AEAb2derx(1,lll,kkk,iii,2,2))
7073             enddo
7074           enddo
7075         enddo
7076         ENDIF
7077 C End vectors
7078       else
7079 C Antiparallel orientation of the two CA-CA-CA frames.
7080         if (i.gt.1) then
7081           iti=itortyp(itype(i))
7082         else
7083           iti=ntortyp+1
7084         endif
7085         itk1=itortyp(itype(k+1))
7086         itl=itortyp(itype(l))
7087         itj=itortyp(itype(j))
7088         if (j.lt.nres-1) then
7089           itj1=itortyp(itype(j+1))
7090         else
7091           itj1=ntortyp+1
7092         endif
7093 C A2 kernel(j-1)T A1T
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.,EUg(1,1,j),EUgder(1,1,j),
7096      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7097 C Following matrices are needed only for 6-th order cumulants
7098         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7099      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7100         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7101      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7102      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7103         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7104      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7105      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7106      &   ADtEAderx(1,1,1,1,1,1))
7107         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7108      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7109      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7110      &   ADtEA1derx(1,1,1,1,1,1))
7111         ENDIF
7112 C End 6-th order cumulants
7113         call transpose2(EUgder(1,1,k),auxmat(1,1))
7114         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7115         call transpose2(EUg(1,1,k),auxmat(1,1))
7116         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7117         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7118         do iii=1,2
7119           do kkk=1,5
7120             do lll=1,3
7121               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7122      &          EAEAderx(1,1,lll,kkk,iii,1))
7123             enddo
7124           enddo
7125         enddo
7126 C A2T kernel(i+1)T A1
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.,EUg(1,1,k),EUgder(1,1,k),
7129      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7130 C Following matrices are needed only for 6-th order cumulants
7131         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7132      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7133         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7134      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7135      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7136         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7137      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7138      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7139      &   ADtEAderx(1,1,1,1,1,2))
7140         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7141      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7142      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7143      &   ADtEA1derx(1,1,1,1,1,2))
7144         ENDIF
7145 C End 6-th order cumulants
7146         call transpose2(EUgder(1,1,j),auxmat(1,1))
7147         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7148         call transpose2(EUg(1,1,j),auxmat(1,1))
7149         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7150         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7151         do iii=1,2
7152           do kkk=1,5
7153             do lll=1,3
7154               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7155      &          EAEAderx(1,1,lll,kkk,iii,2))
7156             enddo
7157           enddo
7158         enddo
7159 C AEAb1 and AEAb2
7160 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7161 C They are needed only when the fifth- or the sixth-order cumulants are
7162 C indluded.
7163         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7164      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7165         call transpose2(AEA(1,1,1),auxmat(1,1))
7166         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7167         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7168         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7169         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7170         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7171         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7172         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7173         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7174         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7175         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7176         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7177         call transpose2(AEA(1,1,2),auxmat(1,1))
7178         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7179         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7180         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7181         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7182         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7183         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7184         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7185         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7186         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7187         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7188         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7189 C Calculate the Cartesian derivatives of the vectors.
7190         do iii=1,2
7191           do kkk=1,5
7192             do lll=1,3
7193               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7194               call matvec2(auxmat(1,1),b1(1,iti),
7195      &          AEAb1derx(1,lll,kkk,iii,1,1))
7196               call matvec2(auxmat(1,1),Ub2(1,i),
7197      &          AEAb2derx(1,lll,kkk,iii,1,1))
7198               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7199      &          AEAb1derx(1,lll,kkk,iii,2,1))
7200               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7201      &          AEAb2derx(1,lll,kkk,iii,2,1))
7202               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7203               call matvec2(auxmat(1,1),b1(1,itl),
7204      &          AEAb1derx(1,lll,kkk,iii,1,2))
7205               call matvec2(auxmat(1,1),Ub2(1,l),
7206      &          AEAb2derx(1,lll,kkk,iii,1,2))
7207               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7208      &          AEAb1derx(1,lll,kkk,iii,2,2))
7209               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7210      &          AEAb2derx(1,lll,kkk,iii,2,2))
7211             enddo
7212           enddo
7213         enddo
7214         ENDIF
7215 C End vectors
7216       endif
7217       return
7218       end
7219 C---------------------------------------------------------------------------
7220       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7221      &  KK,KKderg,AKA,AKAderg,AKAderx)
7222       implicit none
7223       integer nderg
7224       logical transp
7225       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7226      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7227      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7228       integer iii,kkk,lll
7229       integer jjj,mmm
7230       logical lprn
7231       common /kutas/ lprn
7232       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7233       do iii=1,nderg
7234         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7235      &    AKAderg(1,1,iii))
7236       enddo
7237 cd      if (lprn) write (2,*) 'In kernel'
7238       do kkk=1,5
7239 cd        if (lprn) write (2,*) 'kkk=',kkk
7240         do lll=1,3
7241           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7242      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7243 cd          if (lprn) then
7244 cd            write (2,*) 'lll=',lll
7245 cd            write (2,*) 'iii=1'
7246 cd            do jjj=1,2
7247 cd              write (2,'(3(2f10.5),5x)')
7248 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7249 cd            enddo
7250 cd          endif
7251           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7252      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7253 cd          if (lprn) then
7254 cd            write (2,*) 'lll=',lll
7255 cd            write (2,*) 'iii=2'
7256 cd            do jjj=1,2
7257 cd              write (2,'(3(2f10.5),5x)')
7258 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7259 cd            enddo
7260 cd          endif
7261         enddo
7262       enddo
7263       return
7264       end
7265 C---------------------------------------------------------------------------
7266       double precision function eello4(i,j,k,l,jj,kk)
7267       implicit real*8 (a-h,o-z)
7268       include 'DIMENSIONS'
7269       include 'COMMON.IOUNITS'
7270       include 'COMMON.CHAIN'
7271       include 'COMMON.DERIV'
7272       include 'COMMON.INTERACT'
7273       include 'COMMON.CONTACTS'
7274       include 'COMMON.TORSION'
7275       include 'COMMON.VAR'
7276       include 'COMMON.GEO'
7277       double precision pizda(2,2),ggg1(3),ggg2(3)
7278 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7279 cd        eello4=0.0d0
7280 cd        return
7281 cd      endif
7282 cd      print *,'eello4:',i,j,k,l,jj,kk
7283 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7284 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7285 cold      eij=facont_hb(jj,i)
7286 cold      ekl=facont_hb(kk,k)
7287 cold      ekont=eij*ekl
7288       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7289 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7290       gcorr_loc(k-1)=gcorr_loc(k-1)
7291      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7292       if (l.eq.j+1) then
7293         gcorr_loc(l-1)=gcorr_loc(l-1)
7294      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7295       else
7296         gcorr_loc(j-1)=gcorr_loc(j-1)
7297      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7298       endif
7299       do iii=1,2
7300         do kkk=1,5
7301           do lll=1,3
7302             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7303      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7304 cd            derx(lll,kkk,iii)=0.0d0
7305           enddo
7306         enddo
7307       enddo
7308 cd      gcorr_loc(l-1)=0.0d0
7309 cd      gcorr_loc(j-1)=0.0d0
7310 cd      gcorr_loc(k-1)=0.0d0
7311 cd      eel4=1.0d0
7312 cd      write (iout,*)'Contacts have occurred for peptide groups',
7313 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7314 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7315       if (j.lt.nres-1) then
7316         j1=j+1
7317         j2=j-1
7318       else
7319         j1=j-1
7320         j2=j-2
7321       endif
7322       if (l.lt.nres-1) then
7323         l1=l+1
7324         l2=l-1
7325       else
7326         l1=l-1
7327         l2=l-2
7328       endif
7329       do ll=1,3
7330 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7331 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7332         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7333         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7334 cgrad        ghalf=0.5d0*ggg1(ll)
7335         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7336         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7337         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7338         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7339         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7340         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7341 cgrad        ghalf=0.5d0*ggg2(ll)
7342         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7343         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7344         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7345         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7346         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7347         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7348       enddo
7349 cgrad      do m=i+1,j-1
7350 cgrad        do ll=1,3
7351 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7352 cgrad        enddo
7353 cgrad      enddo
7354 cgrad      do m=k+1,l-1
7355 cgrad        do ll=1,3
7356 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7357 cgrad        enddo
7358 cgrad      enddo
7359 cgrad      do m=i+2,j2
7360 cgrad        do ll=1,3
7361 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7362 cgrad        enddo
7363 cgrad      enddo
7364 cgrad      do m=k+2,l2
7365 cgrad        do ll=1,3
7366 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7367 cgrad        enddo
7368 cgrad      enddo
7369 cd      do iii=1,nres-3
7370 cd        write (2,*) iii,gcorr_loc(iii)
7371 cd      enddo
7372       eello4=ekont*eel4
7373 cd      write (2,*) 'ekont',ekont
7374 cd      write (iout,*) 'eello4',ekont*eel4
7375       return
7376       end
7377 C---------------------------------------------------------------------------
7378       double precision function eello5(i,j,k,l,jj,kk)
7379       implicit real*8 (a-h,o-z)
7380       include 'DIMENSIONS'
7381       include 'COMMON.IOUNITS'
7382       include 'COMMON.CHAIN'
7383       include 'COMMON.DERIV'
7384       include 'COMMON.INTERACT'
7385       include 'COMMON.CONTACTS'
7386       include 'COMMON.TORSION'
7387       include 'COMMON.VAR'
7388       include 'COMMON.GEO'
7389       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7390       double precision ggg1(3),ggg2(3)
7391 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7392 C                                                                              C
7393 C                            Parallel chains                                   C
7394 C                                                                              C
7395 C          o             o                   o             o                   C
7396 C         /l\           / \             \   / \           / \   /              C
7397 C        /   \         /   \             \ /   \         /   \ /               C
7398 C       j| o |l1       | o |              o| o |         | o |o                C
7399 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7400 C      \i/   \         /   \ /             /   \         /   \                 C
7401 C       o    k1             o                                                  C
7402 C         (I)          (II)                (III)          (IV)                 C
7403 C                                                                              C
7404 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7405 C                                                                              C
7406 C                            Antiparallel chains                               C
7407 C                                                                              C
7408 C          o             o                   o             o                   C
7409 C         /j\           / \             \   / \           / \   /              C
7410 C        /   \         /   \             \ /   \         /   \ /               C
7411 C      j1| o |l        | o |              o| o |         | o |o                C
7412 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7413 C      \i/   \         /   \ /             /   \         /   \                 C
7414 C       o     k1            o                                                  C
7415 C         (I)          (II)                (III)          (IV)                 C
7416 C                                                                              C
7417 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7418 C                                                                              C
7419 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7420 C                                                                              C
7421 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7422 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7423 cd        eello5=0.0d0
7424 cd        return
7425 cd      endif
7426 cd      write (iout,*)
7427 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7428 cd     &   ' and',k,l
7429       itk=itortyp(itype(k))
7430       itl=itortyp(itype(l))
7431       itj=itortyp(itype(j))
7432       eello5_1=0.0d0
7433       eello5_2=0.0d0
7434       eello5_3=0.0d0
7435       eello5_4=0.0d0
7436 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7437 cd     &   eel5_3_num,eel5_4_num)
7438       do iii=1,2
7439         do kkk=1,5
7440           do lll=1,3
7441             derx(lll,kkk,iii)=0.0d0
7442           enddo
7443         enddo
7444       enddo
7445 cd      eij=facont_hb(jj,i)
7446 cd      ekl=facont_hb(kk,k)
7447 cd      ekont=eij*ekl
7448 cd      write (iout,*)'Contacts have occurred for peptide groups',
7449 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7450 cd      goto 1111
7451 C Contribution from the graph I.
7452 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7453 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7454       call transpose2(EUg(1,1,k),auxmat(1,1))
7455       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7456       vv(1)=pizda(1,1)-pizda(2,2)
7457       vv(2)=pizda(1,2)+pizda(2,1)
7458       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7459      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7460 C Explicit gradient in virtual-dihedral angles.
7461       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7462      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7463      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7464       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7465       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7466       vv(1)=pizda(1,1)-pizda(2,2)
7467       vv(2)=pizda(1,2)+pizda(2,1)
7468       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7469      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7470      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7471       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7472       vv(1)=pizda(1,1)-pizda(2,2)
7473       vv(2)=pizda(1,2)+pizda(2,1)
7474       if (l.eq.j+1) then
7475         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7476      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7477      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7478       else
7479         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7480      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7481      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7482       endif
7483 C Cartesian gradient
7484       do iii=1,2
7485         do kkk=1,5
7486           do lll=1,3
7487             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7488      &        pizda(1,1))
7489             vv(1)=pizda(1,1)-pizda(2,2)
7490             vv(2)=pizda(1,2)+pizda(2,1)
7491             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7492      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7493      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7494           enddo
7495         enddo
7496       enddo
7497 c      goto 1112
7498 c1111  continue
7499 C Contribution from graph II
7500       call transpose2(EE(1,1,itk),auxmat(1,1))
7501       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7502       vv(1)=pizda(1,1)+pizda(2,2)
7503       vv(2)=pizda(2,1)-pizda(1,2)
7504       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7505      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7506 C Explicit gradient in virtual-dihedral angles.
7507       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7508      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7509       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7510       vv(1)=pizda(1,1)+pizda(2,2)
7511       vv(2)=pizda(2,1)-pizda(1,2)
7512       if (l.eq.j+1) then
7513         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7514      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7515      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7516       else
7517         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7518      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7519      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7520       endif
7521 C Cartesian gradient
7522       do iii=1,2
7523         do kkk=1,5
7524           do lll=1,3
7525             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7526      &        pizda(1,1))
7527             vv(1)=pizda(1,1)+pizda(2,2)
7528             vv(2)=pizda(2,1)-pizda(1,2)
7529             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7530      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7531      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7532           enddo
7533         enddo
7534       enddo
7535 cd      goto 1112
7536 cd1111  continue
7537       if (l.eq.j+1) then
7538 cd        goto 1110
7539 C Parallel orientation
7540 C Contribution from graph III
7541         call transpose2(EUg(1,1,l),auxmat(1,1))
7542         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7543         vv(1)=pizda(1,1)-pizda(2,2)
7544         vv(2)=pizda(1,2)+pizda(2,1)
7545         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7546      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7547 C Explicit gradient in virtual-dihedral angles.
7548         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7549      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7550      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7551         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7552         vv(1)=pizda(1,1)-pizda(2,2)
7553         vv(2)=pizda(1,2)+pizda(2,1)
7554         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7555      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7556      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7557         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7558         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7559         vv(1)=pizda(1,1)-pizda(2,2)
7560         vv(2)=pizda(1,2)+pizda(2,1)
7561         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7562      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7563      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7564 C Cartesian gradient
7565         do iii=1,2
7566           do kkk=1,5
7567             do lll=1,3
7568               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7569      &          pizda(1,1))
7570               vv(1)=pizda(1,1)-pizda(2,2)
7571               vv(2)=pizda(1,2)+pizda(2,1)
7572               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7573      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7574      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7575             enddo
7576           enddo
7577         enddo
7578 cd        goto 1112
7579 C Contribution from graph IV
7580 cd1110    continue
7581         call transpose2(EE(1,1,itl),auxmat(1,1))
7582         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7583         vv(1)=pizda(1,1)+pizda(2,2)
7584         vv(2)=pizda(2,1)-pizda(1,2)
7585         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7586      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7587 C Explicit gradient in virtual-dihedral angles.
7588         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7589      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7590         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7591         vv(1)=pizda(1,1)+pizda(2,2)
7592         vv(2)=pizda(2,1)-pizda(1,2)
7593         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7594      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7595      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7596 C Cartesian gradient
7597         do iii=1,2
7598           do kkk=1,5
7599             do lll=1,3
7600               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7601      &          pizda(1,1))
7602               vv(1)=pizda(1,1)+pizda(2,2)
7603               vv(2)=pizda(2,1)-pizda(1,2)
7604               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7605      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7606      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7607             enddo
7608           enddo
7609         enddo
7610       else
7611 C Antiparallel orientation
7612 C Contribution from graph III
7613 c        goto 1110
7614         call transpose2(EUg(1,1,j),auxmat(1,1))
7615         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7616         vv(1)=pizda(1,1)-pizda(2,2)
7617         vv(2)=pizda(1,2)+pizda(2,1)
7618         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7619      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7620 C Explicit gradient in virtual-dihedral angles.
7621         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7622      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7623      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7624         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7625         vv(1)=pizda(1,1)-pizda(2,2)
7626         vv(2)=pizda(1,2)+pizda(2,1)
7627         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7628      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7629      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7630         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7631         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7632         vv(1)=pizda(1,1)-pizda(2,2)
7633         vv(2)=pizda(1,2)+pizda(2,1)
7634         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7635      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7636      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7637 C Cartesian gradient
7638         do iii=1,2
7639           do kkk=1,5
7640             do lll=1,3
7641               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7642      &          pizda(1,1))
7643               vv(1)=pizda(1,1)-pizda(2,2)
7644               vv(2)=pizda(1,2)+pizda(2,1)
7645               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7646      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7647      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7648             enddo
7649           enddo
7650         enddo
7651 cd        goto 1112
7652 C Contribution from graph IV
7653 1110    continue
7654         call transpose2(EE(1,1,itj),auxmat(1,1))
7655         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7656         vv(1)=pizda(1,1)+pizda(2,2)
7657         vv(2)=pizda(2,1)-pizda(1,2)
7658         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7659      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7660 C Explicit gradient in virtual-dihedral angles.
7661         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7662      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7663         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7664         vv(1)=pizda(1,1)+pizda(2,2)
7665         vv(2)=pizda(2,1)-pizda(1,2)
7666         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7667      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7668      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7669 C Cartesian gradient
7670         do iii=1,2
7671           do kkk=1,5
7672             do lll=1,3
7673               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7674      &          pizda(1,1))
7675               vv(1)=pizda(1,1)+pizda(2,2)
7676               vv(2)=pizda(2,1)-pizda(1,2)
7677               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7678      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7679      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7680             enddo
7681           enddo
7682         enddo
7683       endif
7684 1112  continue
7685       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7686 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7687 cd        write (2,*) 'ijkl',i,j,k,l
7688 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7689 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7690 cd      endif
7691 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7692 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7693 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7694 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7695       if (j.lt.nres-1) then
7696         j1=j+1
7697         j2=j-1
7698       else
7699         j1=j-1
7700         j2=j-2
7701       endif
7702       if (l.lt.nres-1) then
7703         l1=l+1
7704         l2=l-1
7705       else
7706         l1=l-1
7707         l2=l-2
7708       endif
7709 cd      eij=1.0d0
7710 cd      ekl=1.0d0
7711 cd      ekont=1.0d0
7712 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7713 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7714 C        summed up outside the subrouine as for the other subroutines
7715 C        handling long-range interactions. The old code is commented out
7716 C        with "cgrad" to keep track of changes.
7717       do ll=1,3
7718 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7719 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7720         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7721         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7722 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7723 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7724 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7725 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7726 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7727 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7728 c     &   gradcorr5ij,
7729 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7730 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7731 cgrad        ghalf=0.5d0*ggg1(ll)
7732 cd        ghalf=0.0d0
7733         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7734         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7735         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7736         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7737         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7738         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7739 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7740 cgrad        ghalf=0.5d0*ggg2(ll)
7741 cd        ghalf=0.0d0
7742         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7743         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7744         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7745         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7746         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7747         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7748       enddo
7749 cd      goto 1112
7750 cgrad      do m=i+1,j-1
7751 cgrad        do ll=1,3
7752 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7753 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7754 cgrad        enddo
7755 cgrad      enddo
7756 cgrad      do m=k+1,l-1
7757 cgrad        do ll=1,3
7758 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7759 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7760 cgrad        enddo
7761 cgrad      enddo
7762 c1112  continue
7763 cgrad      do m=i+2,j2
7764 cgrad        do ll=1,3
7765 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7766 cgrad        enddo
7767 cgrad      enddo
7768 cgrad      do m=k+2,l2
7769 cgrad        do ll=1,3
7770 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7771 cgrad        enddo
7772 cgrad      enddo
7773 cd      do iii=1,nres-3
7774 cd        write (2,*) iii,g_corr5_loc(iii)
7775 cd      enddo
7776       eello5=ekont*eel5
7777 cd      write (2,*) 'ekont',ekont
7778 cd      write (iout,*) 'eello5',ekont*eel5
7779       return
7780       end
7781 c--------------------------------------------------------------------------
7782       double precision function eello6(i,j,k,l,jj,kk)
7783       implicit real*8 (a-h,o-z)
7784       include 'DIMENSIONS'
7785       include 'COMMON.IOUNITS'
7786       include 'COMMON.CHAIN'
7787       include 'COMMON.DERIV'
7788       include 'COMMON.INTERACT'
7789       include 'COMMON.CONTACTS'
7790       include 'COMMON.TORSION'
7791       include 'COMMON.VAR'
7792       include 'COMMON.GEO'
7793       include 'COMMON.FFIELD'
7794       double precision ggg1(3),ggg2(3)
7795 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7796 cd        eello6=0.0d0
7797 cd        return
7798 cd      endif
7799 cd      write (iout,*)
7800 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7801 cd     &   ' and',k,l
7802       eello6_1=0.0d0
7803       eello6_2=0.0d0
7804       eello6_3=0.0d0
7805       eello6_4=0.0d0
7806       eello6_5=0.0d0
7807       eello6_6=0.0d0
7808 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7809 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7810       do iii=1,2
7811         do kkk=1,5
7812           do lll=1,3
7813             derx(lll,kkk,iii)=0.0d0
7814           enddo
7815         enddo
7816       enddo
7817 cd      eij=facont_hb(jj,i)
7818 cd      ekl=facont_hb(kk,k)
7819 cd      ekont=eij*ekl
7820 cd      eij=1.0d0
7821 cd      ekl=1.0d0
7822 cd      ekont=1.0d0
7823       if (l.eq.j+1) then
7824         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7825         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7826         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7827         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7828         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7829         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7830       else
7831         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7832         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7833         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7834         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7835         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7836           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7837         else
7838           eello6_5=0.0d0
7839         endif
7840         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7841       endif
7842 C If turn contributions are considered, they will be handled separately.
7843       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7844 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7845 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7846 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7847 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7848 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7849 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7850 cd      goto 1112
7851       if (j.lt.nres-1) then
7852         j1=j+1
7853         j2=j-1
7854       else
7855         j1=j-1
7856         j2=j-2
7857       endif
7858       if (l.lt.nres-1) then
7859         l1=l+1
7860         l2=l-1
7861       else
7862         l1=l-1
7863         l2=l-2
7864       endif
7865       do ll=1,3
7866 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7867 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7868 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7869 cgrad        ghalf=0.5d0*ggg1(ll)
7870 cd        ghalf=0.0d0
7871         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7872         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7873         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7874         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7875         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7876         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7877         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7878         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7879 cgrad        ghalf=0.5d0*ggg2(ll)
7880 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7881 cd        ghalf=0.0d0
7882         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7883         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7884         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7885         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7886         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7887         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7888       enddo
7889 cd      goto 1112
7890 cgrad      do m=i+1,j-1
7891 cgrad        do ll=1,3
7892 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7893 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7894 cgrad        enddo
7895 cgrad      enddo
7896 cgrad      do m=k+1,l-1
7897 cgrad        do ll=1,3
7898 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7899 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7900 cgrad        enddo
7901 cgrad      enddo
7902 cgrad1112  continue
7903 cgrad      do m=i+2,j2
7904 cgrad        do ll=1,3
7905 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7906 cgrad        enddo
7907 cgrad      enddo
7908 cgrad      do m=k+2,l2
7909 cgrad        do ll=1,3
7910 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7911 cgrad        enddo
7912 cgrad      enddo
7913 cd      do iii=1,nres-3
7914 cd        write (2,*) iii,g_corr6_loc(iii)
7915 cd      enddo
7916       eello6=ekont*eel6
7917 cd      write (2,*) 'ekont',ekont
7918 cd      write (iout,*) 'eello6',ekont*eel6
7919       return
7920       end
7921 c--------------------------------------------------------------------------
7922       double precision function eello6_graph1(i,j,k,l,imat,swap)
7923       implicit real*8 (a-h,o-z)
7924       include 'DIMENSIONS'
7925       include 'COMMON.IOUNITS'
7926       include 'COMMON.CHAIN'
7927       include 'COMMON.DERIV'
7928       include 'COMMON.INTERACT'
7929       include 'COMMON.CONTACTS'
7930       include 'COMMON.TORSION'
7931       include 'COMMON.VAR'
7932       include 'COMMON.GEO'
7933       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7934       logical swap
7935       logical lprn
7936       common /kutas/ lprn
7937 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7938 C                                                                              C
7939 C      Parallel       Antiparallel                                             C
7940 C                                                                              C
7941 C          o             o                                                     C
7942 C         /l\           /j\                                                    C
7943 C        /   \         /   \                                                   C
7944 C       /| o |         | o |\                                                  C
7945 C     \ j|/k\|  /   \  |/k\|l /                                                C
7946 C      \ /   \ /     \ /   \ /                                                 C
7947 C       o     o       o     o                                                  C
7948 C       i             i                                                        C
7949 C                                                                              C
7950 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7951       itk=itortyp(itype(k))
7952       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7953       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7954       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7955       call transpose2(EUgC(1,1,k),auxmat(1,1))
7956       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7957       vv1(1)=pizda1(1,1)-pizda1(2,2)
7958       vv1(2)=pizda1(1,2)+pizda1(2,1)
7959       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7960       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7961       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7962       s5=scalar2(vv(1),Dtobr2(1,i))
7963 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7964       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7965       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7966      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7967      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7968      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7969      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7970      & +scalar2(vv(1),Dtobr2der(1,i)))
7971       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7972       vv1(1)=pizda1(1,1)-pizda1(2,2)
7973       vv1(2)=pizda1(1,2)+pizda1(2,1)
7974       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7975       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7976       if (l.eq.j+1) then
7977         g_corr6_loc(l-1)=g_corr6_loc(l-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       else
7983         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7984      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7985      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7986      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7987      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7988       endif
7989       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7990       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7991       vv1(1)=pizda1(1,1)-pizda1(2,2)
7992       vv1(2)=pizda1(1,2)+pizda1(2,1)
7993       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7994      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7995      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7996      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7997       do iii=1,2
7998         if (swap) then
7999           ind=3-iii
8000         else
8001           ind=iii
8002         endif
8003         do kkk=1,5
8004           do lll=1,3
8005             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8006             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8007             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8008             call transpose2(EUgC(1,1,k),auxmat(1,1))
8009             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8010      &        pizda1(1,1))
8011             vv1(1)=pizda1(1,1)-pizda1(2,2)
8012             vv1(2)=pizda1(1,2)+pizda1(2,1)
8013             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8014             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8015      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8016             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8017      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8018             s5=scalar2(vv(1),Dtobr2(1,i))
8019             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8020           enddo
8021         enddo
8022       enddo
8023       return
8024       end
8025 c----------------------------------------------------------------------------
8026       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8027       implicit real*8 (a-h,o-z)
8028       include 'DIMENSIONS'
8029       include 'COMMON.IOUNITS'
8030       include 'COMMON.CHAIN'
8031       include 'COMMON.DERIV'
8032       include 'COMMON.INTERACT'
8033       include 'COMMON.CONTACTS'
8034       include 'COMMON.TORSION'
8035       include 'COMMON.VAR'
8036       include 'COMMON.GEO'
8037       logical swap
8038       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8039      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8040       logical lprn
8041       common /kutas/ lprn
8042 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8043 C                                                                              C
8044 C      Parallel       Antiparallel                                             C
8045 C                                                                              C
8046 C          o             o                                                     C
8047 C     \   /l\           /j\   /                                                C
8048 C      \ /   \         /   \ /                                                 C
8049 C       o| o |         | o |o                                                  C
8050 C     \ j|/k\|      \  |/k\|l                                                  C
8051 C      \ /   \       \ /   \                                                   C
8052 C       o             o                                                        C
8053 C       i             i                                                        C
8054 C                                                                              C
8055 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8056 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8057 C AL 7/4/01 s1 would occur in the sixth-order moment,
8058 C           but not in a cluster cumulant
8059 #ifdef MOMENT
8060       s1=dip(1,jj,i)*dip(1,kk,k)
8061 #endif
8062       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8063       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8064       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8065       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8066       call transpose2(EUg(1,1,k),auxmat(1,1))
8067       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8068       vv(1)=pizda(1,1)-pizda(2,2)
8069       vv(2)=pizda(1,2)+pizda(2,1)
8070       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8071 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8072 #ifdef MOMENT
8073       eello6_graph2=-(s1+s2+s3+s4)
8074 #else
8075       eello6_graph2=-(s2+s3+s4)
8076 #endif
8077 c      eello6_graph2=-s3
8078 C Derivatives in gamma(i-1)
8079       if (i.gt.1) then
8080 #ifdef MOMENT
8081         s1=dipderg(1,jj,i)*dip(1,kk,k)
8082 #endif
8083         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8084         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8085         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8086         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8087 #ifdef MOMENT
8088         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8089 #else
8090         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8091 #endif
8092 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8093       endif
8094 C Derivatives in gamma(k-1)
8095 #ifdef MOMENT
8096       s1=dip(1,jj,i)*dipderg(1,kk,k)
8097 #endif
8098       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8099       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8100       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8101       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8102       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8103       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8104       vv(1)=pizda(1,1)-pizda(2,2)
8105       vv(2)=pizda(1,2)+pizda(2,1)
8106       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8107 #ifdef MOMENT
8108       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8109 #else
8110       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8111 #endif
8112 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8113 C Derivatives in gamma(j-1) or gamma(l-1)
8114       if (j.gt.1) then
8115 #ifdef MOMENT
8116         s1=dipderg(3,jj,i)*dip(1,kk,k)
8117 #endif
8118         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8119         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8120         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8121         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8122         vv(1)=pizda(1,1)-pizda(2,2)
8123         vv(2)=pizda(1,2)+pizda(2,1)
8124         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8125 #ifdef MOMENT
8126         if (swap) then
8127           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8128         else
8129           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8130         endif
8131 #endif
8132         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8133 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8134       endif
8135 C Derivatives in gamma(l-1) or gamma(j-1)
8136       if (l.gt.1) then
8137 #ifdef MOMENT
8138         s1=dip(1,jj,i)*dipderg(3,kk,k)
8139 #endif
8140         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8141         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8142         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8143         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8144         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8145         vv(1)=pizda(1,1)-pizda(2,2)
8146         vv(2)=pizda(1,2)+pizda(2,1)
8147         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8148 #ifdef MOMENT
8149         if (swap) then
8150           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8151         else
8152           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8153         endif
8154 #endif
8155         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8156 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8157       endif
8158 C Cartesian derivatives.
8159       if (lprn) then
8160         write (2,*) 'In eello6_graph2'
8161         do iii=1,2
8162           write (2,*) 'iii=',iii
8163           do kkk=1,5
8164             write (2,*) 'kkk=',kkk
8165             do jjj=1,2
8166               write (2,'(3(2f10.5),5x)')
8167      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8168             enddo
8169           enddo
8170         enddo
8171       endif
8172       do iii=1,2
8173         do kkk=1,5
8174           do lll=1,3
8175 #ifdef MOMENT
8176             if (iii.eq.1) then
8177               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8178             else
8179               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8180             endif
8181 #endif
8182             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8183      &        auxvec(1))
8184             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8185             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8186      &        auxvec(1))
8187             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8188             call transpose2(EUg(1,1,k),auxmat(1,1))
8189             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8190      &        pizda(1,1))
8191             vv(1)=pizda(1,1)-pizda(2,2)
8192             vv(2)=pizda(1,2)+pizda(2,1)
8193             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8194 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8195 #ifdef MOMENT
8196             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8197 #else
8198             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8199 #endif
8200             if (swap) then
8201               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8202             else
8203               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8204             endif
8205           enddo
8206         enddo
8207       enddo
8208       return
8209       end
8210 c----------------------------------------------------------------------------
8211       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8212       implicit real*8 (a-h,o-z)
8213       include 'DIMENSIONS'
8214       include 'COMMON.IOUNITS'
8215       include 'COMMON.CHAIN'
8216       include 'COMMON.DERIV'
8217       include 'COMMON.INTERACT'
8218       include 'COMMON.CONTACTS'
8219       include 'COMMON.TORSION'
8220       include 'COMMON.VAR'
8221       include 'COMMON.GEO'
8222       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8223       logical swap
8224 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8225 C                                                                              C
8226 C      Parallel       Antiparallel                                             C
8227 C                                                                              C
8228 C          o             o                                                     C
8229 C         /l\   /   \   /j\                                                    C
8230 C        /   \ /     \ /   \                                                   C
8231 C       /| o |o       o| o |\                                                  C
8232 C       j|/k\|  /      |/k\|l /                                                C
8233 C        /   \ /       /   \ /                                                 C
8234 C       /     o       /     o                                                  C
8235 C       i             i                                                        C
8236 C                                                                              C
8237 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8238 C
8239 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8240 C           energy moment and not to the cluster cumulant.
8241       iti=itortyp(itype(i))
8242       if (j.lt.nres-1) then
8243         itj1=itortyp(itype(j+1))
8244       else
8245         itj1=ntortyp+1
8246       endif
8247       itk=itortyp(itype(k))
8248       itk1=itortyp(itype(k+1))
8249       if (l.lt.nres-1) then
8250         itl1=itortyp(itype(l+1))
8251       else
8252         itl1=ntortyp+1
8253       endif
8254 #ifdef MOMENT
8255       s1=dip(4,jj,i)*dip(4,kk,k)
8256 #endif
8257       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8258       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8259       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8260       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8261       call transpose2(EE(1,1,itk),auxmat(1,1))
8262       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8263       vv(1)=pizda(1,1)+pizda(2,2)
8264       vv(2)=pizda(2,1)-pizda(1,2)
8265       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8266 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8267 cd     & "sum",-(s2+s3+s4)
8268 #ifdef MOMENT
8269       eello6_graph3=-(s1+s2+s3+s4)
8270 #else
8271       eello6_graph3=-(s2+s3+s4)
8272 #endif
8273 c      eello6_graph3=-s4
8274 C Derivatives in gamma(k-1)
8275       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8276       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8277       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8278       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8279 C Derivatives in gamma(l-1)
8280       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8281       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8282       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8283       vv(1)=pizda(1,1)+pizda(2,2)
8284       vv(2)=pizda(2,1)-pizda(1,2)
8285       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8286       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8287 C Cartesian derivatives.
8288       do iii=1,2
8289         do kkk=1,5
8290           do lll=1,3
8291 #ifdef MOMENT
8292             if (iii.eq.1) then
8293               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8294             else
8295               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8296             endif
8297 #endif
8298             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8299      &        auxvec(1))
8300             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8301             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8302      &        auxvec(1))
8303             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8304             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8305      &        pizda(1,1))
8306             vv(1)=pizda(1,1)+pizda(2,2)
8307             vv(2)=pizda(2,1)-pizda(1,2)
8308             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8309 #ifdef MOMENT
8310             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8311 #else
8312             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8313 #endif
8314             if (swap) then
8315               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8316             else
8317               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8318             endif
8319 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8320           enddo
8321         enddo
8322       enddo
8323       return
8324       end
8325 c----------------------------------------------------------------------------
8326       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8327       implicit real*8 (a-h,o-z)
8328       include 'DIMENSIONS'
8329       include 'COMMON.IOUNITS'
8330       include 'COMMON.CHAIN'
8331       include 'COMMON.DERIV'
8332       include 'COMMON.INTERACT'
8333       include 'COMMON.CONTACTS'
8334       include 'COMMON.TORSION'
8335       include 'COMMON.VAR'
8336       include 'COMMON.GEO'
8337       include 'COMMON.FFIELD'
8338       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8339      & auxvec1(2),auxmat1(2,2)
8340       logical swap
8341 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8342 C                                                                              C
8343 C      Parallel       Antiparallel                                             C
8344 C                                                                              C
8345 C          o             o                                                     C
8346 C         /l\   /   \   /j\                                                    C
8347 C        /   \ /     \ /   \                                                   C
8348 C       /| o |o       o| o |\                                                  C
8349 C     \ j|/k\|      \  |/k\|l                                                  C
8350 C      \ /   \       \ /   \                                                   C
8351 C       o     \       o     \                                                  C
8352 C       i             i                                                        C
8353 C                                                                              C
8354 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8355 C
8356 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8357 C           energy moment and not to the cluster cumulant.
8358 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8359       iti=itortyp(itype(i))
8360       itj=itortyp(itype(j))
8361       if (j.lt.nres-1) then
8362         itj1=itortyp(itype(j+1))
8363       else
8364         itj1=ntortyp+1
8365       endif
8366       itk=itortyp(itype(k))
8367       if (k.lt.nres-1) then
8368         itk1=itortyp(itype(k+1))
8369       else
8370         itk1=ntortyp+1
8371       endif
8372       itl=itortyp(itype(l))
8373       if (l.lt.nres-1) then
8374         itl1=itortyp(itype(l+1))
8375       else
8376         itl1=ntortyp+1
8377       endif
8378 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8379 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8380 cd     & ' itl',itl,' itl1',itl1
8381 #ifdef MOMENT
8382       if (imat.eq.1) then
8383         s1=dip(3,jj,i)*dip(3,kk,k)
8384       else
8385         s1=dip(2,jj,j)*dip(2,kk,l)
8386       endif
8387 #endif
8388       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8389       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8390       if (j.eq.l+1) then
8391         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8392         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8393       else
8394         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8395         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8396       endif
8397       call transpose2(EUg(1,1,k),auxmat(1,1))
8398       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8399       vv(1)=pizda(1,1)-pizda(2,2)
8400       vv(2)=pizda(2,1)+pizda(1,2)
8401       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8402 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8403 #ifdef MOMENT
8404       eello6_graph4=-(s1+s2+s3+s4)
8405 #else
8406       eello6_graph4=-(s2+s3+s4)
8407 #endif
8408 C Derivatives in gamma(i-1)
8409       if (i.gt.1) then
8410 #ifdef MOMENT
8411         if (imat.eq.1) then
8412           s1=dipderg(2,jj,i)*dip(3,kk,k)
8413         else
8414           s1=dipderg(4,jj,j)*dip(2,kk,l)
8415         endif
8416 #endif
8417         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8418         if (j.eq.l+1) then
8419           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8420           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8421         else
8422           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8423           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8424         endif
8425         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8426         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8427 cd          write (2,*) 'turn6 derivatives'
8428 #ifdef MOMENT
8429           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8430 #else
8431           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8432 #endif
8433         else
8434 #ifdef MOMENT
8435           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8436 #else
8437           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8438 #endif
8439         endif
8440       endif
8441 C Derivatives in gamma(k-1)
8442 #ifdef MOMENT
8443       if (imat.eq.1) then
8444         s1=dip(3,jj,i)*dipderg(2,kk,k)
8445       else
8446         s1=dip(2,jj,j)*dipderg(4,kk,l)
8447       endif
8448 #endif
8449       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8450       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8451       if (j.eq.l+1) then
8452         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8453         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8454       else
8455         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8456         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8457       endif
8458       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8459       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8460       vv(1)=pizda(1,1)-pizda(2,2)
8461       vv(2)=pizda(2,1)+pizda(1,2)
8462       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8463       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8464 #ifdef MOMENT
8465         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8466 #else
8467         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8468 #endif
8469       else
8470 #ifdef MOMENT
8471         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8472 #else
8473         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8474 #endif
8475       endif
8476 C Derivatives in gamma(j-1) or gamma(l-1)
8477       if (l.eq.j+1 .and. l.gt.1) then
8478         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8479         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8480         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8481         vv(1)=pizda(1,1)-pizda(2,2)
8482         vv(2)=pizda(2,1)+pizda(1,2)
8483         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8484         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8485       else if (j.gt.1) then
8486         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8487         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8488         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8489         vv(1)=pizda(1,1)-pizda(2,2)
8490         vv(2)=pizda(2,1)+pizda(1,2)
8491         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8492         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8493           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8494         else
8495           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8496         endif
8497       endif
8498 C Cartesian derivatives.
8499       do iii=1,2
8500         do kkk=1,5
8501           do lll=1,3
8502 #ifdef MOMENT
8503             if (iii.eq.1) then
8504               if (imat.eq.1) then
8505                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8506               else
8507                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8508               endif
8509             else
8510               if (imat.eq.1) then
8511                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8512               else
8513                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8514               endif
8515             endif
8516 #endif
8517             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8518      &        auxvec(1))
8519             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8520             if (j.eq.l+1) then
8521               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8522      &          b1(1,itj1),auxvec(1))
8523               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8524             else
8525               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8526      &          b1(1,itl1),auxvec(1))
8527               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8528             endif
8529             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8530      &        pizda(1,1))
8531             vv(1)=pizda(1,1)-pizda(2,2)
8532             vv(2)=pizda(2,1)+pizda(1,2)
8533             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8534             if (swap) then
8535               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8536 #ifdef MOMENT
8537                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8538      &             -(s1+s2+s4)
8539 #else
8540                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8541      &             -(s2+s4)
8542 #endif
8543                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8544               else
8545 #ifdef MOMENT
8546                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8547 #else
8548                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8549 #endif
8550                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8551               endif
8552             else
8553 #ifdef MOMENT
8554               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8555 #else
8556               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8557 #endif
8558               if (l.eq.j+1) then
8559                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8560               else
8561                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8562               endif
8563             endif
8564           enddo
8565         enddo
8566       enddo
8567       return
8568       end
8569 c----------------------------------------------------------------------------
8570       double precision function eello_turn6(i,jj,kk)
8571       implicit real*8 (a-h,o-z)
8572       include 'DIMENSIONS'
8573       include 'COMMON.IOUNITS'
8574       include 'COMMON.CHAIN'
8575       include 'COMMON.DERIV'
8576       include 'COMMON.INTERACT'
8577       include 'COMMON.CONTACTS'
8578       include 'COMMON.TORSION'
8579       include 'COMMON.VAR'
8580       include 'COMMON.GEO'
8581       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8582      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8583      &  ggg1(3),ggg2(3)
8584       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8585      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8586 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8587 C           the respective energy moment and not to the cluster cumulant.
8588       s1=0.0d0
8589       s8=0.0d0
8590       s13=0.0d0
8591 c
8592       eello_turn6=0.0d0
8593       j=i+4
8594       k=i+1
8595       l=i+3
8596       iti=itortyp(itype(i))
8597       itk=itortyp(itype(k))
8598       itk1=itortyp(itype(k+1))
8599       itl=itortyp(itype(l))
8600       itj=itortyp(itype(j))
8601 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8602 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8603 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8604 cd        eello6=0.0d0
8605 cd        return
8606 cd      endif
8607 cd      write (iout,*)
8608 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8609 cd     &   ' and',k,l
8610 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8611       do iii=1,2
8612         do kkk=1,5
8613           do lll=1,3
8614             derx_turn(lll,kkk,iii)=0.0d0
8615           enddo
8616         enddo
8617       enddo
8618 cd      eij=1.0d0
8619 cd      ekl=1.0d0
8620 cd      ekont=1.0d0
8621       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8622 cd      eello6_5=0.0d0
8623 cd      write (2,*) 'eello6_5',eello6_5
8624 #ifdef MOMENT
8625       call transpose2(AEA(1,1,1),auxmat(1,1))
8626       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8627       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8628       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8629 #endif
8630       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8631       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8632       s2 = scalar2(b1(1,itk),vtemp1(1))
8633 #ifdef MOMENT
8634       call transpose2(AEA(1,1,2),atemp(1,1))
8635       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8636       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8637       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8638 #endif
8639       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8640       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8641       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8642 #ifdef MOMENT
8643       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8644       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8645       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8646       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8647       ss13 = scalar2(b1(1,itk),vtemp4(1))
8648       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8649 #endif
8650 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8651 c      s1=0.0d0
8652 c      s2=0.0d0
8653 c      s8=0.0d0
8654 c      s12=0.0d0
8655 c      s13=0.0d0
8656       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8657 C Derivatives in gamma(i+2)
8658       s1d =0.0d0
8659       s8d =0.0d0
8660 #ifdef MOMENT
8661       call transpose2(AEA(1,1,1),auxmatd(1,1))
8662       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8663       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8664       call transpose2(AEAderg(1,1,2),atempd(1,1))
8665       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8666       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8667 #endif
8668       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8669       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8670       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8671 c      s1d=0.0d0
8672 c      s2d=0.0d0
8673 c      s8d=0.0d0
8674 c      s12d=0.0d0
8675 c      s13d=0.0d0
8676       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8677 C Derivatives in gamma(i+3)
8678 #ifdef MOMENT
8679       call transpose2(AEA(1,1,1),auxmatd(1,1))
8680       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8681       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8682       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8683 #endif
8684       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8685       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8686       s2d = scalar2(b1(1,itk),vtemp1d(1))
8687 #ifdef MOMENT
8688       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8689       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8690 #endif
8691       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8692 #ifdef MOMENT
8693       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8694       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8695       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8696 #endif
8697 c      s1d=0.0d0
8698 c      s2d=0.0d0
8699 c      s8d=0.0d0
8700 c      s12d=0.0d0
8701 c      s13d=0.0d0
8702 #ifdef MOMENT
8703       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8704      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8705 #else
8706       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8707      &               -0.5d0*ekont*(s2d+s12d)
8708 #endif
8709 C Derivatives in gamma(i+4)
8710       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8711       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8712       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8713 #ifdef MOMENT
8714       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8715       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8716       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8717 #endif
8718 c      s1d=0.0d0
8719 c      s2d=0.0d0
8720 c      s8d=0.0d0
8721 C      s12d=0.0d0
8722 c      s13d=0.0d0
8723 #ifdef MOMENT
8724       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8725 #else
8726       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8727 #endif
8728 C Derivatives in gamma(i+5)
8729 #ifdef MOMENT
8730       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8731       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8732       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8733 #endif
8734       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8735       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8736       s2d = scalar2(b1(1,itk),vtemp1d(1))
8737 #ifdef MOMENT
8738       call transpose2(AEA(1,1,2),atempd(1,1))
8739       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8740       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8741 #endif
8742       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8743       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8744 #ifdef MOMENT
8745       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8746       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8747       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8748 #endif
8749 c      s1d=0.0d0
8750 c      s2d=0.0d0
8751 c      s8d=0.0d0
8752 c      s12d=0.0d0
8753 c      s13d=0.0d0
8754 #ifdef MOMENT
8755       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8756      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8757 #else
8758       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8759      &               -0.5d0*ekont*(s2d+s12d)
8760 #endif
8761 C Cartesian derivatives
8762       do iii=1,2
8763         do kkk=1,5
8764           do lll=1,3
8765 #ifdef MOMENT
8766             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8767             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8768             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8769 #endif
8770             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8771             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8772      &          vtemp1d(1))
8773             s2d = scalar2(b1(1,itk),vtemp1d(1))
8774 #ifdef MOMENT
8775             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8776             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8777             s8d = -(atempd(1,1)+atempd(2,2))*
8778      &           scalar2(cc(1,1,itl),vtemp2(1))
8779 #endif
8780             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8781      &           auxmatd(1,1))
8782             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8783             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8784 c      s1d=0.0d0
8785 c      s2d=0.0d0
8786 c      s8d=0.0d0
8787 c      s12d=0.0d0
8788 c      s13d=0.0d0
8789 #ifdef MOMENT
8790             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8791      &        - 0.5d0*(s1d+s2d)
8792 #else
8793             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8794      &        - 0.5d0*s2d
8795 #endif
8796 #ifdef MOMENT
8797             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8798      &        - 0.5d0*(s8d+s12d)
8799 #else
8800             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8801      &        - 0.5d0*s12d
8802 #endif
8803           enddo
8804         enddo
8805       enddo
8806 #ifdef MOMENT
8807       do kkk=1,5
8808         do lll=1,3
8809           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8810      &      achuj_tempd(1,1))
8811           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8812           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8813           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8814           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8815           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8816      &      vtemp4d(1))
8817           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8818           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8819           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8820         enddo
8821       enddo
8822 #endif
8823 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8824 cd     &  16*eel_turn6_num
8825 cd      goto 1112
8826       if (j.lt.nres-1) then
8827         j1=j+1
8828         j2=j-1
8829       else
8830         j1=j-1
8831         j2=j-2
8832       endif
8833       if (l.lt.nres-1) then
8834         l1=l+1
8835         l2=l-1
8836       else
8837         l1=l-1
8838         l2=l-2
8839       endif
8840       do ll=1,3
8841 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8842 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8843 cgrad        ghalf=0.5d0*ggg1(ll)
8844 cd        ghalf=0.0d0
8845         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8846         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8847         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8848      &    +ekont*derx_turn(ll,2,1)
8849         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8850         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8851      &    +ekont*derx_turn(ll,4,1)
8852         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8853         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8854         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8855 cgrad        ghalf=0.5d0*ggg2(ll)
8856 cd        ghalf=0.0d0
8857         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8858      &    +ekont*derx_turn(ll,2,2)
8859         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8860         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8861      &    +ekont*derx_turn(ll,4,2)
8862         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8863         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8864         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8865       enddo
8866 cd      goto 1112
8867 cgrad      do m=i+1,j-1
8868 cgrad        do ll=1,3
8869 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8870 cgrad        enddo
8871 cgrad      enddo
8872 cgrad      do m=k+1,l-1
8873 cgrad        do ll=1,3
8874 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8875 cgrad        enddo
8876 cgrad      enddo
8877 cgrad1112  continue
8878 cgrad      do m=i+2,j2
8879 cgrad        do ll=1,3
8880 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8881 cgrad        enddo
8882 cgrad      enddo
8883 cgrad      do m=k+2,l2
8884 cgrad        do ll=1,3
8885 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8886 cgrad        enddo
8887 cgrad      enddo
8888 cd      do iii=1,nres-3
8889 cd        write (2,*) iii,g_corr6_loc(iii)
8890 cd      enddo
8891       eello_turn6=ekont*eel_turn6
8892 cd      write (2,*) 'ekont',ekont
8893 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8894       return
8895       end
8896
8897 C-----------------------------------------------------------------------------
8898       double precision function scalar(u,v)
8899 !DIR$ INLINEALWAYS scalar
8900 #ifndef OSF
8901 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8902 #endif
8903       implicit none
8904       double precision u(3),v(3)
8905 cd      double precision sc
8906 cd      integer i
8907 cd      sc=0.0d0
8908 cd      do i=1,3
8909 cd        sc=sc+u(i)*v(i)
8910 cd      enddo
8911 cd      scalar=sc
8912
8913       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8914       return
8915       end
8916 crc-------------------------------------------------
8917       SUBROUTINE MATVEC2(A1,V1,V2)
8918 !DIR$ INLINEALWAYS MATVEC2
8919 #ifndef OSF
8920 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8921 #endif
8922       implicit real*8 (a-h,o-z)
8923       include 'DIMENSIONS'
8924       DIMENSION A1(2,2),V1(2),V2(2)
8925 c      DO 1 I=1,2
8926 c        VI=0.0
8927 c        DO 3 K=1,2
8928 c    3     VI=VI+A1(I,K)*V1(K)
8929 c        Vaux(I)=VI
8930 c    1 CONTINUE
8931
8932       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8933       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8934
8935       v2(1)=vaux1
8936       v2(2)=vaux2
8937       END
8938 C---------------------------------------
8939       SUBROUTINE MATMAT2(A1,A2,A3)
8940 #ifndef OSF
8941 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8942 #endif
8943       implicit real*8 (a-h,o-z)
8944       include 'DIMENSIONS'
8945       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8946 c      DIMENSION AI3(2,2)
8947 c        DO  J=1,2
8948 c          A3IJ=0.0
8949 c          DO K=1,2
8950 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8951 c          enddo
8952 c          A3(I,J)=A3IJ
8953 c       enddo
8954 c      enddo
8955
8956       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8957       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8958       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8959       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8960
8961       A3(1,1)=AI3_11
8962       A3(2,1)=AI3_21
8963       A3(1,2)=AI3_12
8964       A3(2,2)=AI3_22
8965       END
8966
8967 c-------------------------------------------------------------------------
8968       double precision function scalar2(u,v)
8969 !DIR$ INLINEALWAYS scalar2
8970       implicit none
8971       double precision u(2),v(2)
8972       double precision sc
8973       integer i
8974       scalar2=u(1)*v(1)+u(2)*v(2)
8975       return
8976       end
8977
8978 C-----------------------------------------------------------------------------
8979
8980       subroutine transpose2(a,at)
8981 !DIR$ INLINEALWAYS transpose2
8982 #ifndef OSF
8983 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8984 #endif
8985       implicit none
8986       double precision a(2,2),at(2,2)
8987       at(1,1)=a(1,1)
8988       at(1,2)=a(2,1)
8989       at(2,1)=a(1,2)
8990       at(2,2)=a(2,2)
8991       return
8992       end
8993 c--------------------------------------------------------------------------
8994       subroutine transpose(n,a,at)
8995       implicit none
8996       integer n,i,j
8997       double precision a(n,n),at(n,n)
8998       do i=1,n
8999         do j=1,n
9000           at(j,i)=a(i,j)
9001         enddo
9002       enddo
9003       return
9004       end
9005 C---------------------------------------------------------------------------
9006       subroutine prodmat3(a1,a2,kk,transp,prod)
9007 !DIR$ INLINEALWAYS prodmat3
9008 #ifndef OSF
9009 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9010 #endif
9011       implicit none
9012       integer i,j
9013       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9014       logical transp
9015 crc      double precision auxmat(2,2),prod_(2,2)
9016
9017       if (transp) then
9018 crc        call transpose2(kk(1,1),auxmat(1,1))
9019 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9020 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9021
9022            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9023      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9024            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9025      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9026            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9027      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9028            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9029      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9030
9031       else
9032 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9033 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9034
9035            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9036      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9037            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9038      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9039            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9040      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9041            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9042      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9043
9044       endif
9045 c      call transpose2(a2(1,1),a2t(1,1))
9046
9047 crc      print *,transp
9048 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9049 crc      print *,((prod(i,j),i=1,2),j=1,2)
9050
9051       return
9052       end
9053