source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 c    Here are the energies showed per procesor if the are more processors
 305 c    per molecule then we sum it up in sum_energy subroutine
 306 c      print *," Processor",myrank," calls SUM_ENERGY"
 307       call sum_energy(energia,.true.)
 308       if (dyn_ss) call dyn_set_nss
 309 c      print *," Processor",myrank," left SUM_ENERGY"
 310 #ifdef TIMING
 311       time_sumene=time_sumene+MPI_Wtime()-time00
 312 #endif
 313       return
 314       end
 315 c-------------------------------------------------------------------------------
 316       subroutine sum_energy(energia,reduce)
 317       implicit real*8 (a-h,o-z)
 318       include 'DIMENSIONS'
 319 #ifndef ISNAN
 320       external proc_proc
 321 #ifdef WINPGI
 322 cMS$ATTRIBUTES C ::  proc_proc
 323 #endif
 324 #endif
 325 #ifdef MPI
 326       include "mpif.h"
 327 #endif
 328       include 'COMMON.SETUP'
 329       include 'COMMON.IOUNITS'
 330       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 331       include 'COMMON.FFIELD'
 332       include 'COMMON.DERIV'
 333       include 'COMMON.INTERACT'
 334       include 'COMMON.SBRIDGE'
 335       include 'COMMON.CHAIN'
 336       include 'COMMON.VAR'
 337       include 'COMMON.CONTROL'
 338       include 'COMMON.TIME1'
 339       logical reduce
 340 #ifdef MPI
 341       if (nfgtasks.gt.1 .and. reduce) then
 342 #ifdef DEBUG
 343         write (iout,*) "energies before REDUCE"
 344         call enerprint(energia)
 345         call flush(iout)
 346 #endif
 347         do i=0,n_ene
 348           enebuff(i)=energia(i)
 349         enddo
 350         time00=MPI_Wtime()
 351         call MPI_Barrier(FG_COMM,IERR)
 352         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 353         time00=MPI_Wtime()
 354         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 355      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 356 #ifdef DEBUG
 357         write (iout,*) "energies after REDUCE"
 358         call enerprint(energia)
 359         call flush(iout)
 360 #endif
 361         time_Reduce=time_Reduce+MPI_Wtime()-time00
 362       endif
 363       if (fg_rank.eq.0) then
 364 #endif
 365       evdw=energia(1)
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 446 #endif
 447       include 'COMMON.SETUP'
 448       include 'COMMON.IOUNITS'
 449       include 'COMMON.FFIELD'
 450       include 'COMMON.DERIV'
 451       include 'COMMON.INTERACT'
 452       include 'COMMON.SBRIDGE'
 453       include 'COMMON.CHAIN'
 454       include 'COMMON.VAR'
 455       include 'COMMON.CONTROL'
 456       include 'COMMON.TIME1'
 457       include 'COMMON.MAXGRAD'
 458       include 'COMMON.SCCOR'
 459 #ifdef TIMING
 460       time01=MPI_Wtime()
 461 #endif
 462 #ifdef DEBUG
 463       write (iout,*) "sum_gradient gvdwc, gvdwx"
 464       do i=1,nres
 465         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 466      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 467       enddo
 468       call flush(iout)
 469 #endif
 470 #ifdef MPI
 471 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 472         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 473      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 474 #endif
 475 C
 476 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 477 C            in virtual-bond-vector coordinates
 478 C
 479 #ifdef DEBUG
 480 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 481 c      do i=1,nres-1
 482 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 483 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 484 c      enddo
 485 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 486 c      do i=1,nres-1
 487 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 488 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 489 c      enddo
 490       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 491       do i=1,nres
 492         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 493      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 494      &   g_corr5_loc(i)
 495       enddo
 496       call flush(iout)
 497 #endif
 498 #ifdef SPLITELE
 499       do i=1,nct
 500         do j=1,3
 501           gradbufc(j,i)=wsc*gvdwc(j,i)+
 502      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 503      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 504      &                wel_loc*gel_loc_long(j,i)+
 505      &                wcorr*gradcorr_long(j,i)+
 506      &                wcorr5*gradcorr5_long(j,i)+
 507      &                wcorr6*gradcorr6_long(j,i)+
 508      &                wturn6*gcorr6_turn_long(j,i)+
 509      &                wstrain*ghpbc(j,i)
 510         enddo
 511       enddo
 512 #else
 513       do i=1,nct
 514         do j=1,3
 515           gradbufc(j,i)=wsc*gvdwc(j,i)+
 516      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 517      &                welec*gelc_long(j,i)+
 518      &                wbond*gradb(j,i)+
 519      &                wel_loc*gel_loc_long(j,i)+
 520      &                wcorr*gradcorr_long(j,i)+
 521      &                wcorr5*gradcorr5_long(j,i)+
 522      &                wcorr6*gradcorr6_long(j,i)+
 523      &                wturn6*gcorr6_turn_long(j,i)+
 524      &                wstrain*ghpbc(j,i)
 525         enddo
 526       enddo
 527 #endif
 528 #ifdef MPI
 529       if (nfgtasks.gt.1) then
 530       time00=MPI_Wtime()
 531 #ifdef DEBUG
 532       write (iout,*) "gradbufc before allreduce"
 533       do i=1,nres
 534         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 535       enddo
 536       call flush(iout)
 537 #endif
 538       do i=1,nres
 539         do j=1,3
 540           gradbufc_sum(j,i)=gradbufc(j,i)
 541         enddo
 542       enddo
 543 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 544 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 545 c      time_reduce=time_reduce+MPI_Wtime()-time00
 546 #ifdef DEBUG
 547 c      write (iout,*) "gradbufc_sum after allreduce"
 548 c      do i=1,nres
 549 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 550 c      enddo
 551 c      call flush(iout)
 552 #endif
 553 #ifdef TIMING
 554 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 555 #endif
 556       do i=nnt,nres
 557         do k=1,3
 558           gradbufc(k,i)=0.0d0
 559         enddo
 560       enddo
 561 #ifdef DEBUG
 562       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 563       write (iout,*) (i," jgrad_start",jgrad_start(i),
 564      &                  " jgrad_end  ",jgrad_end(i),
 565      &                  i=igrad_start,igrad_end)
 566 #endif
 567 c
 568 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 569 c do not parallelize this part.
 570 c
 571 c      do i=igrad_start,igrad_end
 572 c        do j=jgrad_start(i),jgrad_end(i)
 573 c          do k=1,3
 574 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 575 c          enddo
 576 c        enddo
 577 c      enddo
 578       do j=1,3
 579         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 580       enddo
 581       do i=nres-2,nnt,-1
 582         do j=1,3
 583           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 584         enddo
 585       enddo
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc after summing"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       else
 594 #endif
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       do i=1,nres
 603         do j=1,3
 604           gradbufc_sum(j,i)=gradbufc(j,i)
 605           gradbufc(j,i)=0.0d0
 606         enddo
 607       enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,nnt,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 c      do i=nnt,nres-1
 617 c        do k=1,3
 618 c          gradbufc(k,i)=0.0d0
 619 c        enddo
 620 c        do j=i+1,nres
 621 c          do k=1,3
 622 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 623 c          enddo
 624 c        enddo
 625 c      enddo
 626 #ifdef DEBUG
 627       write (iout,*) "gradbufc after summing"
 628       do i=1,nres
 629         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 630       enddo
 631       call flush(iout)
 632 #endif
 633 #ifdef MPI
 634       endif
 635 #endif
 636       do k=1,3
 637         gradbufc(k,nres)=0.0d0
 638       enddo
 639       do i=1,nct
 640         do j=1,3
 641 #ifdef SPLITELE
 642           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 643      &                wel_loc*gel_loc(j,i)+
 644      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 645      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 646      &                wel_loc*gel_loc_long(j,i)+
 647      &                wcorr*gradcorr_long(j,i)+
 648      &                wcorr5*gradcorr5_long(j,i)+
 649      &                wcorr6*gradcorr6_long(j,i)+
 650      &                wturn6*gcorr6_turn_long(j,i))+
 651      &                wbond*gradb(j,i)+
 652      &                wcorr*gradcorr(j,i)+
 653      &                wturn3*gcorr3_turn(j,i)+
 654      &                wturn4*gcorr4_turn(j,i)+
 655      &                wcorr5*gradcorr5(j,i)+
 656      &                wcorr6*gradcorr6(j,i)+
 657      &                wturn6*gcorr6_turn(j,i)+
 658      &                wsccor*gsccorc(j,i)
 659      &               +wscloc*gscloc(j,i)
 660 #else
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679 #endif
 680           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 681      &                  wbond*gradbx(j,i)+
 682      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 683      &                  wsccor*gsccorx(j,i)
 684      &                 +wscloc*gsclocx(j,i)
 685         enddo
 686       enddo
 687 #ifdef DEBUG
 688       write (iout,*) "gloc before adding corr"
 689       do i=1,4*nres
 690         write (iout,*) i,gloc(i,icg)
 691       enddo
 692 #endif
 693       do i=1,nres-3
 694         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 695      &   +wcorr5*g_corr5_loc(i)
 696      &   +wcorr6*g_corr6_loc(i)
 697      &   +wturn4*gel_loc_turn4(i)
 698      &   +wturn3*gel_loc_turn3(i)
 699      &   +wturn6*gel_loc_turn6(i)
 700      &   +wel_loc*gel_loc_loc(i)
 701       enddo
 702 #ifdef DEBUG
 703       write (iout,*) "gloc after adding corr"
 704       do i=1,4*nres
 705         write (iout,*) i,gloc(i,icg)
 706       enddo
 707 #endif
 708 #ifdef MPI
 709       if (nfgtasks.gt.1) then
 710         do j=1,3
 711           do i=1,nres
 712             gradbufc(j,i)=gradc(j,i,icg)
 713             gradbufx(j,i)=gradx(j,i,icg)
 714           enddo
 715         enddo
 716         do i=1,4*nres
 717           glocbuf(i)=gloc(i,icg)
 718         enddo
 719 c#define DEBUG
 720 #ifdef DEBUG
 721       write (iout,*) "gloc_sc before reduce"
 722       do i=1,nres
 723        do j=1,1
 724         write (iout,*) i,j,gloc_sc(j,i,icg)
 725        enddo
 726       enddo
 727 #endif
 728 c#undef DEBUG
 729         do i=1,nres
 730          do j=1,3
 731           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 732          enddo
 733         enddo
 734         time00=MPI_Wtime()
 735         call MPI_Barrier(FG_COMM,IERR)
 736         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 737         time00=MPI_Wtime()
 738         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 739      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 740         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 743      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 744         time_reduce=time_reduce+MPI_Wtime()-time00
 745         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 746      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 747         time_reduce=time_reduce+MPI_Wtime()-time00
 748 c#define DEBUG
 749 #ifdef DEBUG
 750       write (iout,*) "gloc_sc after reduce"
 751       do i=1,nres
 752        do j=1,1
 753         write (iout,*) i,j,gloc_sc(j,i,icg)
 754        enddo
 755       enddo
 756 #endif
 757 c#undef DEBUG
 758 #ifdef DEBUG
 759       write (iout,*) "gloc after reduce"
 760       do i=1,4*nres
 761         write (iout,*) i,gloc(i,icg)
 762       enddo
 763 #endif
 764       endif
 765 #endif
 766       if (gnorm_check) then
 767 c
 768 c Compute the maximum elements of the gradient
 769 c
 770       gvdwc_max=0.0d0
 771       gvdwc_scp_max=0.0d0
 772       gelc_max=0.0d0
 773       gvdwpp_max=0.0d0
 774       gradb_max=0.0d0
 775       ghpbc_max=0.0d0
 776       gradcorr_max=0.0d0
 777       gel_loc_max=0.0d0
 778       gcorr3_turn_max=0.0d0
 779       gcorr4_turn_max=0.0d0
 780       gradcorr5_max=0.0d0
 781       gradcorr6_max=0.0d0
 782       gcorr6_turn_max=0.0d0
 783       gsccorc_max=0.0d0
 784       gscloc_max=0.0d0
 785       gvdwx_max=0.0d0
 786       gradx_scp_max=0.0d0
 787       ghpbx_max=0.0d0
 788       gradxorr_max=0.0d0
 789       gsccorx_max=0.0d0
 790       gsclocx_max=0.0d0
 791       do i=1,nct
 792         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 793         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 794         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 795         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 796      &   gvdwc_scp_max=gvdwc_scp_norm
 797         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 798         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 799         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 800         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 801         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 802         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 803         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 804         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 805         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 806         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 807         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 808         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 809         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 810      &    gcorr3_turn(1,i)))
 811         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 812      &    gcorr3_turn_max=gcorr3_turn_norm
 813         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 814      &    gcorr4_turn(1,i)))
 815         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 816      &    gcorr4_turn_max=gcorr4_turn_norm
 817         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 818         if (gradcorr5_norm.gt.gradcorr5_max)
 819      &    gradcorr5_max=gradcorr5_norm
 820         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 821         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 822         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 823      &    gcorr6_turn(1,i)))
 824         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 825      &    gcorr6_turn_max=gcorr6_turn_norm
 826         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 827         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 828         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 829         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 830         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 831         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 832         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 833         if (gradx_scp_norm.gt.gradx_scp_max)
 834      &    gradx_scp_max=gradx_scp_norm
 835         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 836         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 837         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 838         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 839         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 840         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 841         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 842         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 843       enddo
 844       if (gradout) then
 845 #ifdef AIX
 846         open(istat,file=statname,position="append")
 847 #else
 848         open(istat,file=statname,access="append")
 849 #endif
 850         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 851      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 852      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 853      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 854      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 855      &     gsccorx_max,gsclocx_max
 856         close(istat)
 857         if (gvdwc_max.gt.1.0d4) then
 858           write (iout,*) "gvdwc gvdwx gradb gradbx"
 859           do i=nnt,nct
 860             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 861      &        gradb(j,i),gradbx(j,i),j=1,3)
 862           enddo
 863           call pdbout(0.0d0,'cipiszcze',iout)
 864           call flush(iout)
 865         endif
 866       endif
 867       endif
 868 #ifdef DEBUG
 869       write (iout,*) "gradc gradx gloc"
 870       do i=1,nres
 871         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 872      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 873       enddo
 874 #endif
 875 #ifdef TIMING
 876       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 877 #endif
 878       return
 879       end
 880 c-------------------------------------------------------------------------------
 881       subroutine rescale_weights(t_bath)
 882       implicit real*8 (a-h,o-z)
 883       include 'DIMENSIONS'
 884       include 'COMMON.IOUNITS'
 885       include 'COMMON.FFIELD'
 886       include 'COMMON.SBRIDGE'
 887       double precision kfac /2.4d0/
 888       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 889 c      facT=temp0/t_bath
 890 c      facT=2*temp0/(t_bath+temp0)
 891       if (rescale_mode.eq.0) then
 892         facT=1.0d0
 893         facT2=1.0d0
 894         facT3=1.0d0
 895         facT4=1.0d0
 896         facT5=1.0d0
 897       else if (rescale_mode.eq.1) then
 898         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 899         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 900         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 901         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 902         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 903       else if (rescale_mode.eq.2) then
 904         x=t_bath/temp0
 905         x2=x*x
 906         x3=x2*x
 907         x4=x3*x
 908         x5=x4*x
 909         facT=licznik/dlog(dexp(x)+dexp(-x))
 910         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 911         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 912         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 913         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 914       else
 915         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 916         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 917 #ifdef MPI
 918        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 919 #endif
 920        stop 555
 921       endif
 922       welec=weights(3)*fact
 923       wcorr=weights(4)*fact3
 924       wcorr5=weights(5)*fact4
 925       wcorr6=weights(6)*fact5
 926       wel_loc=weights(7)*fact2
 927       wturn3=weights(8)*fact2
 928       wturn4=weights(9)*fact3
 929       wturn6=weights(10)*fact5
 930       wtor=weights(13)*fact
 931       wtor_d=weights(14)*fact2
 932       wsccor=weights(21)*fact
 933
 934       return
 935       end
 936 C------------------------------------------------------------------------
 937       subroutine enerprint(energia)
 938       implicit real*8 (a-h,o-z)
 939       include 'DIMENSIONS'
 940       include 'COMMON.IOUNITS'
 941       include 'COMMON.FFIELD'
 942       include 'COMMON.SBRIDGE'
 943       include 'COMMON.MD'
 944       double precision energia(0:n_ene)
 945       etot=energia(0)
 946       evdw=energia(1)
 947       evdw2=energia(2)
 948 #ifdef SCP14
 949       evdw2=energia(2)+energia(18)
 950 #else
 951       evdw2=energia(2)
 952 #endif
 953       ees=energia(3)
 954 #ifdef SPLITELE
 955       evdw1=energia(16)
 956 #endif
 957       ecorr=energia(4)
 958       ecorr5=energia(5)
 959       ecorr6=energia(6)
 960       eel_loc=energia(7)
 961       eello_turn3=energia(8)
 962       eello_turn4=energia(9)
 963       eello_turn6=energia(10)
 964       ebe=energia(11)
 965       escloc=energia(12)
 966       etors=energia(13)
 967       etors_d=energia(14)
 968       ehpb=energia(15)
 969       edihcnstr=energia(19)
 970       estr=energia(17)
 971       Uconst=energia(20)
 972       esccor=energia(21)
 973 #ifdef SPLITELE
 974       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 975      &  estr,wbond,ebe,wang,
 976      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 977      &  ecorr,wcorr,
 978      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 979      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 980      &  edihcnstr,ebr*nss,
 981      &  Uconst,etot
 982    10 format (/'Virtual-chain energies:'//
 983      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 984      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 985      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 986      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 987      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 988      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 989      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 990      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 991      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 992      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 993      & ' (SS bridges & dist. cnstr.)'/
 994      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 998      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 999      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1000      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1001      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1002      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1003      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1004      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1005      & 'ETOT=  ',1pE16.6,' (total)')
1006 #else
1007       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1008      &  estr,wbond,ebe,wang,
1009      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1010      &  ecorr,wcorr,
1011      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1012      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1013      &  ebr*nss,Uconst,etot
1014    10 format (/'Virtual-chain energies:'//
1015      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1016      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1017      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1018      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1019      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1020      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1021      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1022      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1023      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1024      & ' (SS bridges & dist. cnstr.)'/
1025      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1029      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1030      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1031      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1032      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1033      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1034      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1035      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1036      & 'ETOT=  ',1pE16.6,' (total)')
1037 #endif
1038       return
1039       end
1040 C-----------------------------------------------------------------------
1041       subroutine elj(evdw)
1042 C
1043 C This subroutine calculates the interaction energy of nonbonded side chains
1044 C assuming the LJ potential of interaction.
1045 C
1046       implicit real*8 (a-h,o-z)
1047       include 'DIMENSIONS'
1048       parameter (accur=1.0d-10)
1049       include 'COMMON.GEO'
1050       include 'COMMON.VAR'
1051       include 'COMMON.LOCAL'
1052       include 'COMMON.CHAIN'
1053       include 'COMMON.DERIV'
1054       include 'COMMON.INTERACT'
1055       include 'COMMON.TORSION'
1056       include 'COMMON.SBRIDGE'
1057       include 'COMMON.NAMES'
1058       include 'COMMON.IOUNITS'
1059       include 'COMMON.CONTACTS'
1060       dimension gg(3)
1061 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 C Change 12/1/95
1071         num_conti=0
1072 C
1073 C Calculate SC interaction energy.
1074 C
1075         do iint=1,nint_gr(i)
1076 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1077 cd   &                  'iend=',iend(i,iint)
1078           do j=istart(i,iint),iend(i,iint)
1079             itypj=iabs(itype(j))
1080             if (itypj.eq.ntyp1) cycle
1081             xj=c(1,nres+j)-xi
1082             yj=c(2,nres+j)-yi
1083             zj=c(3,nres+j)-zi
1084 C Change 12/1/95 to calculate four-body interactions
1085             rij=xj*xj+yj*yj+zj*zj
1086             rrij=1.0D0/rij
1087 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1088             eps0ij=eps(itypi,itypj)
1089             fac=rrij**expon2
1090             e1=fac*fac*aa(itypi,itypj)
1091             e2=fac*bb(itypi,itypj)
1092             evdwij=e1+e2
1093 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1096 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1097 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1098 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1099             evdw=evdw+evdwij
1100 C
1101 C Calculate the components of the gradient in DC and X
1102 C
1103             fac=-rrij*(e1+evdwij)
1104             gg(1)=xj*fac
1105             gg(2)=yj*fac
1106             gg(3)=zj*fac
1107             do k=1,3
1108               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1109               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1110               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1111               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1112             enddo
1113 cgrad            do k=i,j-1
1114 cgrad              do l=1,3
1115 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1116 cgrad              enddo
1117 cgrad            enddo
1118 C
1119 C 12/1/95, revised on 5/20/97
1120 C
1121 C Calculate the contact function. The ith column of the array JCONT will
1122 C contain the numbers of atoms that make contacts with the atom I (of numbers
1123 C greater than I). The arrays FACONT and GACONT will contain the values of
1124 C the contact function and its derivative.
1125 C
1126 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1127 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1128 C Uncomment next line, if the correlation interactions are contact function only
1129             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1130               rij=dsqrt(rij)
1131               sigij=sigma(itypi,itypj)
1132               r0ij=rs0(itypi,itypj)
1133 C
1134 C Check whether the SC's are not too far to make a contact.
1135 C
1136               rcut=1.5d0*r0ij
1137               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1138 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1139 C
1140               if (fcont.gt.0.0D0) then
1141 C If the SC-SC distance if close to sigma, apply spline.
1142 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1143 cAdam &             fcont1,fprimcont1)
1144 cAdam           fcont1=1.0d0-fcont1
1145 cAdam           if (fcont1.gt.0.0d0) then
1146 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1147 cAdam             fcont=fcont*fcont1
1148 cAdam           endif
1149 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1150 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1151 cga             do k=1,3
1152 cga               gg(k)=gg(k)*eps0ij
1153 cga             enddo
1154 cga             eps0ij=-evdwij*eps0ij
1155 C Uncomment for AL's type of SC correlation interactions.
1156 cadam           eps0ij=-evdwij
1157                 num_conti=num_conti+1
1158                 jcont(num_conti,i)=j
1159                 facont(num_conti,i)=fcont*eps0ij
1160                 fprimcont=eps0ij*fprimcont/rij
1161                 fcont=expon*fcont
1162 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1163 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1164 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1165 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1166                 gacont(1,num_conti,i)=-fprimcont*xj
1167                 gacont(2,num_conti,i)=-fprimcont*yj
1168                 gacont(3,num_conti,i)=-fprimcont*zj
1169 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1170 cd              write (iout,'(2i3,3f10.5)')
1171 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1172               endif
1173             endif
1174           enddo      ! j
1175         enddo        ! iint
1176 C Change 12/1/95
1177         num_cont(i)=num_conti
1178       enddo          ! i
1179       do i=1,nct
1180         do j=1,3
1181           gvdwc(j,i)=expon*gvdwc(j,i)
1182           gvdwx(j,i)=expon*gvdwx(j,i)
1183         enddo
1184       enddo
1185 C******************************************************************************
1186 C
1187 C                              N O T E !!!
1188 C
1189 C To save time, the factor of EXPON has been extracted from ALL components
1190 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1191 C use!
1192 C
1193 C******************************************************************************
1194       return
1195       end
1196 C-----------------------------------------------------------------------------
1197       subroutine eljk(evdw)
1198 C
1199 C This subroutine calculates the interaction energy of nonbonded side chains
1200 C assuming the LJK potential of interaction.
1201 C
1202       implicit real*8 (a-h,o-z)
1203       include 'DIMENSIONS'
1204       include 'COMMON.GEO'
1205       include 'COMMON.VAR'
1206       include 'COMMON.LOCAL'
1207       include 'COMMON.CHAIN'
1208       include 'COMMON.DERIV'
1209       include 'COMMON.INTERACT'
1210       include 'COMMON.IOUNITS'
1211       include 'COMMON.NAMES'
1212       dimension gg(3)
1213       logical scheck
1214 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1215       evdw=0.0D0
1216       do i=iatsc_s,iatsc_e
1217         itypi=iabs(itype(i))
1218         if (itypi.eq.ntyp1) cycle
1219         itypi1=iabs(itype(i+1))
1220         xi=c(1,nres+i)
1221         yi=c(2,nres+i)
1222         zi=c(3,nres+i)
1223 C
1224 C Calculate SC interaction energy.
1225 C
1226         do iint=1,nint_gr(i)
1227           do j=istart(i,iint),iend(i,iint)
1228             itypj=iabs(itype(j))
1229             if (itypj.eq.ntyp1) cycle
1230             xj=c(1,nres+j)-xi
1231             yj=c(2,nres+j)-yi
1232             zj=c(3,nres+j)-zi
1233             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1234             fac_augm=rrij**expon
1235             e_augm=augm(itypi,itypj)*fac_augm
1236             r_inv_ij=dsqrt(rrij)
1237             rij=1.0D0/r_inv_ij
1238             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1239             fac=r_shift_inv**expon
1240             e1=fac*fac*aa(itypi,itypj)
1241             e2=fac*bb(itypi,itypj)
1242             evdwij=e_augm+e1+e2
1243 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1244 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1245 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1246 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1247 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1248 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1249 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1250             evdw=evdw+evdwij
1251 C
1252 C Calculate the components of the gradient in DC and X
1253 C
1254             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1255             gg(1)=xj*fac
1256             gg(2)=yj*fac
1257             gg(3)=zj*fac
1258             do k=1,3
1259               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1260               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1261               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1262               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1263             enddo
1264 cgrad            do k=i,j-1
1265 cgrad              do l=1,3
1266 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1267 cgrad              enddo
1268 cgrad            enddo
1269           enddo      ! j
1270         enddo        ! iint
1271       enddo          ! i
1272       do i=1,nct
1273         do j=1,3
1274           gvdwc(j,i)=expon*gvdwc(j,i)
1275           gvdwx(j,i)=expon*gvdwx(j,i)
1276         enddo
1277       enddo
1278       return
1279       end
1280 C-----------------------------------------------------------------------------
1281       subroutine ebp(evdw)
1282 C
1283 C This subroutine calculates the interaction energy of nonbonded side chains
1284 C assuming the Berne-Pechukas potential of interaction.
1285 C
1286       implicit real*8 (a-h,o-z)
1287       include 'DIMENSIONS'
1288       include 'COMMON.GEO'
1289       include 'COMMON.VAR'
1290       include 'COMMON.LOCAL'
1291       include 'COMMON.CHAIN'
1292       include 'COMMON.DERIV'
1293       include 'COMMON.NAMES'
1294       include 'COMMON.INTERACT'
1295       include 'COMMON.IOUNITS'
1296       include 'COMMON.CALC'
1297       common /srutu/ icall
1298 c     double precision rrsave(maxdim)
1299       logical lprn
1300       evdw=0.0D0
1301 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1302       evdw=0.0D0
1303 c     if (icall.eq.0) then
1304 c       lprn=.true.
1305 c     else
1306         lprn=.false.
1307 c     endif
1308       ind=0
1309       do i=iatsc_s,iatsc_e
1310         itypi=iabs(itype(i))
1311         if (itypi.eq.ntyp1) cycle
1312         itypi1=iabs(itype(i+1))
1313         xi=c(1,nres+i)
1314         yi=c(2,nres+i)
1315         zi=c(3,nres+i)
1316         dxi=dc_norm(1,nres+i)
1317         dyi=dc_norm(2,nres+i)
1318         dzi=dc_norm(3,nres+i)
1319 c        dsci_inv=dsc_inv(itypi)
1320         dsci_inv=vbld_inv(i+nres)
1321 C
1322 C Calculate SC interaction energy.
1323 C
1324         do iint=1,nint_gr(i)
1325           do j=istart(i,iint),iend(i,iint)
1326             ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 c            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331             chi1=chi(itypi,itypj)
1332             chi2=chi(itypj,itypi)
1333             chi12=chi1*chi2
1334             chip1=chip(itypi)
1335             chip2=chip(itypj)
1336             chip12=chip1*chip2
1337             alf1=alp(itypi)
1338             alf2=alp(itypj)
1339             alf12=0.5D0*(alf1+alf2)
1340 C For diagnostics only!!!
1341 c           chi1=0.0D0
1342 c           chi2=0.0D0
1343 c           chi12=0.0D0
1344 c           chip1=0.0D0
1345 c           chip2=0.0D0
1346 c           chip12=0.0D0
1347 c           alf1=0.0D0
1348 c           alf2=0.0D0
1349 c           alf12=0.0D0
1350             xj=c(1,nres+j)-xi
1351             yj=c(2,nres+j)-yi
1352             zj=c(3,nres+j)-zi
1353             dxj=dc_norm(1,nres+j)
1354             dyj=dc_norm(2,nres+j)
1355             dzj=dc_norm(3,nres+j)
1356             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1357 cd          if (icall.eq.0) then
1358 cd            rrsave(ind)=rrij
1359 cd          else
1360 cd            rrij=rrsave(ind)
1361 cd          endif
1362             rij=dsqrt(rrij)
1363 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1364             call sc_angular
1365 C Calculate whole angle-dependent part of epsilon and contributions
1366 C to its derivatives
1367             fac=(rrij*sigsq)**expon2
1368             e1=fac*fac*aa(itypi,itypj)
1369             e2=fac*bb(itypi,itypj)
1370             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1371             eps2der=evdwij*eps3rt
1372             eps3der=evdwij*eps2rt
1373             evdwij=evdwij*eps2rt*eps3rt
1374             evdw=evdw+evdwij
1375             if (lprn) then
1376             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1377             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1378 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1379 cd     &        restyp(itypi),i,restyp(itypj),j,
1380 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1381 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1382 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1383 cd     &        evdwij
1384             endif
1385 C Calculate gradient components.
1386             e1=e1*eps1*eps2rt**2*eps3rt**2
1387             fac=-expon*(e1+evdwij)
1388             sigder=fac/sigsq
1389             fac=rrij*fac
1390 C Calculate radial part of the gradient
1391             gg(1)=xj*fac
1392             gg(2)=yj*fac
1393             gg(3)=zj*fac
1394 C Calculate the angular part of the gradient and sum add the contributions
1395 C to the appropriate components of the Cartesian gradient.
1396             call sc_grad
1397           enddo      ! j
1398         enddo        ! iint
1399       enddo          ! i
1400 c     stop
1401       return
1402       end
1403 C-----------------------------------------------------------------------------
1404       subroutine egb(evdw)
1405 C
1406 C This subroutine calculates the interaction energy of nonbonded side chains
1407 C assuming the Gay-Berne potential of interaction.
1408 C
1409       implicit real*8 (a-h,o-z)
1410       include 'DIMENSIONS'
1411       include 'COMMON.GEO'
1412       include 'COMMON.VAR'
1413       include 'COMMON.LOCAL'
1414       include 'COMMON.CHAIN'
1415       include 'COMMON.DERIV'
1416       include 'COMMON.NAMES'
1417       include 'COMMON.INTERACT'
1418       include 'COMMON.IOUNITS'
1419       include 'COMMON.CALC'
1420       include 'COMMON.CONTROL'
1421       include 'COMMON.SBRIDGE'
1422       logical lprn
1423       evdw=0.0D0
1424 ccccc      energy_dec=.false.
1425 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427       lprn=.false.
1428 c     if (icall.eq.0) lprn=.false.
1429       ind=0
1430       do i=iatsc_s,iatsc_e
1431         itypi=iabs(itype(i))
1432         if (itypi.eq.ntyp1) cycle
1433         itypi1=iabs(itype(i+1))
1434         xi=c(1,nres+i)
1435         yi=c(2,nres+i)
1436         zi=c(3,nres+i)
1437         dxi=dc_norm(1,nres+i)
1438         dyi=dc_norm(2,nres+i)
1439         dzi=dc_norm(3,nres+i)
1440 c        dsci_inv=dsc_inv(itypi)
1441         dsci_inv=vbld_inv(i+nres)
1442 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1443 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1450               call dyn_ssbond_ene(i,j,evdwij)
1451               evdw=evdw+evdwij
1452               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1453      &                        'evdw',i,j,evdwij,' ss'
1454             ELSE
1455             ind=ind+1
1456             itypj=iabs(itype(j))
1457             if (itypj.eq.ntyp1) cycle
1458 c            dscj_inv=dsc_inv(itypj)
1459             dscj_inv=vbld_inv(j+nres)
1460 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1461 c     &       1.0d0/vbld(j+nres)
1462 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1463             sig0ij=sigma(itypi,itypj)
1464             chi1=chi(itypi,itypj)
1465             chi2=chi(itypj,itypi)
1466             chi12=chi1*chi2
1467             chip1=chip(itypi)
1468             chip2=chip(itypj)
1469             chip12=chip1*chip2
1470             alf1=alp(itypi)
1471             alf2=alp(itypj)
1472             alf12=0.5D0*(alf1+alf2)
1473 C For diagnostics only!!!
1474 c           chi1=0.0D0
1475 c           chi2=0.0D0
1476 c           chi12=0.0D0
1477 c           chip1=0.0D0
1478 c           chip2=0.0D0
1479 c           chip12=0.0D0
1480 c           alf1=0.0D0
1481 c           alf2=0.0D0
1482 c           alf12=0.0D0
1483             xj=c(1,nres+j)-xi
1484             yj=c(2,nres+j)-yi
1485             zj=c(3,nres+j)-zi
1486             dxj=dc_norm(1,nres+j)
1487             dyj=dc_norm(2,nres+j)
1488             dzj=dc_norm(3,nres+j)
1489 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1490 c            write (iout,*) "j",j," dc_norm",
1491 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1492             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1493             rij=dsqrt(rrij)
1494 C Calculate angle-dependent terms of energy and contributions to their
1495 C derivatives.
1496             call sc_angular
1497             sigsq=1.0D0/sigsq
1498             sig=sig0ij*dsqrt(sigsq)
1499             rij_shift=1.0D0/rij-sig+sig0ij
1500 c for diagnostics; uncomment
1501 c            rij_shift=1.2*sig0ij
1502 C I hate to put IF's in the loops, but here don't have another choice!!!!
1503             if (rij_shift.le.0.0D0) then
1504               evdw=1.0D20
1505 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1506 cd     &        restyp(itypi),i,restyp(itypj),j,
1507 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1508               return
1509             endif
1510             sigder=-sig*sigsq
1511 c---------------------------------------------------------------
1512             rij_shift=1.0D0/rij_shift
1513             fac=rij_shift**expon
1514             e1=fac*fac*aa(itypi,itypj)
1515             e2=fac*bb(itypi,itypj)
1516             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1517             eps2der=evdwij*eps3rt
1518             eps3der=evdwij*eps2rt
1519 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1520 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1521             evdwij=evdwij*eps2rt*eps3rt
1522             evdw=evdw+evdwij
1523             if (lprn) then
1524             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1525             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1526             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1527      &        restyp(itypi),i,restyp(itypj),j,
1528      &        epsi,sigm,chi1,chi2,chip1,chip2,
1529      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1530      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1531      &        evdwij
1532             endif
1533
1534             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1535      &                        'evdw',i,j,evdwij
1536
1537 C Calculate gradient components.
1538             e1=e1*eps1*eps2rt**2*eps3rt**2
1539             fac=-expon*(e1+evdwij)*rij_shift
1540             sigder=fac*sigder
1541             fac=rij*fac
1542 c            fac=0.0d0
1543 C Calculate the radial part of the gradient
1544             gg(1)=xj*fac
1545             gg(2)=yj*fac
1546             gg(3)=zj*fac
1547 C Calculate angular part of the gradient.
1548             call sc_grad
1549             ENDIF    ! dyn_ss
1550           enddo      ! j
1551         enddo        ! iint
1552       enddo          ! i
1553 c      write (iout,*) "Number of loop steps in EGB:",ind
1554 cccc      energy_dec=.false.
1555       return
1556       end
1557 C-----------------------------------------------------------------------------
1558       subroutine egbv(evdw)
1559 C
1560 C This subroutine calculates the interaction energy of nonbonded side chains
1561 C assuming the Gay-Berne-Vorobjev potential of interaction.
1562 C
1563       implicit real*8 (a-h,o-z)
1564       include 'DIMENSIONS'
1565       include 'COMMON.GEO'
1566       include 'COMMON.VAR'
1567       include 'COMMON.LOCAL'
1568       include 'COMMON.CHAIN'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.NAMES'
1571       include 'COMMON.INTERACT'
1572       include 'COMMON.IOUNITS'
1573       include 'COMMON.CALC'
1574       common /srutu/ icall
1575       logical lprn
1576       evdw=0.0D0
1577 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1578       evdw=0.0D0
1579       lprn=.false.
1580 c     if (icall.eq.0) lprn=.true.
1581       ind=0
1582       do i=iatsc_s,iatsc_e
1583         itypi=iabs(itype(i))
1584         if (itypi.eq.ntyp1) cycle
1585         itypi1=iabs(itype(i+1))
1586         xi=c(1,nres+i)
1587         yi=c(2,nres+i)
1588         zi=c(3,nres+i)
1589         dxi=dc_norm(1,nres+i)
1590         dyi=dc_norm(2,nres+i)
1591         dzi=dc_norm(3,nres+i)
1592 c        dsci_inv=dsc_inv(itypi)
1593         dsci_inv=vbld_inv(i+nres)
1594 C
1595 C Calculate SC interaction energy.
1596 C
1597         do iint=1,nint_gr(i)
1598           do j=istart(i,iint),iend(i,iint)
1599             ind=ind+1
1600             itypj=iabs(itype(j))
1601             if (itypj.eq.ntyp1) cycle
1602 c            dscj_inv=dsc_inv(itypj)
1603             dscj_inv=vbld_inv(j+nres)
1604             sig0ij=sigma(itypi,itypj)
1605             r0ij=r0(itypi,itypj)
1606             chi1=chi(itypi,itypj)
1607             chi2=chi(itypj,itypi)
1608             chi12=chi1*chi2
1609             chip1=chip(itypi)
1610             chip2=chip(itypj)
1611             chip12=chip1*chip2
1612             alf1=alp(itypi)
1613             alf2=alp(itypj)
1614             alf12=0.5D0*(alf1+alf2)
1615 C For diagnostics only!!!
1616 c           chi1=0.0D0
1617 c           chi2=0.0D0
1618 c           chi12=0.0D0
1619 c           chip1=0.0D0
1620 c           chip2=0.0D0
1621 c           chip12=0.0D0
1622 c           alf1=0.0D0
1623 c           alf2=0.0D0
1624 c           alf12=0.0D0
1625             xj=c(1,nres+j)-xi
1626             yj=c(2,nres+j)-yi
1627             zj=c(3,nres+j)-zi
1628             dxj=dc_norm(1,nres+j)
1629             dyj=dc_norm(2,nres+j)
1630             dzj=dc_norm(3,nres+j)
1631             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1632             rij=dsqrt(rrij)
1633 C Calculate angle-dependent terms of energy and contributions to their
1634 C derivatives.
1635             call sc_angular
1636             sigsq=1.0D0/sigsq
1637             sig=sig0ij*dsqrt(sigsq)
1638             rij_shift=1.0D0/rij-sig+r0ij
1639 C I hate to put IF's in the loops, but here don't have another choice!!!!
1640             if (rij_shift.le.0.0D0) then
1641               evdw=1.0D20
1642               return
1643             endif
1644             sigder=-sig*sigsq
1645 c---------------------------------------------------------------
1646             rij_shift=1.0D0/rij_shift
1647             fac=rij_shift**expon
1648             e1=fac*fac*aa(itypi,itypj)
1649             e2=fac*bb(itypi,itypj)
1650             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1651             eps2der=evdwij*eps3rt
1652             eps3der=evdwij*eps2rt
1653             fac_augm=rrij**expon
1654             e_augm=augm(itypi,itypj)*fac_augm
1655             evdwij=evdwij*eps2rt*eps3rt
1656             evdw=evdw+evdwij+e_augm
1657             if (lprn) then
1658             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1659             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1660             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1661      &        restyp(itypi),i,restyp(itypj),j,
1662      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1663      &        chi1,chi2,chip1,chip2,
1664      &        eps1,eps2rt**2,eps3rt**2,
1665      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1666      &        evdwij+e_augm
1667             endif
1668 C Calculate gradient components.
1669             e1=e1*eps1*eps2rt**2*eps3rt**2
1670             fac=-expon*(e1+evdwij)*rij_shift
1671             sigder=fac*sigder
1672             fac=rij*fac-2*expon*rrij*e_augm
1673 C Calculate the radial part of the gradient
1674             gg(1)=xj*fac
1675             gg(2)=yj*fac
1676             gg(3)=zj*fac
1677 C Calculate angular part of the gradient.
1678             call sc_grad
1679           enddo      ! j
1680         enddo        ! iint
1681       enddo          ! i
1682       end
1683 C-----------------------------------------------------------------------------
1684       subroutine sc_angular
1685 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1686 C om12. Called by ebp, egb, and egbv.
1687       implicit none
1688       include 'COMMON.CALC'
1689       include 'COMMON.IOUNITS'
1690       erij(1)=xj*rij
1691       erij(2)=yj*rij
1692       erij(3)=zj*rij
1693       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1694       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1695       om12=dxi*dxj+dyi*dyj+dzi*dzj
1696       chiom12=chi12*om12
1697 C Calculate eps1(om12) and its derivative in om12
1698       faceps1=1.0D0-om12*chiom12
1699       faceps1_inv=1.0D0/faceps1
1700       eps1=dsqrt(faceps1_inv)
1701 C Following variable is eps1*deps1/dom12
1702       eps1_om12=faceps1_inv*chiom12
1703 c diagnostics only
1704 c      faceps1_inv=om12
1705 c      eps1=om12
1706 c      eps1_om12=1.0d0
1707 c      write (iout,*) "om12",om12," eps1",eps1
1708 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1709 C and om12.
1710       om1om2=om1*om2
1711       chiom1=chi1*om1
1712       chiom2=chi2*om2
1713       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1714       sigsq=1.0D0-facsig*faceps1_inv
1715       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1716       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1717       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1718 c diagnostics only
1719 c      sigsq=1.0d0
1720 c      sigsq_om1=0.0d0
1721 c      sigsq_om2=0.0d0
1722 c      sigsq_om12=0.0d0
1723 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1724 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1725 c     &    " eps1",eps1
1726 C Calculate eps2 and its derivatives in om1, om2, and om12.
1727       chipom1=chip1*om1
1728       chipom2=chip2*om2
1729       chipom12=chip12*om12
1730       facp=1.0D0-om12*chipom12
1731       facp_inv=1.0D0/facp
1732       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1733 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1734 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1735 C Following variable is the square root of eps2
1736       eps2rt=1.0D0-facp1*facp_inv
1737 C Following three variables are the derivatives of the square root of eps
1738 C in om1, om2, and om12.
1739       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1740       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1741       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1742 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1743       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1744 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1745 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1746 c     &  " eps2rt_om12",eps2rt_om12
1747 C Calculate whole angle-dependent part of epsilon and contributions
1748 C to its derivatives
1749       return
1750       end
1751 C----------------------------------------------------------------------------
1752       subroutine sc_grad
1753       implicit real*8 (a-h,o-z)
1754       include 'DIMENSIONS'
1755       include 'COMMON.CHAIN'
1756       include 'COMMON.DERIV'
1757       include 'COMMON.CALC'
1758       include 'COMMON.IOUNITS'
1759       double precision dcosom1(3),dcosom2(3)
1760       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1761       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1762       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1763      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1764 c diagnostics only
1765 c      eom1=0.0d0
1766 c      eom2=0.0d0
1767 c      eom12=evdwij*eps1_om12
1768 c end diagnostics
1769 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1770 c     &  " sigder",sigder
1771 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1772 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1773       do k=1,3
1774         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1775         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1776       enddo
1777       do k=1,3
1778         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1779       enddo
1780 c      write (iout,*) "gg",(gg(k),k=1,3)
1781       do k=1,3
1782         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1783      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1784      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1785         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1786      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1787      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1788 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1789 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1790 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1791 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1792       enddo
1793 C
1794 C Calculate the components of the gradient in DC and X
1795 C
1796 cgrad      do k=i,j-1
1797 cgrad        do l=1,3
1798 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1799 cgrad        enddo
1800 cgrad      enddo
1801       do l=1,3
1802         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1803         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1804       enddo
1805       return
1806       end
1807 C-----------------------------------------------------------------------
1808       subroutine e_softsphere(evdw)
1809 C
1810 C This subroutine calculates the interaction energy of nonbonded side chains
1811 C assuming the LJ potential of interaction.
1812 C
1813       implicit real*8 (a-h,o-z)
1814       include 'DIMENSIONS'
1815       parameter (accur=1.0d-10)
1816       include 'COMMON.GEO'
1817       include 'COMMON.VAR'
1818       include 'COMMON.LOCAL'
1819       include 'COMMON.CHAIN'
1820       include 'COMMON.DERIV'
1821       include 'COMMON.INTERACT'
1822       include 'COMMON.TORSION'
1823       include 'COMMON.SBRIDGE'
1824       include 'COMMON.NAMES'
1825       include 'COMMON.IOUNITS'
1826       include 'COMMON.CONTACTS'
1827       dimension gg(3)
1828 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1829       evdw=0.0D0
1830       do i=iatsc_s,iatsc_e
1831         itypi=iabs(itype(i))
1832         if (itypi.eq.ntyp1) cycle
1833         itypi1=iabs(itype(i+1))
1834         xi=c(1,nres+i)
1835         yi=c(2,nres+i)
1836         zi=c(3,nres+i)
1837 C
1838 C Calculate SC interaction energy.
1839 C
1840         do iint=1,nint_gr(i)
1841 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1842 cd   &                  'iend=',iend(i,iint)
1843           do j=istart(i,iint),iend(i,iint)
1844             itypj=iabs(itype(j))
1845             if (itypj.eq.ntyp1) cycle
1846             xj=c(1,nres+j)-xi
1847             yj=c(2,nres+j)-yi
1848             zj=c(3,nres+j)-zi
1849             rij=xj*xj+yj*yj+zj*zj
1850 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1851             r0ij=r0(itypi,itypj)
1852             r0ijsq=r0ij*r0ij
1853 c            print *,i,j,r0ij,dsqrt(rij)
1854             if (rij.lt.r0ijsq) then
1855               evdwij=0.25d0*(rij-r0ijsq)**2
1856               fac=rij-r0ijsq
1857             else
1858               evdwij=0.0d0
1859               fac=0.0d0
1860             endif
1861             evdw=evdw+evdwij
1862 C
1863 C Calculate the components of the gradient in DC and X
1864 C
1865             gg(1)=xj*fac
1866             gg(2)=yj*fac
1867             gg(3)=zj*fac
1868             do k=1,3
1869               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1870               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1871               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1872               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1873             enddo
1874 cgrad            do k=i,j-1
1875 cgrad              do l=1,3
1876 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1877 cgrad              enddo
1878 cgrad            enddo
1879           enddo ! j
1880         enddo ! iint
1881       enddo ! i
1882       return
1883       end
1884 C--------------------------------------------------------------------------
1885       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1886      &              eello_turn4)
1887 C
1888 C Soft-sphere potential of p-p interaction
1889 C
1890       implicit real*8 (a-h,o-z)
1891       include 'DIMENSIONS'
1892       include 'COMMON.CONTROL'
1893       include 'COMMON.IOUNITS'
1894       include 'COMMON.GEO'
1895       include 'COMMON.VAR'
1896       include 'COMMON.LOCAL'
1897       include 'COMMON.CHAIN'
1898       include 'COMMON.DERIV'
1899       include 'COMMON.INTERACT'
1900       include 'COMMON.CONTACTS'
1901       include 'COMMON.TORSION'
1902       include 'COMMON.VECTORS'
1903       include 'COMMON.FFIELD'
1904       dimension ggg(3)
1905 cd      write(iout,*) 'In EELEC_soft_sphere'
1906       ees=0.0D0
1907       evdw1=0.0D0
1908       eel_loc=0.0d0
1909       eello_turn3=0.0d0
1910       eello_turn4=0.0d0
1911       ind=0
1912       do i=iatel_s,iatel_e
1913         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1914         dxi=dc(1,i)
1915         dyi=dc(2,i)
1916         dzi=dc(3,i)
1917         xmedi=c(1,i)+0.5d0*dxi
1918         ymedi=c(2,i)+0.5d0*dyi
1919         zmedi=c(3,i)+0.5d0*dzi
1920         num_conti=0
1921 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1922         do j=ielstart(i),ielend(i)
1923           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1924           ind=ind+1
1925           iteli=itel(i)
1926           itelj=itel(j)
1927           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1928           r0ij=rpp(iteli,itelj)
1929           r0ijsq=r0ij*r0ij
1930           dxj=dc(1,j)
1931           dyj=dc(2,j)
1932           dzj=dc(3,j)
1933           xj=c(1,j)+0.5D0*dxj-xmedi
1934           yj=c(2,j)+0.5D0*dyj-ymedi
1935           zj=c(3,j)+0.5D0*dzj-zmedi
1936           rij=xj*xj+yj*yj+zj*zj
1937           if (rij.lt.r0ijsq) then
1938             evdw1ij=0.25d0*(rij-r0ijsq)**2
1939             fac=rij-r0ijsq
1940           else
1941             evdw1ij=0.0d0
1942             fac=0.0d0
1943           endif
1944           evdw1=evdw1+evdw1ij
1945 C
1946 C Calculate contributions to the Cartesian gradient.
1947 C
1948           ggg(1)=fac*xj
1949           ggg(2)=fac*yj
1950           ggg(3)=fac*zj
1951           do k=1,3
1952             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1953             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1954           enddo
1955 *
1956 * Loop over residues i+1 thru j-1.
1957 *
1958 cgrad          do k=i+1,j-1
1959 cgrad            do l=1,3
1960 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1961 cgrad            enddo
1962 cgrad          enddo
1963         enddo ! j
1964       enddo   ! i
1965 cgrad      do i=nnt,nct-1
1966 cgrad        do k=1,3
1967 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1968 cgrad        enddo
1969 cgrad        do j=i+1,nct-1
1970 cgrad          do k=1,3
1971 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1972 cgrad          enddo
1973 cgrad        enddo
1974 cgrad      enddo
1975       return
1976       end
1977 c------------------------------------------------------------------------------
1978       subroutine vec_and_deriv
1979       implicit real*8 (a-h,o-z)
1980       include 'DIMENSIONS'
1981 #ifdef MPI
1982       include 'mpif.h'
1983 #endif
1984       include 'COMMON.IOUNITS'
1985       include 'COMMON.GEO'
1986       include 'COMMON.VAR'
1987       include 'COMMON.LOCAL'
1988       include 'COMMON.CHAIN'
1989       include 'COMMON.VECTORS'
1990       include 'COMMON.SETUP'
1991       include 'COMMON.TIME1'
1992       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1993 C Compute the local reference systems. For reference system (i), the
1994 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1995 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1996 #ifdef PARVEC
1997       do i=ivec_start,ivec_end
1998 #else
1999       do i=1,nres-1
2000 #endif
2001           if (i.eq.nres-1) then
2002 C Case of the last full residue
2003 C Compute the Z-axis
2004             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2005             costh=dcos(pi-theta(nres))
2006             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2007             do k=1,3
2008               uz(k,i)=fac*uz(k,i)
2009             enddo
2010 C Compute the derivatives of uz
2011             uzder(1,1,1)= 0.0d0
2012             uzder(2,1,1)=-dc_norm(3,i-1)
2013             uzder(3,1,1)= dc_norm(2,i-1)
2014             uzder(1,2,1)= dc_norm(3,i-1)
2015             uzder(2,2,1)= 0.0d0
2016             uzder(3,2,1)=-dc_norm(1,i-1)
2017             uzder(1,3,1)=-dc_norm(2,i-1)
2018             uzder(2,3,1)= dc_norm(1,i-1)
2019             uzder(3,3,1)= 0.0d0
2020             uzder(1,1,2)= 0.0d0
2021             uzder(2,1,2)= dc_norm(3,i)
2022             uzder(3,1,2)=-dc_norm(2,i)
2023             uzder(1,2,2)=-dc_norm(3,i)
2024             uzder(2,2,2)= 0.0d0
2025             uzder(3,2,2)= dc_norm(1,i)
2026             uzder(1,3,2)= dc_norm(2,i)
2027             uzder(2,3,2)=-dc_norm(1,i)
2028             uzder(3,3,2)= 0.0d0
2029 C Compute the Y-axis
2030             facy=fac
2031             do k=1,3
2032               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2033             enddo
2034 C Compute the derivatives of uy
2035             do j=1,3
2036               do k=1,3
2037                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2038      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2039                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2040               enddo
2041               uyder(j,j,1)=uyder(j,j,1)-costh
2042               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2043             enddo
2044             do j=1,2
2045               do k=1,3
2046                 do l=1,3
2047                   uygrad(l,k,j,i)=uyder(l,k,j)
2048                   uzgrad(l,k,j,i)=uzder(l,k,j)
2049                 enddo
2050               enddo
2051             enddo
2052             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2053             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2054             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2055             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2056           else
2057 C Other residues
2058 C Compute the Z-axis
2059             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2060             costh=dcos(pi-theta(i+2))
2061             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2062             do k=1,3
2063               uz(k,i)=fac*uz(k,i)
2064             enddo
2065 C Compute the derivatives of uz
2066             uzder(1,1,1)= 0.0d0
2067             uzder(2,1,1)=-dc_norm(3,i+1)
2068             uzder(3,1,1)= dc_norm(2,i+1)
2069             uzder(1,2,1)= dc_norm(3,i+1)
2070             uzder(2,2,1)= 0.0d0
2071             uzder(3,2,1)=-dc_norm(1,i+1)
2072             uzder(1,3,1)=-dc_norm(2,i+1)
2073             uzder(2,3,1)= dc_norm(1,i+1)
2074             uzder(3,3,1)= 0.0d0
2075             uzder(1,1,2)= 0.0d0
2076             uzder(2,1,2)= dc_norm(3,i)
2077             uzder(3,1,2)=-dc_norm(2,i)
2078             uzder(1,2,2)=-dc_norm(3,i)
2079             uzder(2,2,2)= 0.0d0
2080             uzder(3,2,2)= dc_norm(1,i)
2081             uzder(1,3,2)= dc_norm(2,i)
2082             uzder(2,3,2)=-dc_norm(1,i)
2083             uzder(3,3,2)= 0.0d0
2084 C Compute the Y-axis
2085             facy=fac
2086             do k=1,3
2087               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2088             enddo
2089 C Compute the derivatives of uy
2090             do j=1,3
2091               do k=1,3
2092                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2093      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2094                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2095               enddo
2096               uyder(j,j,1)=uyder(j,j,1)-costh
2097               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2098             enddo
2099             do j=1,2
2100               do k=1,3
2101                 do l=1,3
2102                   uygrad(l,k,j,i)=uyder(l,k,j)
2103                   uzgrad(l,k,j,i)=uzder(l,k,j)
2104                 enddo
2105               enddo
2106             enddo
2107             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2108             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2109             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2110             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2111           endif
2112       enddo
2113       do i=1,nres-1
2114         vbld_inv_temp(1)=vbld_inv(i+1)
2115         if (i.lt.nres-1) then
2116           vbld_inv_temp(2)=vbld_inv(i+2)
2117           else
2118           vbld_inv_temp(2)=vbld_inv(i)
2119           endif
2120         do j=1,2
2121           do k=1,3
2122             do l=1,3
2123               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2124               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2125             enddo
2126           enddo
2127         enddo
2128       enddo
2129 #if defined(PARVEC) && defined(MPI)
2130       if (nfgtasks1.gt.1) then
2131         time00=MPI_Wtime()
2132 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2133 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2134 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2135         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2136      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2137      &   FG_COMM1,IERR)
2138         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2139      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2140      &   FG_COMM1,IERR)
2141         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2142      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2143      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2144         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2145      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2146      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2147         time_gather=time_gather+MPI_Wtime()-time00
2148       endif
2149 c      if (fg_rank.eq.0) then
2150 c        write (iout,*) "Arrays UY and UZ"
2151 c        do i=1,nres-1
2152 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2153 c     &     (uz(k,i),k=1,3)
2154 c        enddo
2155 c      endif
2156 #endif
2157       return
2158       end
2159 C-----------------------------------------------------------------------------
2160       subroutine check_vecgrad
2161       implicit real*8 (a-h,o-z)
2162       include 'DIMENSIONS'
2163       include 'COMMON.IOUNITS'
2164       include 'COMMON.GEO'
2165       include 'COMMON.VAR'
2166       include 'COMMON.LOCAL'
2167       include 'COMMON.CHAIN'
2168       include 'COMMON.VECTORS'
2169       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2170       dimension uyt(3,maxres),uzt(3,maxres)
2171       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2172       double precision delta /1.0d-7/
2173       call vec_and_deriv
2174 cd      do i=1,nres
2175 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2176 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2177 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2178 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2179 cd     &     (dc_norm(if90,i),if90=1,3)
2180 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2181 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2182 cd          write(iout,'(a)')
2183 cd      enddo
2184       do i=1,nres
2185         do j=1,2
2186           do k=1,3
2187             do l=1,3
2188               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2189               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2190             enddo
2191           enddo
2192         enddo
2193       enddo
2194       call vec_and_deriv
2195       do i=1,nres
2196         do j=1,3
2197           uyt(j,i)=uy(j,i)
2198           uzt(j,i)=uz(j,i)
2199         enddo
2200       enddo
2201       do i=1,nres
2202 cd        write (iout,*) 'i=',i
2203         do k=1,3
2204           erij(k)=dc_norm(k,i)
2205         enddo
2206         do j=1,3
2207           do k=1,3
2208             dc_norm(k,i)=erij(k)
2209           enddo
2210           dc_norm(j,i)=dc_norm(j,i)+delta
2211 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2212 c          do k=1,3
2213 c            dc_norm(k,i)=dc_norm(k,i)/fac
2214 c          enddo
2215 c          write (iout,*) (dc_norm(k,i),k=1,3)
2216 c          write (iout,*) (erij(k),k=1,3)
2217           call vec_and_deriv
2218           do k=1,3
2219             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2220             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2221             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2222             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2223           enddo
2224 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2225 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2226 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2227         enddo
2228         do k=1,3
2229           dc_norm(k,i)=erij(k)
2230         enddo
2231 cd        do k=1,3
2232 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2233 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2234 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2235 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2236 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2237 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2238 cd          write (iout,'(a)')
2239 cd        enddo
2240       enddo
2241       return
2242       end
2243 C--------------------------------------------------------------------------
2244       subroutine set_matrices
2245       implicit real*8 (a-h,o-z)
2246       include 'DIMENSIONS'
2247 #ifdef MPI
2248       include "mpif.h"
2249       include "COMMON.SETUP"
2250       integer IERR
2251       integer status(MPI_STATUS_SIZE)
2252 #endif
2253       include 'COMMON.IOUNITS'
2254       include 'COMMON.GEO'
2255       include 'COMMON.VAR'
2256       include 'COMMON.LOCAL'
2257       include 'COMMON.CHAIN'
2258       include 'COMMON.DERIV'
2259       include 'COMMON.INTERACT'
2260       include 'COMMON.CONTACTS'
2261       include 'COMMON.TORSION'
2262       include 'COMMON.VECTORS'
2263       include 'COMMON.FFIELD'
2264       double precision auxvec(2),auxmat(2,2)
2265 C
2266 C Compute the virtual-bond-torsional-angle dependent quantities needed
2267 C to calculate the el-loc multibody terms of various order.
2268 C
2269 #ifdef PARMAT
2270       do i=ivec_start+2,ivec_end+2
2271 #else
2272       do i=3,nres+1
2273 #endif
2274         if (i .lt. nres+1) then
2275           sin1=dsin(phi(i))
2276           cos1=dcos(phi(i))
2277           sintab(i-2)=sin1
2278           costab(i-2)=cos1
2279           obrot(1,i-2)=cos1
2280           obrot(2,i-2)=sin1
2281           sin2=dsin(2*phi(i))
2282           cos2=dcos(2*phi(i))
2283           sintab2(i-2)=sin2
2284           costab2(i-2)=cos2
2285           obrot2(1,i-2)=cos2
2286           obrot2(2,i-2)=sin2
2287           Ug(1,1,i-2)=-cos1
2288           Ug(1,2,i-2)=-sin1
2289           Ug(2,1,i-2)=-sin1
2290           Ug(2,2,i-2)= cos1
2291           Ug2(1,1,i-2)=-cos2
2292           Ug2(1,2,i-2)=-sin2
2293           Ug2(2,1,i-2)=-sin2
2294           Ug2(2,2,i-2)= cos2
2295         else
2296           costab(i-2)=1.0d0
2297           sintab(i-2)=0.0d0
2298           obrot(1,i-2)=1.0d0
2299           obrot(2,i-2)=0.0d0
2300           obrot2(1,i-2)=0.0d0
2301           obrot2(2,i-2)=0.0d0
2302           Ug(1,1,i-2)=1.0d0
2303           Ug(1,2,i-2)=0.0d0
2304           Ug(2,1,i-2)=0.0d0
2305           Ug(2,2,i-2)=1.0d0
2306           Ug2(1,1,i-2)=0.0d0
2307           Ug2(1,2,i-2)=0.0d0
2308           Ug2(2,1,i-2)=0.0d0
2309           Ug2(2,2,i-2)=0.0d0
2310         endif
2311         if (i .gt. 3 .and. i .lt. nres+1) then
2312           obrot_der(1,i-2)=-sin1
2313           obrot_der(2,i-2)= cos1
2314           Ugder(1,1,i-2)= sin1
2315           Ugder(1,2,i-2)=-cos1
2316           Ugder(2,1,i-2)=-cos1
2317           Ugder(2,2,i-2)=-sin1
2318           dwacos2=cos2+cos2
2319           dwasin2=sin2+sin2
2320           obrot2_der(1,i-2)=-dwasin2
2321           obrot2_der(2,i-2)= dwacos2
2322           Ug2der(1,1,i-2)= dwasin2
2323           Ug2der(1,2,i-2)=-dwacos2
2324           Ug2der(2,1,i-2)=-dwacos2
2325           Ug2der(2,2,i-2)=-dwasin2
2326         else
2327           obrot_der(1,i-2)=0.0d0
2328           obrot_der(2,i-2)=0.0d0
2329           Ugder(1,1,i-2)=0.0d0
2330           Ugder(1,2,i-2)=0.0d0
2331           Ugder(2,1,i-2)=0.0d0
2332           Ugder(2,2,i-2)=0.0d0
2333           obrot2_der(1,i-2)=0.0d0
2334           obrot2_der(2,i-2)=0.0d0
2335           Ug2der(1,1,i-2)=0.0d0
2336           Ug2der(1,2,i-2)=0.0d0
2337           Ug2der(2,1,i-2)=0.0d0
2338           Ug2der(2,2,i-2)=0.0d0
2339         endif
2340 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2341         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2342           iti = itortyp(itype(i-2))
2343         else
2344           iti=ntortyp+1
2345         endif
2346 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2347         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2348           iti1 = itortyp(itype(i-1))
2349         else
2350           iti1=ntortyp+1
2351         endif
2352 cd        write (iout,*) '*******i',i,' iti1',iti
2353 cd        write (iout,*) 'b1',b1(:,iti)
2354 cd        write (iout,*) 'b2',b2(:,iti)
2355 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2356 c        if (i .gt. iatel_s+2) then
2357         if (i .gt. nnt+2) then
2358           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2359           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2360           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2361      &    then
2362           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2363           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2364           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2365           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2366           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2367           endif
2368         else
2369           do k=1,2
2370             Ub2(k,i-2)=0.0d0
2371             Ctobr(k,i-2)=0.0d0
2372             Dtobr2(k,i-2)=0.0d0
2373             do l=1,2
2374               EUg(l,k,i-2)=0.0d0
2375               CUg(l,k,i-2)=0.0d0
2376               DUg(l,k,i-2)=0.0d0
2377               DtUg2(l,k,i-2)=0.0d0
2378             enddo
2379           enddo
2380         endif
2381         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2382         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2383         do k=1,2
2384           muder(k,i-2)=Ub2der(k,i-2)
2385         enddo
2386 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2387         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2388           if (itype(i-1).le.ntyp) then
2389             iti1 = itortyp(itype(i-1))
2390           else
2391             iti1=ntortyp+1
2392           endif
2393         else
2394           iti1=ntortyp+1
2395         endif
2396         do k=1,2
2397           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2398         enddo
2399 cd        write (iout,*) 'mu ',mu(:,i-2)
2400 cd        write (iout,*) 'mu1',mu1(:,i-2)
2401 cd        write (iout,*) 'mu2',mu2(:,i-2)
2402         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2403      &  then
2404         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2405         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2406         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2407         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2408         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2409 C Vectors and matrices dependent on a single virtual-bond dihedral.
2410         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2411         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2412         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2413         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2414         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2415         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2416         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2417         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2418         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2419         endif
2420       enddo
2421 C Matrices dependent on two consecutive virtual-bond dihedrals.
2422 C The order of matrices is from left to right.
2423       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2424      &then
2425 c      do i=max0(ivec_start,2),ivec_end
2426       do i=2,nres-1
2427         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2428         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2429         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2430         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2431         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2432         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2433         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2434         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2435       enddo
2436       endif
2437 #if defined(MPI) && defined(PARMAT)
2438 #ifdef DEBUG
2439 c      if (fg_rank.eq.0) then
2440         write (iout,*) "Arrays UG and UGDER before GATHER"
2441         do i=1,nres-1
2442           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2443      &     ((ug(l,k,i),l=1,2),k=1,2),
2444      &     ((ugder(l,k,i),l=1,2),k=1,2)
2445         enddo
2446         write (iout,*) "Arrays UG2 and UG2DER"
2447         do i=1,nres-1
2448           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2449      &     ((ug2(l,k,i),l=1,2),k=1,2),
2450      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2451         enddo
2452         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2453         do i=1,nres-1
2454           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2455      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2456      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2457         enddo
2458         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2459         do i=1,nres-1
2460           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2461      &     costab(i),sintab(i),costab2(i),sintab2(i)
2462         enddo
2463         write (iout,*) "Array MUDER"
2464         do i=1,nres-1
2465           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2466         enddo
2467 c      endif
2468 #endif
2469       if (nfgtasks.gt.1) then
2470         time00=MPI_Wtime()
2471 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2472 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2473 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2474 #ifdef MATGATHER
2475         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2476      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2477      &   FG_COMM1,IERR)
2478         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2479      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2480      &   FG_COMM1,IERR)
2481         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2482      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2483      &   FG_COMM1,IERR)
2484         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2485      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2486      &   FG_COMM1,IERR)
2487         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2488      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2489      &   FG_COMM1,IERR)
2490         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2491      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2492      &   FG_COMM1,IERR)
2493         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2494      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2495      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2496         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2497      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2498      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2499         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2500      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2501      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2502         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2503      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2504      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2505         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2506      &  then
2507         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2508      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2509      &   FG_COMM1,IERR)
2510         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2514      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2515      &   FG_COMM1,IERR)
2516        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2517      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2523      &   ivec_count(fg_rank1),
2524      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2525      &   FG_COMM1,IERR)
2526         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2527      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2528      &   FG_COMM1,IERR)
2529         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2530      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2531      &   FG_COMM1,IERR)
2532         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2533      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2534      &   FG_COMM1,IERR)
2535         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2536      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2537      &   FG_COMM1,IERR)
2538         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2539      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2540      &   FG_COMM1,IERR)
2541         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2542      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2543      &   FG_COMM1,IERR)
2544         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2545      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2548      &   ivec_count(fg_rank1),
2549      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2550      &   FG_COMM1,IERR)
2551         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2552      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2553      &   FG_COMM1,IERR)
2554        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2555      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2556      &   FG_COMM1,IERR)
2557         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2558      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2559      &   FG_COMM1,IERR)
2560        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2561      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2562      &   FG_COMM1,IERR)
2563         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2564      &   ivec_count(fg_rank1),
2565      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2568      &   ivec_count(fg_rank1),
2569      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2570      &   FG_COMM1,IERR)
2571         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2572      &   ivec_count(fg_rank1),
2573      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2574      &   MPI_MAT2,FG_COMM1,IERR)
2575         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2576      &   ivec_count(fg_rank1),
2577      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2578      &   MPI_MAT2,FG_COMM1,IERR)
2579         endif
2580 #else
2581 c Passes matrix info through the ring
2582       isend=fg_rank1
2583       irecv=fg_rank1-1
2584       if (irecv.lt.0) irecv=nfgtasks1-1
2585       iprev=irecv
2586       inext=fg_rank1+1
2587       if (inext.ge.nfgtasks1) inext=0
2588       do i=1,nfgtasks1-1
2589 c        write (iout,*) "isend",isend," irecv",irecv
2590 c        call flush(iout)
2591         lensend=lentyp(isend)
2592         lenrecv=lentyp(irecv)
2593 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2594 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2595 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2596 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2597 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2598 c        write (iout,*) "Gather ROTAT1"
2599 c        call flush(iout)
2600 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2601 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2602 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2603 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2604 c        write (iout,*) "Gather ROTAT2"
2605 c        call flush(iout)
2606         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2607      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2608      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2609      &   iprev,4400+irecv,FG_COMM,status,IERR)
2610 c        write (iout,*) "Gather ROTAT_OLD"
2611 c        call flush(iout)
2612         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2613      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2614      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2615      &   iprev,5500+irecv,FG_COMM,status,IERR)
2616 c        write (iout,*) "Gather PRECOMP11"
2617 c        call flush(iout)
2618         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2619      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2620      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2621      &   iprev,6600+irecv,FG_COMM,status,IERR)
2622 c        write (iout,*) "Gather PRECOMP12"
2623 c        call flush(iout)
2624         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2625      &  then
2626         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2627      &   MPI_ROTAT2(lensend),inext,7700+isend,
2628      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2629      &   iprev,7700+irecv,FG_COMM,status,IERR)
2630 c        write (iout,*) "Gather PRECOMP21"
2631 c        call flush(iout)
2632         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2633      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2634      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2635      &   iprev,8800+irecv,FG_COMM,status,IERR)
2636 c        write (iout,*) "Gather PRECOMP22"
2637 c        call flush(iout)
2638         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2639      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2640      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2641      &   MPI_PRECOMP23(lenrecv),
2642      &   iprev,9900+irecv,FG_COMM,status,IERR)
2643 c        write (iout,*) "Gather PRECOMP23"
2644 c        call flush(iout)
2645         endif
2646         isend=irecv
2647         irecv=irecv-1
2648         if (irecv.lt.0) irecv=nfgtasks1-1
2649       enddo
2650 #endif
2651         time_gather=time_gather+MPI_Wtime()-time00
2652       endif
2653 #ifdef DEBUG
2654 c      if (fg_rank.eq.0) then
2655         write (iout,*) "Arrays UG and UGDER"
2656         do i=1,nres-1
2657           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2658      &     ((ug(l,k,i),l=1,2),k=1,2),
2659      &     ((ugder(l,k,i),l=1,2),k=1,2)
2660         enddo
2661         write (iout,*) "Arrays UG2 and UG2DER"
2662         do i=1,nres-1
2663           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2664      &     ((ug2(l,k,i),l=1,2),k=1,2),
2665      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2666         enddo
2667         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2668         do i=1,nres-1
2669           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2670      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2671      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2672         enddo
2673         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2674         do i=1,nres-1
2675           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2676      &     costab(i),sintab(i),costab2(i),sintab2(i)
2677         enddo
2678         write (iout,*) "Array MUDER"
2679         do i=1,nres-1
2680           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2681         enddo
2682 c      endif
2683 #endif
2684 #endif
2685 cd      do i=1,nres
2686 cd        iti = itortyp(itype(i))
2687 cd        write (iout,*) i
2688 cd        do j=1,2
2689 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2690 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2691 cd        enddo
2692 cd      enddo
2693       return
2694       end
2695 C--------------------------------------------------------------------------
2696       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2697 C
2698 C This subroutine calculates the average interaction energy and its gradient
2699 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2700 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2701 C The potential depends both on the distance of peptide-group centers and on
2702 C the orientation of the CA-CA virtual bonds.
2703 C
2704       implicit real*8 (a-h,o-z)
2705 #ifdef MPI
2706       include 'mpif.h'
2707 #endif
2708       include 'DIMENSIONS'
2709       include 'COMMON.CONTROL'
2710       include 'COMMON.SETUP'
2711       include 'COMMON.IOUNITS'
2712       include 'COMMON.GEO'
2713       include 'COMMON.VAR'
2714       include 'COMMON.LOCAL'
2715       include 'COMMON.CHAIN'
2716       include 'COMMON.DERIV'
2717       include 'COMMON.INTERACT'
2718       include 'COMMON.CONTACTS'
2719       include 'COMMON.TORSION'
2720       include 'COMMON.VECTORS'
2721       include 'COMMON.FFIELD'
2722       include 'COMMON.TIME1'
2723       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2724      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2725       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2726      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2727       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2728      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2729      &    num_conti,j1,j2
2730 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2731 #ifdef MOMENT
2732       double precision scal_el /1.0d0/
2733 #else
2734       double precision scal_el /0.5d0/
2735 #endif
2736 C 12/13/98
2737 C 13-go grudnia roku pamietnego...
2738       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2739      &                   0.0d0,1.0d0,0.0d0,
2740      &                   0.0d0,0.0d0,1.0d0/
2741 cd      write(iout,*) 'In EELEC'
2742 cd      do i=1,nloctyp
2743 cd        write(iout,*) 'Type',i
2744 cd        write(iout,*) 'B1',B1(:,i)
2745 cd        write(iout,*) 'B2',B2(:,i)
2746 cd        write(iout,*) 'CC',CC(:,:,i)
2747 cd        write(iout,*) 'DD',DD(:,:,i)
2748 cd        write(iout,*) 'EE',EE(:,:,i)
2749 cd      enddo
2750 cd      call check_vecgrad
2751 cd      stop
2752       if (icheckgrad.eq.1) then
2753         do i=1,nres-1
2754           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2755           do k=1,3
2756             dc_norm(k,i)=dc(k,i)*fac
2757           enddo
2758 c          write (iout,*) 'i',i,' fac',fac
2759         enddo
2760       endif
2761       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2762      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2763      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2764 c        call vec_and_deriv
2765 #ifdef TIMING
2766         time01=MPI_Wtime()
2767 #endif
2768         call set_matrices
2769 #ifdef TIMING
2770         time_mat=time_mat+MPI_Wtime()-time01
2771 #endif
2772       endif
2773 cd      do i=1,nres-1
2774 cd        write (iout,*) 'i=',i
2775 cd        do k=1,3
2776 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2777 cd        enddo
2778 cd        do k=1,3
2779 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2780 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2781 cd        enddo
2782 cd      enddo
2783       t_eelecij=0.0d0
2784       ees=0.0D0
2785       evdw1=0.0D0
2786       eel_loc=0.0d0
2787       eello_turn3=0.0d0
2788       eello_turn4=0.0d0
2789       ind=0
2790       do i=1,nres
2791         num_cont_hb(i)=0
2792       enddo
2793 cd      print '(a)','Enter EELEC'
2794 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2795       do i=1,nres
2796         gel_loc_loc(i)=0.0d0
2797         gcorr_loc(i)=0.0d0
2798       enddo
2799 c
2800 c
2801 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2802 C
2803 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2804 C
2805       do i=iturn3_start,iturn3_end
2806         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2807      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2808         dxi=dc(1,i)
2809         dyi=dc(2,i)
2810         dzi=dc(3,i)
2811         dx_normi=dc_norm(1,i)
2812         dy_normi=dc_norm(2,i)
2813         dz_normi=dc_norm(3,i)
2814         xmedi=c(1,i)+0.5d0*dxi
2815         ymedi=c(2,i)+0.5d0*dyi
2816         zmedi=c(3,i)+0.5d0*dzi
2817         num_conti=0
2818         call eelecij(i,i+2,ees,evdw1,eel_loc)
2819         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2820         num_cont_hb(i)=num_conti
2821       enddo
2822       do i=iturn4_start,iturn4_end
2823         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2824      &    .or. itype(i+3).eq.ntyp1
2825      &    .or. itype(i+4).eq.ntyp1) cycle
2826         dxi=dc(1,i)
2827         dyi=dc(2,i)
2828         dzi=dc(3,i)
2829         dx_normi=dc_norm(1,i)
2830         dy_normi=dc_norm(2,i)
2831         dz_normi=dc_norm(3,i)
2832         xmedi=c(1,i)+0.5d0*dxi
2833         ymedi=c(2,i)+0.5d0*dyi
2834         zmedi=c(3,i)+0.5d0*dzi
2835         num_conti=num_cont_hb(i)
2836         call eelecij(i,i+3,ees,evdw1,eel_loc)
2837         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2838      &   call eturn4(i,eello_turn4)
2839         num_cont_hb(i)=num_conti
2840       enddo   ! i
2841 c
2842 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2843 c
2844       do i=iatel_s,iatel_e
2845         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2846         dxi=dc(1,i)
2847         dyi=dc(2,i)
2848         dzi=dc(3,i)
2849         dx_normi=dc_norm(1,i)
2850         dy_normi=dc_norm(2,i)
2851         dz_normi=dc_norm(3,i)
2852         xmedi=c(1,i)+0.5d0*dxi
2853         ymedi=c(2,i)+0.5d0*dyi
2854         zmedi=c(3,i)+0.5d0*dzi
2855 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2856         num_conti=num_cont_hb(i)
2857         do j=ielstart(i),ielend(i)
2858 c          write (iout,*) i,j,itype(i),itype(j)
2859           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2860           call eelecij(i,j,ees,evdw1,eel_loc)
2861         enddo ! j
2862         num_cont_hb(i)=num_conti
2863       enddo   ! i
2864 c      write (iout,*) "Number of loop steps in EELEC:",ind
2865 cd      do i=1,nres
2866 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2867 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2868 cd      enddo
2869 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2870 ccc      eel_loc=eel_loc+eello_turn3
2871 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2872       return
2873       end
2874 C-------------------------------------------------------------------------------
2875       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2876       implicit real*8 (a-h,o-z)
2877       include 'DIMENSIONS'
2878 #ifdef MPI
2879       include "mpif.h"
2880 #endif
2881       include 'COMMON.CONTROL'
2882       include 'COMMON.IOUNITS'
2883       include 'COMMON.GEO'
2884       include 'COMMON.VAR'
2885       include 'COMMON.LOCAL'
2886       include 'COMMON.CHAIN'
2887       include 'COMMON.DERIV'
2888       include 'COMMON.INTERACT'
2889       include 'COMMON.CONTACTS'
2890       include 'COMMON.TORSION'
2891       include 'COMMON.VECTORS'
2892       include 'COMMON.FFIELD'
2893       include 'COMMON.TIME1'
2894       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2895      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2896       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2897      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2898       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2899      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2900      &    num_conti,j1,j2
2901 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2902 #ifdef MOMENT
2903       double precision scal_el /1.0d0/
2904 #else
2905       double precision scal_el /0.5d0/
2906 #endif
2907 C 12/13/98
2908 C 13-go grudnia roku pamietnego...
2909       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2910      &                   0.0d0,1.0d0,0.0d0,
2911      &                   0.0d0,0.0d0,1.0d0/
2912 c          time00=MPI_Wtime()
2913 cd      write (iout,*) "eelecij",i,j
2914 c          ind=ind+1
2915           iteli=itel(i)
2916           itelj=itel(j)
2917           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2918           aaa=app(iteli,itelj)
2919           bbb=bpp(iteli,itelj)
2920           ael6i=ael6(iteli,itelj)
2921           ael3i=ael3(iteli,itelj)
2922           dxj=dc(1,j)
2923           dyj=dc(2,j)
2924           dzj=dc(3,j)
2925           dx_normj=dc_norm(1,j)
2926           dy_normj=dc_norm(2,j)
2927           dz_normj=dc_norm(3,j)
2928           xj=c(1,j)+0.5D0*dxj-xmedi
2929           yj=c(2,j)+0.5D0*dyj-ymedi
2930           zj=c(3,j)+0.5D0*dzj-zmedi
2931           rij=xj*xj+yj*yj+zj*zj
2932           rrmij=1.0D0/rij
2933           rij=dsqrt(rij)
2934           rmij=1.0D0/rij
2935           r3ij=rrmij*rmij
2936           r6ij=r3ij*r3ij
2937           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2938           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2939           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2940           fac=cosa-3.0D0*cosb*cosg
2941           ev1=aaa*r6ij*r6ij
2942 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2943           if (j.eq.i+2) ev1=scal_el*ev1
2944           ev2=bbb*r6ij
2945           fac3=ael6i*r6ij
2946           fac4=ael3i*r3ij
2947           evdwij=ev1+ev2
2948           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2949           el2=fac4*fac
2950           eesij=el1+el2
2951 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2952           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2953           ees=ees+eesij
2954           evdw1=evdw1+evdwij
2955 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2956 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2957 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2958 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2959
2960           if (energy_dec) then
2961               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2962      &'evdw1',i,j,evdwij
2963      &,iteli,itelj,aaa,evdw1
2964               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2965           endif
2966
2967 C
2968 C Calculate contributions to the Cartesian gradient.
2969 C
2970 #ifdef SPLITELE
2971           facvdw=-6*rrmij*(ev1+evdwij)
2972           facel=-3*rrmij*(el1+eesij)
2973           fac1=fac
2974           erij(1)=xj*rmij
2975           erij(2)=yj*rmij
2976           erij(3)=zj*rmij
2977 *
2978 * Radial derivatives. First process both termini of the fragment (i,j)
2979 *
2980           ggg(1)=facel*xj
2981           ggg(2)=facel*yj
2982           ggg(3)=facel*zj
2983 c          do k=1,3
2984 c            ghalf=0.5D0*ggg(k)
2985 c            gelc(k,i)=gelc(k,i)+ghalf
2986 c            gelc(k,j)=gelc(k,j)+ghalf
2987 c          enddo
2988 c 9/28/08 AL Gradient compotents will be summed only at the end
2989           do k=1,3
2990             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2991             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2992           enddo
2993 *
2994 * Loop over residues i+1 thru j-1.
2995 *
2996 cgrad          do k=i+1,j-1
2997 cgrad            do l=1,3
2998 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2999 cgrad            enddo
3000 cgrad          enddo
3001           ggg(1)=facvdw*xj
3002           ggg(2)=facvdw*yj
3003           ggg(3)=facvdw*zj
3004 c          do k=1,3
3005 c            ghalf=0.5D0*ggg(k)
3006 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3007 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3008 c          enddo
3009 c 9/28/08 AL Gradient compotents will be summed only at the end
3010           do k=1,3
3011             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3012             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3013           enddo
3014 *
3015 * Loop over residues i+1 thru j-1.
3016 *
3017 cgrad          do k=i+1,j-1
3018 cgrad            do l=1,3
3019 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3020 cgrad            enddo
3021 cgrad          enddo
3022 #else
3023           facvdw=ev1+evdwij
3024           facel=el1+eesij
3025           fac1=fac
3026           fac=-3*rrmij*(facvdw+facvdw+facel)
3027           erij(1)=xj*rmij
3028           erij(2)=yj*rmij
3029           erij(3)=zj*rmij
3030 *
3031 * Radial derivatives. First process both termini of the fragment (i,j)
3032 *
3033           ggg(1)=fac*xj
3034           ggg(2)=fac*yj
3035           ggg(3)=fac*zj
3036 c          do k=1,3
3037 c            ghalf=0.5D0*ggg(k)
3038 c            gelc(k,i)=gelc(k,i)+ghalf
3039 c            gelc(k,j)=gelc(k,j)+ghalf
3040 c          enddo
3041 c 9/28/08 AL Gradient compotents will be summed only at the end
3042           do k=1,3
3043             gelc_long(k,j)=gelc(k,j)+ggg(k)
3044             gelc_long(k,i)=gelc(k,i)-ggg(k)
3045           enddo
3046 *
3047 * Loop over residues i+1 thru j-1.
3048 *
3049 cgrad          do k=i+1,j-1
3050 cgrad            do l=1,3
3051 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3052 cgrad            enddo
3053 cgrad          enddo
3054 c 9/28/08 AL Gradient compotents will be summed only at the end
3055           ggg(1)=facvdw*xj
3056           ggg(2)=facvdw*yj
3057           ggg(3)=facvdw*zj
3058           do k=1,3
3059             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3060             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3061           enddo
3062 #endif
3063 *
3064 * Angular part
3065 *
3066           ecosa=2.0D0*fac3*fac1+fac4
3067           fac4=-3.0D0*fac4
3068           fac3=-6.0D0*fac3
3069           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3070           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3071           do k=1,3
3072             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3073             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3074           enddo
3075 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3076 cd   &          (dcosg(k),k=1,3)
3077           do k=1,3
3078             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3079           enddo
3080 c          do k=1,3
3081 c            ghalf=0.5D0*ggg(k)
3082 c            gelc(k,i)=gelc(k,i)+ghalf
3083 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3084 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3085 c            gelc(k,j)=gelc(k,j)+ghalf
3086 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3087 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3088 c          enddo
3089 cgrad          do k=i+1,j-1
3090 cgrad            do l=1,3
3091 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3092 cgrad            enddo
3093 cgrad          enddo
3094           do k=1,3
3095             gelc(k,i)=gelc(k,i)
3096      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3097      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3098             gelc(k,j)=gelc(k,j)
3099      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3100      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3101             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3102             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3103           enddo
3104           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3105      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3106      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3107 C
3108 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3109 C   energy of a peptide unit is assumed in the form of a second-order
3110 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3111 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3112 C   are computed for EVERY pair of non-contiguous peptide groups.
3113 C
3114           if (j.lt.nres-1) then
3115             j1=j+1
3116             j2=j-1
3117           else
3118             j1=j-1
3119             j2=j-2
3120           endif
3121           kkk=0
3122           do k=1,2
3123             do l=1,2
3124               kkk=kkk+1
3125               muij(kkk)=mu(k,i)*mu(l,j)
3126             enddo
3127           enddo
3128 cd         write (iout,*) 'EELEC: i',i,' j',j
3129 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3130 cd          write(iout,*) 'muij',muij
3131           ury=scalar(uy(1,i),erij)
3132           urz=scalar(uz(1,i),erij)
3133           vry=scalar(uy(1,j),erij)
3134           vrz=scalar(uz(1,j),erij)
3135           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3136           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3137           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3138           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3139           fac=dsqrt(-ael6i)*r3ij
3140           a22=a22*fac
3141           a23=a23*fac
3142           a32=a32*fac
3143           a33=a33*fac
3144 cd          write (iout,'(4i5,4f10.5)')
3145 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3146 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3147 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3148 cd     &      uy(:,j),uz(:,j)
3149 cd          write (iout,'(4f10.5)')
3150 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3151 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3152 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3153 cd           write (iout,'(9f10.5/)')
3154 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3155 C Derivatives of the elements of A in virtual-bond vectors
3156           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3157           do k=1,3
3158             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3159             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3160             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3161             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3162             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3163             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3164             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3165             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3166             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3167             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3168             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3169             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3170           enddo
3171 C Compute radial contributions to the gradient
3172           facr=-3.0d0*rrmij
3173           a22der=a22*facr
3174           a23der=a23*facr
3175           a32der=a32*facr
3176           a33der=a33*facr
3177           agg(1,1)=a22der*xj
3178           agg(2,1)=a22der*yj
3179           agg(3,1)=a22der*zj
3180           agg(1,2)=a23der*xj
3181           agg(2,2)=a23der*yj
3182           agg(3,2)=a23der*zj
3183           agg(1,3)=a32der*xj
3184           agg(2,3)=a32der*yj
3185           agg(3,3)=a32der*zj
3186           agg(1,4)=a33der*xj
3187           agg(2,4)=a33der*yj
3188           agg(3,4)=a33der*zj
3189 C Add the contributions coming from er
3190           fac3=-3.0d0*fac
3191           do k=1,3
3192             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3193             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3194             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3195             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3196           enddo
3197           do k=1,3
3198 C Derivatives in DC(i)
3199 cgrad            ghalf1=0.5d0*agg(k,1)
3200 cgrad            ghalf2=0.5d0*agg(k,2)
3201 cgrad            ghalf3=0.5d0*agg(k,3)
3202 cgrad            ghalf4=0.5d0*agg(k,4)
3203             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3204      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3205             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3206      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3207             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3208      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3209             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3210      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3211 C Derivatives in DC(i+1)
3212             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3213      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3214             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3215      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3216             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3217      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3218             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3219      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3220 C Derivatives in DC(j)
3221             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3222      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3223             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3224      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3225             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3226      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3227             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3228      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3229 C Derivatives in DC(j+1) or DC(nres-1)
3230             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3231      &      -3.0d0*vryg(k,3)*ury)
3232             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3233      &      -3.0d0*vrzg(k,3)*ury)
3234             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3235      &      -3.0d0*vryg(k,3)*urz)
3236             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3237      &      -3.0d0*vrzg(k,3)*urz)
3238 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3239 cgrad              do l=1,4
3240 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3241 cgrad              enddo
3242 cgrad            endif
3243           enddo
3244           acipa(1,1)=a22
3245           acipa(1,2)=a23
3246           acipa(2,1)=a32
3247           acipa(2,2)=a33
3248           a22=-a22
3249           a23=-a23
3250           do l=1,2
3251             do k=1,3
3252               agg(k,l)=-agg(k,l)
3253               aggi(k,l)=-aggi(k,l)
3254               aggi1(k,l)=-aggi1(k,l)
3255               aggj(k,l)=-aggj(k,l)
3256               aggj1(k,l)=-aggj1(k,l)
3257             enddo
3258           enddo
3259           if (j.lt.nres-1) then
3260             a22=-a22
3261             a32=-a32
3262             do l=1,3,2
3263               do k=1,3
3264                 agg(k,l)=-agg(k,l)
3265                 aggi(k,l)=-aggi(k,l)
3266                 aggi1(k,l)=-aggi1(k,l)
3267                 aggj(k,l)=-aggj(k,l)
3268                 aggj1(k,l)=-aggj1(k,l)
3269               enddo
3270             enddo
3271           else
3272             a22=-a22
3273             a23=-a23
3274             a32=-a32
3275             a33=-a33
3276             do l=1,4
3277               do k=1,3
3278                 agg(k,l)=-agg(k,l)
3279                 aggi(k,l)=-aggi(k,l)
3280                 aggi1(k,l)=-aggi1(k,l)
3281                 aggj(k,l)=-aggj(k,l)
3282                 aggj1(k,l)=-aggj1(k,l)
3283               enddo
3284             enddo
3285           endif
3286           ENDIF ! WCORR
3287           IF (wel_loc.gt.0.0d0) THEN
3288 C Contribution to the local-electrostatic energy coming from the i-j pair
3289           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3290      &     +a33*muij(4)
3291 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3292
3293           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3294      &            'eelloc',i,j,eel_loc_ij
3295 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3296
3297           eel_loc=eel_loc+eel_loc_ij
3298 C Partial derivatives in virtual-bond dihedral angles gamma
3299           if (i.gt.1)
3300      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3301      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3302      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3303           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3304      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3305      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3306 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3307           do l=1,3
3308             ggg(l)=agg(l,1)*muij(1)+
3309      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3310             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3311             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3312 cgrad            ghalf=0.5d0*ggg(l)
3313 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3314 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3315           enddo
3316 cgrad          do k=i+1,j2
3317 cgrad            do l=1,3
3318 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3319 cgrad            enddo
3320 cgrad          enddo
3321 C Remaining derivatives of eello
3322           do l=1,3
3323             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3324      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3325             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3326      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3327             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3328      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3329             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3330      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3331           enddo
3332           ENDIF
3333 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3334 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3335           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3336      &       .and. num_conti.le.maxconts) then
3337 c            write (iout,*) i,j," entered corr"
3338 C
3339 C Calculate the contact function. The ith column of the array JCONT will
3340 C contain the numbers of atoms that make contacts with the atom I (of numbers
3341 C greater than I). The arrays FACONT and GACONT will contain the values of
3342 C the contact function and its derivative.
3343 c           r0ij=1.02D0*rpp(iteli,itelj)
3344 c           r0ij=1.11D0*rpp(iteli,itelj)
3345             r0ij=2.20D0*rpp(iteli,itelj)
3346 c           r0ij=1.55D0*rpp(iteli,itelj)
3347             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3348             if (fcont.gt.0.0D0) then
3349               num_conti=num_conti+1
3350               if (num_conti.gt.maxconts) then
3351                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3352      &                         ' will skip next contacts for this conf.'
3353               else
3354                 jcont_hb(num_conti,i)=j
3355 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3356 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3357                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3358      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3359 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3360 C  terms.
3361                 d_cont(num_conti,i)=rij
3362 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3363 C     --- Electrostatic-interaction matrix ---
3364                 a_chuj(1,1,num_conti,i)=a22
3365                 a_chuj(1,2,num_conti,i)=a23
3366                 a_chuj(2,1,num_conti,i)=a32
3367                 a_chuj(2,2,num_conti,i)=a33
3368 C     --- Gradient of rij
3369                 do kkk=1,3
3370                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3371                 enddo
3372                 kkll=0
3373                 do k=1,2
3374                   do l=1,2
3375                     kkll=kkll+1
3376                     do m=1,3
3377                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3378                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3379                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3380                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3381                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3382                     enddo
3383                   enddo
3384                 enddo
3385                 ENDIF
3386                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3387 C Calculate contact energies
3388                 cosa4=4.0D0*cosa
3389                 wij=cosa-3.0D0*cosb*cosg
3390                 cosbg1=cosb+cosg
3391                 cosbg2=cosb-cosg
3392 c               fac3=dsqrt(-ael6i)/r0ij**3
3393                 fac3=dsqrt(-ael6i)*r3ij
3394 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3395                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3396                 if (ees0tmp.gt.0) then
3397                   ees0pij=dsqrt(ees0tmp)
3398                 else
3399                   ees0pij=0
3400                 endif
3401 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3402                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3403                 if (ees0tmp.gt.0) then
3404                   ees0mij=dsqrt(ees0tmp)
3405                 else
3406                   ees0mij=0
3407                 endif
3408 c               ees0mij=0.0D0
3409                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3410                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3411 C Diagnostics. Comment out or remove after debugging!
3412 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3413 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3414 c               ees0m(num_conti,i)=0.0D0
3415 C End diagnostics.
3416 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3417 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3418 C Angular derivatives of the contact function
3419                 ees0pij1=fac3/ees0pij
3420                 ees0mij1=fac3/ees0mij
3421                 fac3p=-3.0D0*fac3*rrmij
3422                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3423                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3424 c               ees0mij1=0.0D0
3425                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3426                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3427                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3428                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3429                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3430                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3431                 ecosap=ecosa1+ecosa2
3432                 ecosbp=ecosb1+ecosb2
3433                 ecosgp=ecosg1+ecosg2
3434                 ecosam=ecosa1-ecosa2
3435                 ecosbm=ecosb1-ecosb2
3436                 ecosgm=ecosg1-ecosg2
3437 C Diagnostics
3438 c               ecosap=ecosa1
3439 c               ecosbp=ecosb1
3440 c               ecosgp=ecosg1
3441 c               ecosam=0.0D0
3442 c               ecosbm=0.0D0
3443 c               ecosgm=0.0D0
3444 C End diagnostics
3445                 facont_hb(num_conti,i)=fcont
3446                 fprimcont=fprimcont/rij
3447 cd              facont_hb(num_conti,i)=1.0D0
3448 C Following line is for diagnostics.
3449 cd              fprimcont=0.0D0
3450                 do k=1,3
3451                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3452                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3453                 enddo
3454                 do k=1,3
3455                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3456                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3457                 enddo
3458                 gggp(1)=gggp(1)+ees0pijp*xj
3459                 gggp(2)=gggp(2)+ees0pijp*yj
3460                 gggp(3)=gggp(3)+ees0pijp*zj
3461                 gggm(1)=gggm(1)+ees0mijp*xj
3462                 gggm(2)=gggm(2)+ees0mijp*yj
3463                 gggm(3)=gggm(3)+ees0mijp*zj
3464 C Derivatives due to the contact function
3465                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3466                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3467                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3468                 do k=1,3
3469 c
3470 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3471 c          following the change of gradient-summation algorithm.
3472 c
3473 cgrad                  ghalfp=0.5D0*gggp(k)
3474 cgrad                  ghalfm=0.5D0*gggm(k)
3475                   gacontp_hb1(k,num_conti,i)=!ghalfp
3476      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3477      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3478                   gacontp_hb2(k,num_conti,i)=!ghalfp
3479      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3480      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3481                   gacontp_hb3(k,num_conti,i)=gggp(k)
3482                   gacontm_hb1(k,num_conti,i)=!ghalfm
3483      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3484      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3485                   gacontm_hb2(k,num_conti,i)=!ghalfm
3486      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3487      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3488                   gacontm_hb3(k,num_conti,i)=gggm(k)
3489                 enddo
3490 C Diagnostics. Comment out or remove after debugging!
3491 cdiag           do k=1,3
3492 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3493 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3494 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3495 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3496 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3497 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3498 cdiag           enddo
3499               ENDIF ! wcorr
3500               endif  ! num_conti.le.maxconts
3501             endif  ! fcont.gt.0
3502           endif    ! j.gt.i+1
3503           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3504             do k=1,4
3505               do l=1,3
3506                 ghalf=0.5d0*agg(l,k)
3507                 aggi(l,k)=aggi(l,k)+ghalf
3508                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3509                 aggj(l,k)=aggj(l,k)+ghalf
3510               enddo
3511             enddo
3512             if (j.eq.nres-1 .and. i.lt.j-2) then
3513               do k=1,4
3514                 do l=1,3
3515                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3516                 enddo
3517               enddo
3518             endif
3519           endif
3520 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3521       return
3522       end
3523 C-----------------------------------------------------------------------------
3524       subroutine eturn3(i,eello_turn3)
3525 C Third- and fourth-order contributions from turns
3526       implicit real*8 (a-h,o-z)
3527       include 'DIMENSIONS'
3528       include 'COMMON.IOUNITS'
3529       include 'COMMON.GEO'
3530       include 'COMMON.VAR'
3531       include 'COMMON.LOCAL'
3532       include 'COMMON.CHAIN'
3533       include 'COMMON.DERIV'
3534       include 'COMMON.INTERACT'
3535       include 'COMMON.CONTACTS'
3536       include 'COMMON.TORSION'
3537       include 'COMMON.VECTORS'
3538       include 'COMMON.FFIELD'
3539       include 'COMMON.CONTROL'
3540       dimension ggg(3)
3541       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3542      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3543      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3544       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3545      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3546       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3547      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3548      &    num_conti,j1,j2
3549       j=i+2
3550 c      write (iout,*) "eturn3",i,j,j1,j2
3551       a_temp(1,1)=a22
3552       a_temp(1,2)=a23
3553       a_temp(2,1)=a32
3554       a_temp(2,2)=a33
3555 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3556 C
3557 C               Third-order contributions
3558 C
3559 C                 (i+2)o----(i+3)
3560 C                      | |
3561 C                      | |
3562 C                 (i+1)o----i
3563 C
3564 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3565 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3566         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3567         call transpose2(auxmat(1,1),auxmat1(1,1))
3568         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3569         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3570         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3571      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3572 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3573 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3574 cd     &    ' eello_turn3_num',4*eello_turn3_num
3575 C Derivatives in gamma(i)
3576         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3577         call transpose2(auxmat2(1,1),auxmat3(1,1))
3578         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3579         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3580 C Derivatives in gamma(i+1)
3581         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3582         call transpose2(auxmat2(1,1),auxmat3(1,1))
3583         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3584         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3585      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3586 C Cartesian derivatives
3587         do l=1,3
3588 c            ghalf1=0.5d0*agg(l,1)
3589 c            ghalf2=0.5d0*agg(l,2)
3590 c            ghalf3=0.5d0*agg(l,3)
3591 c            ghalf4=0.5d0*agg(l,4)
3592           a_temp(1,1)=aggi(l,1)!+ghalf1
3593           a_temp(1,2)=aggi(l,2)!+ghalf2
3594           a_temp(2,1)=aggi(l,3)!+ghalf3
3595           a_temp(2,2)=aggi(l,4)!+ghalf4
3596           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3597           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3598      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3599           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3600           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3601           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3602           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3603           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3604           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3605      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3606           a_temp(1,1)=aggj(l,1)!+ghalf1
3607           a_temp(1,2)=aggj(l,2)!+ghalf2
3608           a_temp(2,1)=aggj(l,3)!+ghalf3
3609           a_temp(2,2)=aggj(l,4)!+ghalf4
3610           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3611           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3612      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3613           a_temp(1,1)=aggj1(l,1)
3614           a_temp(1,2)=aggj1(l,2)
3615           a_temp(2,1)=aggj1(l,3)
3616           a_temp(2,2)=aggj1(l,4)
3617           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3618           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3619      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3620         enddo
3621       return
3622       end
3623 C-------------------------------------------------------------------------------
3624       subroutine eturn4(i,eello_turn4)
3625 C Third- and fourth-order contributions from turns
3626       implicit real*8 (a-h,o-z)
3627       include 'DIMENSIONS'
3628       include 'COMMON.IOUNITS'
3629       include 'COMMON.GEO'
3630       include 'COMMON.VAR'
3631       include 'COMMON.LOCAL'
3632       include 'COMMON.CHAIN'
3633       include 'COMMON.DERIV'
3634       include 'COMMON.INTERACT'
3635       include 'COMMON.CONTACTS'
3636       include 'COMMON.TORSION'
3637       include 'COMMON.VECTORS'
3638       include 'COMMON.FFIELD'
3639       include 'COMMON.CONTROL'
3640       dimension ggg(3)
3641       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3642      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3643      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3644       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3645      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3646       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3647      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3648      &    num_conti,j1,j2
3649       j=i+3
3650 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3651 C
3652 C               Fourth-order contributions
3653 C
3654 C                 (i+3)o----(i+4)
3655 C                     /  |
3656 C               (i+2)o   |
3657 C                     \  |
3658 C                 (i+1)o----i
3659 C
3660 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3661 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3662 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3663         a_temp(1,1)=a22
3664         a_temp(1,2)=a23
3665         a_temp(2,1)=a32
3666         a_temp(2,2)=a33
3667         iti1=itortyp(itype(i+1))
3668         iti2=itortyp(itype(i+2))
3669         iti3=itortyp(itype(i+3))
3670 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3671         call transpose2(EUg(1,1,i+1),e1t(1,1))
3672         call transpose2(Eug(1,1,i+2),e2t(1,1))
3673         call transpose2(Eug(1,1,i+3),e3t(1,1))
3674         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3675         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3676         s1=scalar2(b1(1,iti2),auxvec(1))
3677         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3678         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3679         s2=scalar2(b1(1,iti1),auxvec(1))
3680         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3681         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3682         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3683         eello_turn4=eello_turn4-(s1+s2+s3)
3684         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3685      &      'eturn4',i,j,-(s1+s2+s3)
3686 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3687 cd     &    ' eello_turn4_num',8*eello_turn4_num
3688 C Derivatives in gamma(i)
3689         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3690         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3691         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3692         s1=scalar2(b1(1,iti2),auxvec(1))
3693         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3694         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3695         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3696 C Derivatives in gamma(i+1)
3697         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3698         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3699         s2=scalar2(b1(1,iti1),auxvec(1))
3700         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3701         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3702         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3703         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3704 C Derivatives in gamma(i+2)
3705         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3706         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3707         s1=scalar2(b1(1,iti2),auxvec(1))
3708         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3709         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3710         s2=scalar2(b1(1,iti1),auxvec(1))
3711         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3712         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3713         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3714         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3715 C Cartesian derivatives
3716 C Derivatives of this turn contributions in DC(i+2)
3717         if (j.lt.nres-1) then
3718           do l=1,3
3719             a_temp(1,1)=agg(l,1)
3720             a_temp(1,2)=agg(l,2)
3721             a_temp(2,1)=agg(l,3)
3722             a_temp(2,2)=agg(l,4)
3723             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3724             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3725             s1=scalar2(b1(1,iti2),auxvec(1))
3726             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3727             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3728             s2=scalar2(b1(1,iti1),auxvec(1))
3729             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3730             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3731             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3732             ggg(l)=-(s1+s2+s3)
3733             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3734           enddo
3735         endif
3736 C Remaining derivatives of this turn contribution
3737         do l=1,3
3738           a_temp(1,1)=aggi(l,1)
3739           a_temp(1,2)=aggi(l,2)
3740           a_temp(2,1)=aggi(l,3)
3741           a_temp(2,2)=aggi(l,4)
3742           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3743           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3744           s1=scalar2(b1(1,iti2),auxvec(1))
3745           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3746           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3747           s2=scalar2(b1(1,iti1),auxvec(1))
3748           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3749           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3750           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3751           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3752           a_temp(1,1)=aggi1(l,1)
3753           a_temp(1,2)=aggi1(l,2)
3754           a_temp(2,1)=aggi1(l,3)
3755           a_temp(2,2)=aggi1(l,4)
3756           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3757           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3758           s1=scalar2(b1(1,iti2),auxvec(1))
3759           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3760           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3761           s2=scalar2(b1(1,iti1),auxvec(1))
3762           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3763           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3764           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3765           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3766           a_temp(1,1)=aggj(l,1)
3767           a_temp(1,2)=aggj(l,2)
3768           a_temp(2,1)=aggj(l,3)
3769           a_temp(2,2)=aggj(l,4)
3770           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3771           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3772           s1=scalar2(b1(1,iti2),auxvec(1))
3773           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3774           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3775           s2=scalar2(b1(1,iti1),auxvec(1))
3776           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3777           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3778           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3779           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3780           a_temp(1,1)=aggj1(l,1)
3781           a_temp(1,2)=aggj1(l,2)
3782           a_temp(2,1)=aggj1(l,3)
3783           a_temp(2,2)=aggj1(l,4)
3784           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3785           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3786           s1=scalar2(b1(1,iti2),auxvec(1))
3787           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3788           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3789           s2=scalar2(b1(1,iti1),auxvec(1))
3790           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3791           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3792           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3793 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3794           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3795         enddo
3796       return
3797       end
3798 C-----------------------------------------------------------------------------
3799       subroutine vecpr(u,v,w)
3800       implicit real*8(a-h,o-z)
3801       dimension u(3),v(3),w(3)
3802       w(1)=u(2)*v(3)-u(3)*v(2)
3803       w(2)=-u(1)*v(3)+u(3)*v(1)
3804       w(3)=u(1)*v(2)-u(2)*v(1)
3805       return
3806       end
3807 C-----------------------------------------------------------------------------
3808       subroutine unormderiv(u,ugrad,unorm,ungrad)
3809 C This subroutine computes the derivatives of a normalized vector u, given
3810 C the derivatives computed without normalization conditions, ugrad. Returns
3811 C ungrad.
3812       implicit none
3813       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3814       double precision vec(3)
3815       double precision scalar
3816       integer i,j
3817 c      write (2,*) 'ugrad',ugrad
3818 c      write (2,*) 'u',u
3819       do i=1,3
3820         vec(i)=scalar(ugrad(1,i),u(1))
3821       enddo
3822 c      write (2,*) 'vec',vec
3823       do i=1,3
3824         do j=1,3
3825           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3826         enddo
3827       enddo
3828 c      write (2,*) 'ungrad',ungrad
3829       return
3830       end
3831 C-----------------------------------------------------------------------------
3832       subroutine escp_soft_sphere(evdw2,evdw2_14)
3833 C
3834 C This subroutine calculates the excluded-volume interaction energy between
3835 C peptide-group centers and side chains and its gradient in virtual-bond and
3836 C side-chain vectors.
3837 C
3838       implicit real*8 (a-h,o-z)
3839       include 'DIMENSIONS'
3840       include 'COMMON.GEO'
3841       include 'COMMON.VAR'
3842       include 'COMMON.LOCAL'
3843       include 'COMMON.CHAIN'
3844       include 'COMMON.DERIV'
3845       include 'COMMON.INTERACT'
3846       include 'COMMON.FFIELD'
3847       include 'COMMON.IOUNITS'
3848       include 'COMMON.CONTROL'
3849       dimension ggg(3)
3850       evdw2=0.0D0
3851       evdw2_14=0.0d0
3852       r0_scp=4.5d0
3853 cd    print '(a)','Enter ESCP'
3854 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3855       do i=iatscp_s,iatscp_e
3856         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3857         iteli=itel(i)
3858         xi=0.5D0*(c(1,i)+c(1,i+1))
3859         yi=0.5D0*(c(2,i)+c(2,i+1))
3860         zi=0.5D0*(c(3,i)+c(3,i+1))
3861
3862         do iint=1,nscp_gr(i)
3863
3864         do j=iscpstart(i,iint),iscpend(i,iint)
3865           if (itype(j).eq.ntyp1) cycle
3866           itypj=iabs(itype(j))
3867 C Uncomment following three lines for SC-p interactions
3868 c         xj=c(1,nres+j)-xi
3869 c         yj=c(2,nres+j)-yi
3870 c         zj=c(3,nres+j)-zi
3871 C Uncomment following three lines for Ca-p interactions
3872           xj=c(1,j)-xi
3873           yj=c(2,j)-yi
3874           zj=c(3,j)-zi
3875           rij=xj*xj+yj*yj+zj*zj
3876           r0ij=r0_scp
3877           r0ijsq=r0ij*r0ij
3878           if (rij.lt.r0ijsq) then
3879             evdwij=0.25d0*(rij-r0ijsq)**2
3880             fac=rij-r0ijsq
3881           else
3882             evdwij=0.0d0
3883             fac=0.0d0
3884           endif
3885           evdw2=evdw2+evdwij
3886 C
3887 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3888 C
3889           ggg(1)=xj*fac
3890           ggg(2)=yj*fac
3891           ggg(3)=zj*fac
3892 cgrad          if (j.lt.i) then
3893 cd          write (iout,*) 'j<i'
3894 C Uncomment following three lines for SC-p interactions
3895 c           do k=1,3
3896 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3897 c           enddo
3898 cgrad          else
3899 cd          write (iout,*) 'j>i'
3900 cgrad            do k=1,3
3901 cgrad              ggg(k)=-ggg(k)
3902 C Uncomment following line for SC-p interactions
3903 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3904 cgrad            enddo
3905 cgrad          endif
3906 cgrad          do k=1,3
3907 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3908 cgrad          enddo
3909 cgrad          kstart=min0(i+1,j)
3910 cgrad          kend=max0(i-1,j-1)
3911 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3912 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3913 cgrad          do k=kstart,kend
3914 cgrad            do l=1,3
3915 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3916 cgrad            enddo
3917 cgrad          enddo
3918           do k=1,3
3919             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3920             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3921           enddo
3922         enddo
3923
3924         enddo ! iint
3925       enddo ! i
3926       return
3927       end
3928 C-----------------------------------------------------------------------------
3929       subroutine escp(evdw2,evdw2_14)
3930 C
3931 C This subroutine calculates the excluded-volume interaction energy between
3932 C peptide-group centers and side chains and its gradient in virtual-bond and
3933 C side-chain vectors.
3934 C
3935       implicit real*8 (a-h,o-z)
3936       include 'DIMENSIONS'
3937       include 'COMMON.GEO'
3938       include 'COMMON.VAR'
3939       include 'COMMON.LOCAL'
3940       include 'COMMON.CHAIN'
3941       include 'COMMON.DERIV'
3942       include 'COMMON.INTERACT'
3943       include 'COMMON.FFIELD'
3944       include 'COMMON.IOUNITS'
3945       include 'COMMON.CONTROL'
3946       dimension ggg(3)
3947       evdw2=0.0D0
3948       evdw2_14=0.0d0
3949 cd    print '(a)','Enter ESCP'
3950 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3951       do i=iatscp_s,iatscp_e
3952         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3953         iteli=itel(i)
3954         xi=0.5D0*(c(1,i)+c(1,i+1))
3955         yi=0.5D0*(c(2,i)+c(2,i+1))
3956         zi=0.5D0*(c(3,i)+c(3,i+1))
3957
3958         do iint=1,nscp_gr(i)
3959
3960         do j=iscpstart(i,iint),iscpend(i,iint)
3961           itypj=iabs(itype(j))
3962           if (itypj.eq.ntyp1) cycle
3963 C Uncomment following three lines for SC-p interactions
3964 c         xj=c(1,nres+j)-xi
3965 c         yj=c(2,nres+j)-yi
3966 c         zj=c(3,nres+j)-zi
3967 C Uncomment following three lines for Ca-p interactions
3968           xj=c(1,j)-xi
3969           yj=c(2,j)-yi
3970           zj=c(3,j)-zi
3971           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3972           fac=rrij**expon2
3973           e1=fac*fac*aad(itypj,iteli)
3974           e2=fac*bad(itypj,iteli)
3975           if (iabs(j-i) .le. 2) then
3976             e1=scal14*e1
3977             e2=scal14*e2
3978             evdw2_14=evdw2_14+e1+e2
3979           endif
3980           evdwij=e1+e2
3981           evdw2=evdw2+evdwij
3982           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3983      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3984      &       bad(itypj,iteli)
3985 C
3986 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3987 C
3988           fac=-(evdwij+e1)*rrij
3989           ggg(1)=xj*fac
3990           ggg(2)=yj*fac
3991           ggg(3)=zj*fac
3992 cgrad          if (j.lt.i) then
3993 cd          write (iout,*) 'j<i'
3994 C Uncomment following three lines for SC-p interactions
3995 c           do k=1,3
3996 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3997 c           enddo
3998 cgrad          else
3999 cd          write (iout,*) 'j>i'
4000 cgrad            do k=1,3
4001 cgrad              ggg(k)=-ggg(k)
4002 C Uncomment following line for SC-p interactions
4003 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4004 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4005 cgrad            enddo
4006 cgrad          endif
4007 cgrad          do k=1,3
4008 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4009 cgrad          enddo
4010 cgrad          kstart=min0(i+1,j)
4011 cgrad          kend=max0(i-1,j-1)
4012 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4013 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4014 cgrad          do k=kstart,kend
4015 cgrad            do l=1,3
4016 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4017 cgrad            enddo
4018 cgrad          enddo
4019           do k=1,3
4020             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4021             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4022           enddo
4023         enddo
4024
4025         enddo ! iint
4026       enddo ! i
4027       do i=1,nct
4028         do j=1,3
4029           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4030           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4031           gradx_scp(j,i)=expon*gradx_scp(j,i)
4032         enddo
4033       enddo
4034 C******************************************************************************
4035 C
4036 C                              N O T E !!!
4037 C
4038 C To save time the factor EXPON has been extracted from ALL components
4039 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4040 C use!
4041 C
4042 C******************************************************************************
4043       return
4044       end
4045 C--------------------------------------------------------------------------
4046       subroutine edis(ehpb)
4047 C
4048 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4049 C
4050       implicit real*8 (a-h,o-z)
4051       include 'DIMENSIONS'
4052       include 'COMMON.SBRIDGE'
4053       include 'COMMON.CHAIN'
4054       include 'COMMON.DERIV'
4055       include 'COMMON.VAR'
4056       include 'COMMON.INTERACT'
4057       include 'COMMON.IOUNITS'
4058       dimension ggg(3)
4059       ehpb=0.0D0
4060 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4061 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4062       if (link_end.eq.0) return
4063       do i=link_start,link_end
4064 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4065 C CA-CA distance used in regularization of structure.
4066         ii=ihpb(i)
4067         jj=jhpb(i)
4068 C iii and jjj point to the residues for which the distance is assigned.
4069         if (ii.gt.nres) then
4070           iii=ii-nres
4071           jjj=jj-nres
4072         else
4073           iii=ii
4074           jjj=jj
4075         endif
4076 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4077 c     &    dhpb(i),dhpb1(i),forcon(i)
4078 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4079 C    distance and angle dependent SS bond potential.
4080 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4081 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4082         if (.not.dyn_ss .and. i.le.nss) then
4083 C 15/02/13 CC dynamic SSbond - additional check
4084          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4085      & iabs(itype(jjj)).eq.1) then
4086           call ssbond_ene(iii,jjj,eij)
4087           ehpb=ehpb+2*eij
4088          endif
4089 cd          write (iout,*) "eij",eij
4090          endif
4091         else
4092 C Calculate the distance between the two points and its difference from the
4093 C target distance.
4094           dd=dist(ii,jj)
4095             rdis=dd-dhpb(i)
4096 C Get the force constant corresponding to this distance.
4097             waga=forcon(i)
4098 C Calculate the contribution to energy.
4099             ehpb=ehpb+waga*rdis*rdis
4100 C
4101 C Evaluate gradient.
4102 C
4103             fac=waga*rdis/dd
4104 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4105 cd   &   ' waga=',waga,' fac=',fac
4106             do j=1,3
4107               ggg(j)=fac*(c(j,jj)-c(j,ii))
4108             enddo
4109 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4110 C If this is a SC-SC distance, we need to calculate the contributions to the
4111 C Cartesian gradient in the SC vectors (ghpbx).
4112           if (iii.lt.ii) then
4113           do j=1,3
4114             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4115             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4116           enddo
4117           endif
4118 cgrad        do j=iii,jjj-1
4119 cgrad          do k=1,3
4120 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4121 cgrad          enddo
4122 cgrad        enddo
4123           do k=1,3
4124             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4125             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4126           enddo
4127         endif
4128       enddo
4129       ehpb=0.5D0*ehpb
4130       return
4131       end
4132 C--------------------------------------------------------------------------
4133       subroutine ssbond_ene(i,j,eij)
4134 C
4135 C Calculate the distance and angle dependent SS-bond potential energy
4136 C using a free-energy function derived based on RHF/6-31G** ab initio
4137 C calculations of diethyl disulfide.
4138 C
4139 C A. Liwo and U. Kozlowska, 11/24/03
4140 C
4141       implicit real*8 (a-h,o-z)
4142       include 'DIMENSIONS'
4143       include 'COMMON.SBRIDGE'
4144       include 'COMMON.CHAIN'
4145       include 'COMMON.DERIV'
4146       include 'COMMON.LOCAL'
4147       include 'COMMON.INTERACT'
4148       include 'COMMON.VAR'
4149       include 'COMMON.IOUNITS'
4150       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4151       itypi=iabs(itype(i))
4152       xi=c(1,nres+i)
4153       yi=c(2,nres+i)
4154       zi=c(3,nres+i)
4155       dxi=dc_norm(1,nres+i)
4156       dyi=dc_norm(2,nres+i)
4157       dzi=dc_norm(3,nres+i)
4158 c      dsci_inv=dsc_inv(itypi)
4159       dsci_inv=vbld_inv(nres+i)
4160       itypj=iabs(itype(j))
4161 c      dscj_inv=dsc_inv(itypj)
4162       dscj_inv=vbld_inv(nres+j)
4163       xj=c(1,nres+j)-xi
4164       yj=c(2,nres+j)-yi
4165       zj=c(3,nres+j)-zi
4166       dxj=dc_norm(1,nres+j)
4167       dyj=dc_norm(2,nres+j)
4168       dzj=dc_norm(3,nres+j)
4169       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4170       rij=dsqrt(rrij)
4171       erij(1)=xj*rij
4172       erij(2)=yj*rij
4173       erij(3)=zj*rij
4174       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4175       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4176       om12=dxi*dxj+dyi*dyj+dzi*dzj
4177       do k=1,3
4178         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4179         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4180       enddo
4181       rij=1.0d0/rij
4182       deltad=rij-d0cm
4183       deltat1=1.0d0-om1
4184       deltat2=1.0d0+om2
4185       deltat12=om2-om1+2.0d0
4186       cosphi=om12-om1*om2
4187       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4188      &  +akct*deltad*deltat12
4189      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4190 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4191 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4192 c     &  " deltat12",deltat12," eij",eij
4193       ed=2*akcm*deltad+akct*deltat12
4194       pom1=akct*deltad
4195       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4196       eom1=-2*akth*deltat1-pom1-om2*pom2
4197       eom2= 2*akth*deltat2+pom1-om1*pom2
4198       eom12=pom2
4199       do k=1,3
4200         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4201         ghpbx(k,i)=ghpbx(k,i)-ggk
4202      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4203      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4204         ghpbx(k,j)=ghpbx(k,j)+ggk
4205      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4206      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4207         ghpbc(k,i)=ghpbc(k,i)-ggk
4208         ghpbc(k,j)=ghpbc(k,j)+ggk
4209       enddo
4210 C
4211 C Calculate the components of the gradient in DC and X
4212 C
4213 cgrad      do k=i,j-1
4214 cgrad        do l=1,3
4215 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4216 cgrad        enddo
4217 cgrad      enddo
4218       return
4219       end
4220 C--------------------------------------------------------------------------
4221       subroutine ebond(estr)
4222 c
4223 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4224 c
4225       implicit real*8 (a-h,o-z)
4226       include 'DIMENSIONS'
4227       include 'COMMON.LOCAL'
4228       include 'COMMON.GEO'
4229       include 'COMMON.INTERACT'
4230       include 'COMMON.DERIV'
4231       include 'COMMON.VAR'
4232       include 'COMMON.CHAIN'
4233       include 'COMMON.IOUNITS'
4234       include 'COMMON.NAMES'
4235       include 'COMMON.FFIELD'
4236       include 'COMMON.CONTROL'
4237       include 'COMMON.SETUP'
4238       double precision u(3),ud(3)
4239       estr=0.0d0
4240       estr1=0.0d0
4241       do i=ibondp_start,ibondp_end
4242         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4243           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4244           do j=1,3
4245           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4246      &      *dc(j,i-1)/vbld(i)
4247           enddo
4248           if (energy_dec) write(iout,*)
4249      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4250         else
4251         diff = vbld(i)-vbldp0
4252         if (energy_dec) write (iout,*)
4253      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4254         estr=estr+diff*diff
4255         do j=1,3
4256           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4257         enddo
4258 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4259         endif
4260       enddo
4261       estr=0.5d0*AKP*estr+estr1
4262 c
4263 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4264 c
4265       do i=ibond_start,ibond_end
4266         iti=iabs(itype(i))
4267         if (iti.ne.10 .and. iti.ne.ntyp1) then
4268           nbi=nbondterm(iti)
4269           if (nbi.eq.1) then
4270             diff=vbld(i+nres)-vbldsc0(1,iti)
4271             if (energy_dec) write (iout,*)
4272      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4273      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4274             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4275             do j=1,3
4276               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4277             enddo
4278           else
4279             do j=1,nbi
4280               diff=vbld(i+nres)-vbldsc0(j,iti)
4281               ud(j)=aksc(j,iti)*diff
4282               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4283             enddo
4284             uprod=u(1)
4285             do j=2,nbi
4286               uprod=uprod*u(j)
4287             enddo
4288             usum=0.0d0
4289             usumsqder=0.0d0
4290             do j=1,nbi
4291               uprod1=1.0d0
4292               uprod2=1.0d0
4293               do k=1,nbi
4294                 if (k.ne.j) then
4295                   uprod1=uprod1*u(k)
4296                   uprod2=uprod2*u(k)*u(k)
4297                 endif
4298               enddo
4299               usum=usum+uprod1
4300               usumsqder=usumsqder+ud(j)*uprod2
4301             enddo
4302             estr=estr+uprod/usum
4303             do j=1,3
4304              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4305             enddo
4306           endif
4307         endif
4308       enddo
4309       return
4310       end
4311 #ifdef CRYST_THETA
4312 C--------------------------------------------------------------------------
4313       subroutine ebend(etheta)
4314 C
4315 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4316 C angles gamma and its derivatives in consecutive thetas and gammas.
4317 C
4318       implicit real*8 (a-h,o-z)
4319       include 'DIMENSIONS'
4320       include 'COMMON.LOCAL'
4321       include 'COMMON.GEO'
4322       include 'COMMON.INTERACT'
4323       include 'COMMON.DERIV'
4324       include 'COMMON.VAR'
4325       include 'COMMON.CHAIN'
4326       include 'COMMON.IOUNITS'
4327       include 'COMMON.NAMES'
4328       include 'COMMON.FFIELD'
4329       include 'COMMON.CONTROL'
4330       common /calcthet/ term1,term2,termm,diffak,ratak,
4331      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4332      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4333       double precision y(2),z(2)
4334       delta=0.02d0*pi
4335 c      time11=dexp(-2*time)
4336 c      time12=1.0d0
4337       etheta=0.0D0
4338 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4339       do i=ithet_start,ithet_end
4340         if (itype(i-1).eq.ntyp1) cycle
4341 C Zero the energy function and its derivative at 0 or pi.
4342         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4343         it=itype(i-1)
4344         ichir1=isign(1,itype(i-2))
4345         ichir2=isign(1,itype(i))
4346          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4347          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4348          if (itype(i-1).eq.10) then
4349           itype1=isign(10,itype(i-2))
4350           ichir11=isign(1,itype(i-2))
4351           ichir12=isign(1,itype(i-2))
4352           itype2=isign(10,itype(i))
4353           ichir21=isign(1,itype(i))
4354           ichir22=isign(1,itype(i))
4355          endif
4356
4357         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4358 #ifdef OSF
4359           phii=phi(i)
4360           if (phii.ne.phii) phii=150.0
4361 #else
4362           phii=phi(i)
4363 #endif
4364           y(1)=dcos(phii)
4365           y(2)=dsin(phii)
4366         else
4367           y(1)=0.0D0
4368           y(2)=0.0D0
4369         endif
4370         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4371 #ifdef OSF
4372           phii1=phi(i+1)
4373           if (phii1.ne.phii1) phii1=150.0
4374           phii1=pinorm(phii1)
4375           z(1)=cos(phii1)
4376 #else
4377           phii1=phi(i+1)
4378           z(1)=dcos(phii1)
4379 #endif
4380           z(2)=dsin(phii1)
4381         else
4382           z(1)=0.0D0
4383           z(2)=0.0D0
4384         endif
4385 C Calculate the "mean" value of theta from the part of the distribution
4386 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4387 C In following comments this theta will be referred to as t_c.
4388         thet_pred_mean=0.0d0
4389         do k=1,2
4390             athetk=athet(k,it,ichir1,ichir2)
4391             bthetk=bthet(k,it,ichir1,ichir2)
4392           if (it.eq.10) then
4393              athetk=athet(k,itype1,ichir11,ichir12)
4394              bthetk=bthet(k,itype2,ichir21,ichir22)
4395           endif
4396          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4397         enddo
4398         dthett=thet_pred_mean*ssd
4399         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4400 C Derivatives of the "mean" values in gamma1 and gamma2.
4401         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4402      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4403          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4404      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4405          if (it.eq.10) then
4406       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4407      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4408         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4409      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4410          endif
4411         if (theta(i).gt.pi-delta) then
4412           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4413      &         E_tc0)
4414           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4415           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4416           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4417      &        E_theta)
4418           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4419      &        E_tc)
4420         else if (theta(i).lt.delta) then
4421           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4422           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4423           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4424      &        E_theta)
4425           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4426           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4427      &        E_tc)
4428         else
4429           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4430      &        E_theta,E_tc)
4431         endif
4432         etheta=etheta+ethetai
4433         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4434      &      'ebend',i,ethetai
4435         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4436         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4437         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4438       enddo
4439 C Ufff.... We've done all this!!!
4440       return
4441       end
4442 C---------------------------------------------------------------------------
4443       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4444      &     E_tc)
4445       implicit real*8 (a-h,o-z)
4446       include 'DIMENSIONS'
4447       include 'COMMON.LOCAL'
4448       include 'COMMON.IOUNITS'
4449       common /calcthet/ term1,term2,termm,diffak,ratak,
4450      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4451      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4452 C Calculate the contributions to both Gaussian lobes.
4453 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4454 C The "polynomial part" of the "standard deviation" of this part of
4455 C the distribution.
4456         sig=polthet(3,it)
4457         do j=2,0,-1
4458           sig=sig*thet_pred_mean+polthet(j,it)
4459         enddo
4460 C Derivative of the "interior part" of the "standard deviation of the"
4461 C gamma-dependent Gaussian lobe in t_c.
4462         sigtc=3*polthet(3,it)
4463         do j=2,1,-1
4464           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4465         enddo
4466         sigtc=sig*sigtc
4467 C Set the parameters of both Gaussian lobes of the distribution.
4468 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4469         fac=sig*sig+sigc0(it)
4470         sigcsq=fac+fac
4471         sigc=1.0D0/sigcsq
4472 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4473         sigsqtc=-4.0D0*sigcsq*sigtc
4474 c       print *,i,sig,sigtc,sigsqtc
4475 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4476         sigtc=-sigtc/(fac*fac)
4477 C Following variable is sigma(t_c)**(-2)
4478         sigcsq=sigcsq*sigcsq
4479         sig0i=sig0(it)
4480         sig0inv=1.0D0/sig0i**2
4481         delthec=thetai-thet_pred_mean
4482         delthe0=thetai-theta0i
4483         term1=-0.5D0*sigcsq*delthec*delthec
4484         term2=-0.5D0*sig0inv*delthe0*delthe0
4485 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4486 C NaNs in taking the logarithm. We extract the largest exponent which is added
4487 C to the energy (this being the log of the distribution) at the end of energy
4488 C term evaluation for this virtual-bond angle.
4489         if (term1.gt.term2) then
4490           termm=term1
4491           term2=dexp(term2-termm)
4492           term1=1.0d0
4493         else
4494           termm=term2
4495           term1=dexp(term1-termm)
4496           term2=1.0d0
4497         endif
4498 C The ratio between the gamma-independent and gamma-dependent lobes of
4499 C the distribution is a Gaussian function of thet_pred_mean too.
4500         diffak=gthet(2,it)-thet_pred_mean
4501         ratak=diffak/gthet(3,it)**2
4502         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4503 C Let's differentiate it in thet_pred_mean NOW.
4504         aktc=ak*ratak
4505 C Now put together the distribution terms to make complete distribution.
4506         termexp=term1+ak*term2
4507         termpre=sigc+ak*sig0i
4508 C Contribution of the bending energy from this theta is just the -log of
4509 C the sum of the contributions from the two lobes and the pre-exponential
4510 C factor. Simple enough, isn't it?
4511         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4512 C NOW the derivatives!!!
4513 C 6/6/97 Take into account the deformation.
4514         E_theta=(delthec*sigcsq*term1
4515      &       +ak*delthe0*sig0inv*term2)/termexp
4516         E_tc=((sigtc+aktc*sig0i)/termpre
4517      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4518      &       aktc*term2)/termexp)
4519       return
4520       end
4521 c-----------------------------------------------------------------------------
4522       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4523       implicit real*8 (a-h,o-z)
4524       include 'DIMENSIONS'
4525       include 'COMMON.LOCAL'
4526       include 'COMMON.IOUNITS'
4527       common /calcthet/ term1,term2,termm,diffak,ratak,
4528      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4529      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4530       delthec=thetai-thet_pred_mean
4531       delthe0=thetai-theta0i
4532 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4533       t3 = thetai-thet_pred_mean
4534       t6 = t3**2
4535       t9 = term1
4536       t12 = t3*sigcsq
4537       t14 = t12+t6*sigsqtc
4538       t16 = 1.0d0
4539       t21 = thetai-theta0i
4540       t23 = t21**2
4541       t26 = term2
4542       t27 = t21*t26
4543       t32 = termexp
4544       t40 = t32**2
4545       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4546      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4547      & *(-t12*t9-ak*sig0inv*t27)
4548       return
4549       end
4550 #else
4551 C--------------------------------------------------------------------------
4552       subroutine ebend(etheta)
4553 C
4554 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4555 C angles gamma and its derivatives in consecutive thetas and gammas.
4556 C ab initio-derived potentials from
4557 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4558 C
4559       implicit real*8 (a-h,o-z)
4560       include 'DIMENSIONS'
4561       include 'COMMON.LOCAL'
4562       include 'COMMON.GEO'
4563       include 'COMMON.INTERACT'
4564       include 'COMMON.DERIV'
4565       include 'COMMON.VAR'
4566       include 'COMMON.CHAIN'
4567       include 'COMMON.IOUNITS'
4568       include 'COMMON.NAMES'
4569       include 'COMMON.FFIELD'
4570       include 'COMMON.CONTROL'
4571       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4572      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4573      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4574      & sinph1ph2(maxdouble,maxdouble)
4575       logical lprn /.false./, lprn1 /.false./
4576       etheta=0.0D0
4577       do i=ithet_start,ithet_end
4578         if (itype(i-1).eq.ntyp1) cycle
4579         if (iabs(itype(i+1)).eq.20) iblock=2
4580         if (iabs(itype(i+1)).ne.20) iblock=1
4581         dethetai=0.0d0
4582         dephii=0.0d0
4583         dephii1=0.0d0
4584         theti2=0.5d0*theta(i)
4585         ityp2=ithetyp((itype(i-1)))
4586         do k=1,nntheterm
4587           coskt(k)=dcos(k*theti2)
4588           sinkt(k)=dsin(k*theti2)
4589         enddo
4590         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4591 #ifdef OSF
4592           phii=phi(i)
4593           if (phii.ne.phii) phii=150.0
4594 #else
4595           phii=phi(i)
4596 #endif
4597           ityp1=ithetyp((itype(i-2)))
4598 C propagation of chirality for glycine type
4599           do k=1,nsingle
4600             cosph1(k)=dcos(k*phii)
4601             sinph1(k)=dsin(k*phii)
4602           enddo
4603         else
4604           phii=0.0d0
4605           ityp1=nthetyp+1
4606           do k=1,nsingle
4607             cosph1(k)=0.0d0
4608             sinph1(k)=0.0d0
4609           enddo
4610         endif
4611         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4612 #ifdef OSF
4613           phii1=phi(i+1)
4614           if (phii1.ne.phii1) phii1=150.0
4615           phii1=pinorm(phii1)
4616 #else
4617           phii1=phi(i+1)
4618 #endif
4619           ityp3=ithetyp((itype(i)))
4620           do k=1,nsingle
4621             cosph2(k)=dcos(k*phii1)
4622             sinph2(k)=dsin(k*phii1)
4623           enddo
4624         else
4625           phii1=0.0d0
4626           ityp3=nthetyp+1
4627           do k=1,nsingle
4628             cosph2(k)=0.0d0
4629             sinph2(k)=0.0d0
4630           enddo
4631         endif
4632         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4633         do k=1,ndouble
4634           do l=1,k-1
4635             ccl=cosph1(l)*cosph2(k-l)
4636             ssl=sinph1(l)*sinph2(k-l)
4637             scl=sinph1(l)*cosph2(k-l)
4638             csl=cosph1(l)*sinph2(k-l)
4639             cosph1ph2(l,k)=ccl-ssl
4640             cosph1ph2(k,l)=ccl+ssl
4641             sinph1ph2(l,k)=scl+csl
4642             sinph1ph2(k,l)=scl-csl
4643           enddo
4644         enddo
4645         if (lprn) then
4646         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4647      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4648         write (iout,*) "coskt and sinkt"
4649         do k=1,nntheterm
4650           write (iout,*) k,coskt(k),sinkt(k)
4651         enddo
4652         endif
4653         do k=1,ntheterm
4654           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4655           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4656      &      *coskt(k)
4657           if (lprn)
4658      &    write (iout,*) "k",k,"
4659      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4660      &     " ethetai",ethetai
4661         enddo
4662         if (lprn) then
4663         write (iout,*) "cosph and sinph"
4664         do k=1,nsingle
4665           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4666         enddo
4667         write (iout,*) "cosph1ph2 and sinph2ph2"
4668         do k=2,ndouble
4669           do l=1,k-1
4670             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4671      &         sinph1ph2(l,k),sinph1ph2(k,l)
4672           enddo
4673         enddo
4674         write(iout,*) "ethetai",ethetai
4675         endif
4676         do m=1,ntheterm2
4677           do k=1,nsingle
4678             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4679      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4680      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4681      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4682             ethetai=ethetai+sinkt(m)*aux
4683             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4684             dephii=dephii+k*sinkt(m)*(
4685      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4686      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4687             dephii1=dephii1+k*sinkt(m)*(
4688      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4689      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4690             if (lprn)
4691      &      write (iout,*) "m",m," k",k," bbthet",
4692      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4693      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4694      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4695      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4696           enddo
4697         enddo
4698         if (lprn)
4699      &  write(iout,*) "ethetai",ethetai
4700         do m=1,ntheterm3
4701           do k=2,ndouble
4702             do l=1,k-1
4703               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4704      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4705      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4706      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4707               ethetai=ethetai+sinkt(m)*aux
4708               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4709               dephii=dephii+l*sinkt(m)*(
4710      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4711      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4712      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4713      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4714               dephii1=dephii1+(k-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               if (lprn) then
4720               write (iout,*) "m",m," k",k," l",l," ffthet",
4721      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4722      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4723      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4724      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4725      &            " ethetai",ethetai
4726               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4727      &            cosph1ph2(k,l)*sinkt(m),
4728      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4729               endif
4730             enddo
4731           enddo
4732         enddo
4733 10      continue
4734 c        lprn1=.true.
4735         if (lprn1)
4736      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4737      &   i,theta(i)*rad2deg,phii*rad2deg,
4738      &   phii1*rad2deg,ethetai
4739 c        lprn1=.false.
4740         etheta=etheta+ethetai
4741         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4742         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4743         gloc(nphi+i-2,icg)=wang*dethetai
4744       enddo
4745       return
4746       end
4747 #endif
4748 #ifdef CRYST_SC
4749 c-----------------------------------------------------------------------------
4750       subroutine esc(escloc)
4751 C Calculate the local energy of a side chain and its derivatives in the
4752 C corresponding virtual-bond valence angles THETA and the spherical angles
4753 C ALPHA and OMEGA.
4754       implicit real*8 (a-h,o-z)
4755       include 'DIMENSIONS'
4756       include 'COMMON.GEO'
4757       include 'COMMON.LOCAL'
4758       include 'COMMON.VAR'
4759       include 'COMMON.INTERACT'
4760       include 'COMMON.DERIV'
4761       include 'COMMON.CHAIN'
4762       include 'COMMON.IOUNITS'
4763       include 'COMMON.NAMES'
4764       include 'COMMON.FFIELD'
4765       include 'COMMON.CONTROL'
4766       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4767      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4768       common /sccalc/ time11,time12,time112,theti,it,nlobit
4769       delta=0.02d0*pi
4770       escloc=0.0D0
4771 c     write (iout,'(a)') 'ESC'
4772       do i=loc_start,loc_end
4773         it=itype(i)
4774         if (it.eq.ntyp1) cycle
4775         if (it.eq.10) goto 1
4776         nlobit=nlob(iabs(it))
4777 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4778 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4779         theti=theta(i+1)-pipol
4780         x(1)=dtan(theti)
4781         x(2)=alph(i)
4782         x(3)=omeg(i)
4783
4784         if (x(2).gt.pi-delta) then
4785           xtemp(1)=x(1)
4786           xtemp(2)=pi-delta
4787           xtemp(3)=x(3)
4788           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4789           xtemp(2)=pi
4790           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4791           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4792      &        escloci,dersc(2))
4793           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4794      &        ddersc0(1),dersc(1))
4795           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4796      &        ddersc0(3),dersc(3))
4797           xtemp(2)=pi-delta
4798           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4799           xtemp(2)=pi
4800           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4801           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4802      &            dersc0(2),esclocbi,dersc02)
4803           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4804      &            dersc12,dersc01)
4805           call splinthet(x(2),0.5d0*delta,ss,ssd)
4806           dersc0(1)=dersc01
4807           dersc0(2)=dersc02
4808           dersc0(3)=0.0d0
4809           do k=1,3
4810             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4811           enddo
4812           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4813 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4814 c    &             esclocbi,ss,ssd
4815           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4816 c         escloci=esclocbi
4817 c         write (iout,*) escloci
4818         else if (x(2).lt.delta) then
4819           xtemp(1)=x(1)
4820           xtemp(2)=delta
4821           xtemp(3)=x(3)
4822           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4823           xtemp(2)=0.0d0
4824           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4825           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4826      &        escloci,dersc(2))
4827           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4828      &        ddersc0(1),dersc(1))
4829           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4830      &        ddersc0(3),dersc(3))
4831           xtemp(2)=delta
4832           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4833           xtemp(2)=0.0d0
4834           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4835           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4836      &            dersc0(2),esclocbi,dersc02)
4837           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4838      &            dersc12,dersc01)
4839           dersc0(1)=dersc01
4840           dersc0(2)=dersc02
4841           dersc0(3)=0.0d0
4842           call splinthet(x(2),0.5d0*delta,ss,ssd)
4843           do k=1,3
4844             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4845           enddo
4846           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4847 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4848 c    &             esclocbi,ss,ssd
4849           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4850 c         write (iout,*) escloci
4851         else
4852           call enesc(x,escloci,dersc,ddummy,.false.)
4853         endif
4854
4855         escloc=escloc+escloci
4856         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4857      &     'escloc',i,escloci
4858 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4859
4860         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4861      &   wscloc*dersc(1)
4862         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4863         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4864     1   continue
4865       enddo
4866       return
4867       end
4868 C---------------------------------------------------------------------------
4869       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4870       implicit real*8 (a-h,o-z)
4871       include 'DIMENSIONS'
4872       include 'COMMON.GEO'
4873       include 'COMMON.LOCAL'
4874       include 'COMMON.IOUNITS'
4875       common /sccalc/ time11,time12,time112,theti,it,nlobit
4876       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4877       double precision contr(maxlob,-1:1)
4878       logical mixed
4879 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4880         escloc_i=0.0D0
4881         do j=1,3
4882           dersc(j)=0.0D0
4883           if (mixed) ddersc(j)=0.0d0
4884         enddo
4885         x3=x(3)
4886
4887 C Because of periodicity of the dependence of the SC energy in omega we have
4888 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4889 C To avoid underflows, first compute & store the exponents.
4890
4891         do iii=-1,1
4892
4893           x(3)=x3+iii*dwapi
4894
4895           do j=1,nlobit
4896             do k=1,3
4897               z(k)=x(k)-censc(k,j,it)
4898             enddo
4899             do k=1,3
4900               Axk=0.0D0
4901               do l=1,3
4902                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4903               enddo
4904               Ax(k,j,iii)=Axk
4905             enddo
4906             expfac=0.0D0
4907             do k=1,3
4908               expfac=expfac+Ax(k,j,iii)*z(k)
4909             enddo
4910             contr(j,iii)=expfac
4911           enddo ! j
4912
4913         enddo ! iii
4914
4915         x(3)=x3
4916 C As in the case of ebend, we want to avoid underflows in exponentiation and
4917 C subsequent NaNs and INFs in energy calculation.
4918 C Find the largest exponent
4919         emin=contr(1,-1)
4920         do iii=-1,1
4921           do j=1,nlobit
4922             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4923           enddo
4924         enddo
4925         emin=0.5D0*emin
4926 cd      print *,'it=',it,' emin=',emin
4927
4928 C Compute the contribution to SC energy and derivatives
4929         do iii=-1,1
4930
4931           do j=1,nlobit
4932 #ifdef OSF
4933             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4934             if(adexp.ne.adexp) adexp=1.0
4935             expfac=dexp(adexp)
4936 #else
4937             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4938 #endif
4939 cd          print *,'j=',j,' expfac=',expfac
4940             escloc_i=escloc_i+expfac
4941             do k=1,3
4942               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4943             enddo
4944             if (mixed) then
4945               do k=1,3,2
4946                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4947      &            +gaussc(k,2,j,it))*expfac
4948               enddo
4949             endif
4950           enddo
4951
4952         enddo ! iii
4953
4954         dersc(1)=dersc(1)/cos(theti)**2
4955         ddersc(1)=ddersc(1)/cos(theti)**2
4956         ddersc(3)=ddersc(3)
4957
4958         escloci=-(dlog(escloc_i)-emin)
4959         do j=1,3
4960           dersc(j)=dersc(j)/escloc_i
4961         enddo
4962         if (mixed) then
4963           do j=1,3,2
4964             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4965           enddo
4966         endif
4967       return
4968       end
4969 C------------------------------------------------------------------------------
4970       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4971       implicit real*8 (a-h,o-z)
4972       include 'DIMENSIONS'
4973       include 'COMMON.GEO'
4974       include 'COMMON.LOCAL'
4975       include 'COMMON.IOUNITS'
4976       common /sccalc/ time11,time12,time112,theti,it,nlobit
4977       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4978       double precision contr(maxlob)
4979       logical mixed
4980
4981       escloc_i=0.0D0
4982
4983       do j=1,3
4984         dersc(j)=0.0D0
4985       enddo
4986
4987       do j=1,nlobit
4988         do k=1,2
4989           z(k)=x(k)-censc(k,j,it)
4990         enddo
4991         z(3)=dwapi
4992         do k=1,3
4993           Axk=0.0D0
4994           do l=1,3
4995             Axk=Axk+gaussc(l,k,j,it)*z(l)
4996           enddo
4997           Ax(k,j)=Axk
4998         enddo
4999         expfac=0.0D0
5000         do k=1,3
5001           expfac=expfac+Ax(k,j)*z(k)
5002         enddo
5003         contr(j)=expfac
5004       enddo ! j
5005
5006 C As in the case of ebend, we want to avoid underflows in exponentiation and
5007 C subsequent NaNs and INFs in energy calculation.
5008 C Find the largest exponent
5009       emin=contr(1)
5010       do j=1,nlobit
5011         if (emin.gt.contr(j)) emin=contr(j)
5012       enddo
5013       emin=0.5D0*emin
5014
5015 C Compute the contribution to SC energy and derivatives
5016
5017       dersc12=0.0d0
5018       do j=1,nlobit
5019         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5020         escloc_i=escloc_i+expfac
5021         do k=1,2
5022           dersc(k)=dersc(k)+Ax(k,j)*expfac
5023         enddo
5024         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5025      &            +gaussc(1,2,j,it))*expfac
5026         dersc(3)=0.0d0
5027       enddo
5028
5029       dersc(1)=dersc(1)/cos(theti)**2
5030       dersc12=dersc12/cos(theti)**2
5031       escloci=-(dlog(escloc_i)-emin)
5032       do j=1,2
5033         dersc(j)=dersc(j)/escloc_i
5034       enddo
5035       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5036       return
5037       end
5038 #else
5039 c----------------------------------------------------------------------------------
5040       subroutine esc(escloc)
5041 C Calculate the local energy of a side chain and its derivatives in the
5042 C corresponding virtual-bond valence angles THETA and the spherical angles
5043 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5044 C added by Urszula Kozlowska. 07/11/2007
5045 C
5046       implicit real*8 (a-h,o-z)
5047       include 'DIMENSIONS'
5048       include 'COMMON.GEO'
5049       include 'COMMON.LOCAL'
5050       include 'COMMON.VAR'
5051       include 'COMMON.SCROT'
5052       include 'COMMON.INTERACT'
5053       include 'COMMON.DERIV'
5054       include 'COMMON.CHAIN'
5055       include 'COMMON.IOUNITS'
5056       include 'COMMON.NAMES'
5057       include 'COMMON.FFIELD'
5058       include 'COMMON.CONTROL'
5059       include 'COMMON.VECTORS'
5060       double precision x_prime(3),y_prime(3),z_prime(3)
5061      &    , sumene,dsc_i,dp2_i,x(65),
5062      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5063      &    de_dxx,de_dyy,de_dzz,de_dt
5064       double precision s1_t,s1_6_t,s2_t,s2_6_t
5065       double precision
5066      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5067      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5068      & dt_dCi(3),dt_dCi1(3)
5069       common /sccalc/ time11,time12,time112,theti,it,nlobit
5070       delta=0.02d0*pi
5071       escloc=0.0D0
5072       do i=loc_start,loc_end
5073         if (itype(i).eq.ntyp1) cycle
5074         costtab(i+1) =dcos(theta(i+1))
5075         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5076         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5077         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5078         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5079         cosfac=dsqrt(cosfac2)
5080         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5081         sinfac=dsqrt(sinfac2)
5082         it=iabs(itype(i))
5083         if (it.eq.10) goto 1
5084 c
5085 C  Compute the axes of tghe local cartesian coordinates system; store in
5086 c   x_prime, y_prime and z_prime
5087 c
5088         do j=1,3
5089           x_prime(j) = 0.00
5090           y_prime(j) = 0.00
5091           z_prime(j) = 0.00
5092         enddo
5093 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5094 C     &   dc_norm(3,i+nres)
5095         do j = 1,3
5096           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5097           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5098         enddo
5099         do j = 1,3
5100           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5101         enddo
5102 c       write (2,*) "i",i
5103 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5104 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5105 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5106 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5107 c      & " xy",scalar(x_prime(1),y_prime(1)),
5108 c      & " xz",scalar(x_prime(1),z_prime(1)),
5109 c      & " yy",scalar(y_prime(1),y_prime(1)),
5110 c      & " yz",scalar(y_prime(1),z_prime(1)),
5111 c      & " zz",scalar(z_prime(1),z_prime(1))
5112 c
5113 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5114 C to local coordinate system. Store in xx, yy, zz.
5115 c
5116         xx=0.0d0
5117         yy=0.0d0
5118         zz=0.0d0
5119         do j = 1,3
5120           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5121           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5122           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5123         enddo
5124
5125         xxtab(i)=xx
5126         yytab(i)=yy
5127         zztab(i)=zz
5128 C
5129 C Compute the energy of the ith side cbain
5130 C
5131 c        write (2,*) "xx",xx," yy",yy," zz",zz
5132         it=iabs(itype(i))
5133         do j = 1,65
5134           x(j) = sc_parmin(j,it)
5135         enddo
5136 #ifdef CHECK_COORD
5137 Cc diagnostics - remove later
5138         xx1 = dcos(alph(2))
5139         yy1 = dsin(alph(2))*dcos(omeg(2))
5140         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5141         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5142      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5143      &    xx1,yy1,zz1
5144 C,"  --- ", xx_w,yy_w,zz_w
5145 c end diagnostics
5146 #endif
5147         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5148      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5149      &   + x(10)*yy*zz
5150         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5151      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5152      & + x(20)*yy*zz
5153         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5154      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5155      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5156      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5157      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5158      &  +x(40)*xx*yy*zz
5159         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5160      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5161      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5162      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5163      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5164      &  +x(60)*xx*yy*zz
5165         dsc_i   = 0.743d0+x(61)
5166         dp2_i   = 1.9d0+x(62)
5167         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5168      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5169         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5170      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5171         s1=(1+x(63))/(0.1d0 + dscp1)
5172         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5173         s2=(1+x(65))/(0.1d0 + dscp2)
5174         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5175         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5176      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5177 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5178 c     &   sumene4,
5179 c     &   dscp1,dscp2,sumene
5180 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5181         escloc = escloc + sumene
5182 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5183 c     & ,zz,xx,yy
5184 c#define DEBUG
5185 #ifdef DEBUG
5186 C
5187 C This section to check the numerical derivatives of the energy of ith side
5188 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5189 C #define DEBUG in the code to turn it on.
5190 C
5191         write (2,*) "sumene               =",sumene
5192         aincr=1.0d-7
5193         xxsave=xx
5194         xx=xx+aincr
5195         write (2,*) xx,yy,zz
5196         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5197         de_dxx_num=(sumenep-sumene)/aincr
5198         xx=xxsave
5199         write (2,*) "xx+ sumene from enesc=",sumenep
5200         yysave=yy
5201         yy=yy+aincr
5202         write (2,*) xx,yy,zz
5203         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5204         de_dyy_num=(sumenep-sumene)/aincr
5205         yy=yysave
5206         write (2,*) "yy+ sumene from enesc=",sumenep
5207         zzsave=zz
5208         zz=zz+aincr
5209         write (2,*) xx,yy,zz
5210         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5211         de_dzz_num=(sumenep-sumene)/aincr
5212         zz=zzsave
5213         write (2,*) "zz+ sumene from enesc=",sumenep
5214         costsave=cost2tab(i+1)
5215         sintsave=sint2tab(i+1)
5216         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5217         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5218         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5219         de_dt_num=(sumenep-sumene)/aincr
5220         write (2,*) " t+ sumene from enesc=",sumenep
5221         cost2tab(i+1)=costsave
5222         sint2tab(i+1)=sintsave
5223 C End of diagnostics section.
5224 #endif
5225 C
5226 C Compute the gradient of esc
5227 C
5228 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5229         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5230         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5231         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5232         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5233         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5234         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5235         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5236         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5237         pom1=(sumene3*sint2tab(i+1)+sumene1)
5238      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5239         pom2=(sumene4*cost2tab(i+1)+sumene2)
5240      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5241         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5242         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5243      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5244      &  +x(40)*yy*zz
5245         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5246         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5247      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5248      &  +x(60)*yy*zz
5249         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5250      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5251      &        +(pom1+pom2)*pom_dx
5252 #ifdef DEBUG
5253         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5254 #endif
5255 C
5256         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5257         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5258      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5259      &  +x(40)*xx*zz
5260         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5261         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5262      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5263      &  +x(59)*zz**2 +x(60)*xx*zz
5264         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5265      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5266      &        +(pom1-pom2)*pom_dy
5267 #ifdef DEBUG
5268         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5269 #endif
5270 C
5271         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5272      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5273      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5274      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5275      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5276      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5277      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5278      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5279 #ifdef DEBUG
5280         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5281 #endif
5282 C
5283         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5284      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5285      &  +pom1*pom_dt1+pom2*pom_dt2
5286 #ifdef DEBUG
5287         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5288 #endif
5289 c#undef DEBUG
5290 c
5291 C
5292        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5293        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5294        cosfac2xx=cosfac2*xx
5295        sinfac2yy=sinfac2*yy
5296        do k = 1,3
5297          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5298      &      vbld_inv(i+1)
5299          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5300      &      vbld_inv(i)
5301          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5302          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5303 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5304 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5305 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5306 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5307          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5308          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5309          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5310          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5311          dZZ_Ci1(k)=0.0d0
5312          dZZ_Ci(k)=0.0d0
5313          do j=1,3
5314            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5315      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5316            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5317      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5318          enddo
5319
5320          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5321          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5322          dZZ_XYZ(k)=vbld_inv(i+nres)*
5323      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5324 c
5325          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5326          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5327        enddo
5328
5329        do k=1,3
5330          dXX_Ctab(k,i)=dXX_Ci(k)
5331          dXX_C1tab(k,i)=dXX_Ci1(k)
5332          dYY_Ctab(k,i)=dYY_Ci(k)
5333          dYY_C1tab(k,i)=dYY_Ci1(k)
5334          dZZ_Ctab(k,i)=dZZ_Ci(k)
5335          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5336          dXX_XYZtab(k,i)=dXX_XYZ(k)
5337          dYY_XYZtab(k,i)=dYY_XYZ(k)
5338          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5339        enddo
5340
5341        do k = 1,3
5342 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5343 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5344 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5345 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5346 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5347 c     &    dt_dci(k)
5348 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5349 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5350          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5351      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5352          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5353      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5354          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5355      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5356        enddo
5357 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5358 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5359
5360 C to check gradient call subroutine check_grad
5361
5362     1 continue
5363       enddo
5364       return
5365       end
5366 c------------------------------------------------------------------------------
5367       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5368       implicit none
5369       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5370      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5371       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5372      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5373      &   + x(10)*yy*zz
5374       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5375      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5376      & + x(20)*yy*zz
5377       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5378      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5379      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5380      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5381      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5382      &  +x(40)*xx*yy*zz
5383       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5384      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5385      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5386      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5387      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5388      &  +x(60)*xx*yy*zz
5389       dsc_i   = 0.743d0+x(61)
5390       dp2_i   = 1.9d0+x(62)
5391       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5392      &          *(xx*cost2+yy*sint2))
5393       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5394      &          *(xx*cost2-yy*sint2))
5395       s1=(1+x(63))/(0.1d0 + dscp1)
5396       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5397       s2=(1+x(65))/(0.1d0 + dscp2)
5398       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5399       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5400      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5401       enesc=sumene
5402       return
5403       end
5404 #endif
5405 c------------------------------------------------------------------------------
5406       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5407 C
5408 C This procedure calculates two-body contact function g(rij) and its derivative:
5409 C
5410 C           eps0ij                                     !       x < -1
5411 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5412 C            0                                         !       x > 1
5413 C
5414 C where x=(rij-r0ij)/delta
5415 C
5416 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5417 C
5418       implicit none
5419       double precision rij,r0ij,eps0ij,fcont,fprimcont
5420       double precision x,x2,x4,delta
5421 c     delta=0.02D0*r0ij
5422 c      delta=0.2D0*r0ij
5423       x=(rij-r0ij)/delta
5424       if (x.lt.-1.0D0) then
5425         fcont=eps0ij
5426         fprimcont=0.0D0
5427       else if (x.le.1.0D0) then
5428         x2=x*x
5429         x4=x2*x2
5430         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5431         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5432       else
5433         fcont=0.0D0
5434         fprimcont=0.0D0
5435       endif
5436       return
5437       end
5438 c------------------------------------------------------------------------------
5439       subroutine splinthet(theti,delta,ss,ssder)
5440       implicit real*8 (a-h,o-z)
5441       include 'DIMENSIONS'
5442       include 'COMMON.VAR'
5443       include 'COMMON.GEO'
5444       thetup=pi-delta
5445       thetlow=delta
5446       if (theti.gt.pipol) then
5447         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5448       else
5449         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5450         ssder=-ssder
5451       endif
5452       return
5453       end
5454 c------------------------------------------------------------------------------
5455       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5456       implicit none
5457       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5458       double precision ksi,ksi2,ksi3,a1,a2,a3
5459       a1=fprim0*delta/(f1-f0)
5460       a2=3.0d0-2.0d0*a1
5461       a3=a1-2.0d0
5462       ksi=(x-x0)/delta
5463       ksi2=ksi*ksi
5464       ksi3=ksi2*ksi
5465       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5466       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5467       return
5468       end
5469 c------------------------------------------------------------------------------
5470       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5471       implicit none
5472       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5473       double precision ksi,ksi2,ksi3,a1,a2,a3
5474       ksi=(x-x0)/delta
5475       ksi2=ksi*ksi
5476       ksi3=ksi2*ksi
5477       a1=fprim0x*delta
5478       a2=3*(f1x-f0x)-2*fprim0x*delta
5479       a3=fprim0x*delta-2*(f1x-f0x)
5480       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5481       return
5482       end
5483 C-----------------------------------------------------------------------------
5484 #ifdef CRYST_TOR
5485 C-----------------------------------------------------------------------------
5486       subroutine etor(etors,edihcnstr)
5487       implicit real*8 (a-h,o-z)
5488       include 'DIMENSIONS'
5489       include 'COMMON.VAR'
5490       include 'COMMON.GEO'
5491       include 'COMMON.LOCAL'
5492       include 'COMMON.TORSION'
5493       include 'COMMON.INTERACT'
5494       include 'COMMON.DERIV'
5495       include 'COMMON.CHAIN'
5496       include 'COMMON.NAMES'
5497       include 'COMMON.IOUNITS'
5498       include 'COMMON.FFIELD'
5499       include 'COMMON.TORCNSTR'
5500       include 'COMMON.CONTROL'
5501       logical lprn
5502 C Set lprn=.true. for debugging
5503       lprn=.false.
5504 c      lprn=.true.
5505       etors=0.0D0
5506       do i=iphi_start,iphi_end
5507       etors_ii=0.0D0
5508         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5509      &      .or. itype(i).eq.ntyp1) cycle
5510         itori=itortyp(itype(i-2))
5511         itori1=itortyp(itype(i-1))
5512         phii=phi(i)
5513         gloci=0.0D0
5514 C Proline-Proline pair is a special case...
5515         if (itori.eq.3 .and. itori1.eq.3) then
5516           if (phii.gt.-dwapi3) then
5517             cosphi=dcos(3*phii)
5518             fac=1.0D0/(1.0D0-cosphi)
5519             etorsi=v1(1,3,3)*fac
5520             etorsi=etorsi+etorsi
5521             etors=etors+etorsi-v1(1,3,3)
5522             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5523             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5524           endif
5525           do j=1,3
5526             v1ij=v1(j+1,itori,itori1)
5527             v2ij=v2(j+1,itori,itori1)
5528             cosphi=dcos(j*phii)
5529             sinphi=dsin(j*phii)
5530             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5531             if (energy_dec) etors_ii=etors_ii+
5532      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5533             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5534           enddo
5535         else
5536           do j=1,nterm_old
5537             v1ij=v1(j,itori,itori1)
5538             v2ij=v2(j,itori,itori1)
5539             cosphi=dcos(j*phii)
5540             sinphi=dsin(j*phii)
5541             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5542             if (energy_dec) etors_ii=etors_ii+
5543      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5544             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5545           enddo
5546         endif
5547         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5548              'etor',i,etors_ii
5549         if (lprn)
5550      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5551      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5552      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5553         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5554 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5555       enddo
5556 ! 6/20/98 - dihedral angle constraints
5557       edihcnstr=0.0d0
5558       do i=1,ndih_constr
5559         itori=idih_constr(i)
5560         phii=phi(itori)
5561         difi=phii-phi0(i)
5562         if (difi.gt.drange(i)) then
5563           difi=difi-drange(i)
5564           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5565           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5566         else if (difi.lt.-drange(i)) then
5567           difi=difi+drange(i)
5568           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5569           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5570         endif
5571 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5572 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5573       enddo
5574 !      write (iout,*) 'edihcnstr',edihcnstr
5575       return
5576       end
5577 c------------------------------------------------------------------------------
5578       subroutine etor_d(etors_d)
5579       etors_d=0.0d0
5580       return
5581       end
5582 c----------------------------------------------------------------------------
5583 #else
5584       subroutine etor(etors,edihcnstr)
5585       implicit real*8 (a-h,o-z)
5586       include 'DIMENSIONS'
5587       include 'COMMON.VAR'
5588       include 'COMMON.GEO'
5589       include 'COMMON.LOCAL'
5590       include 'COMMON.TORSION'
5591       include 'COMMON.INTERACT'
5592       include 'COMMON.DERIV'
5593       include 'COMMON.CHAIN'
5594       include 'COMMON.NAMES'
5595       include 'COMMON.IOUNITS'
5596       include 'COMMON.FFIELD'
5597       include 'COMMON.TORCNSTR'
5598       include 'COMMON.CONTROL'
5599       logical lprn
5600 C Set lprn=.true. for debugging
5601       lprn=.false.
5602 c     lprn=.true.
5603       etors=0.0D0
5604       do i=iphi_start,iphi_end
5605         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5606      &       .or. itype(i).eq.ntyp1) cycle
5607         etors_ii=0.0D0
5608          if (iabs(itype(i)).eq.20) then
5609          iblock=2
5610          else
5611          iblock=1
5612          endif
5613         itori=itortyp(itype(i-2))
5614         itori1=itortyp(itype(i-1))
5615         phii=phi(i)
5616         gloci=0.0D0
5617 C Regular cosine and sine terms
5618         do j=1,nterm(itori,itori1,iblock)
5619           v1ij=v1(j,itori,itori1,iblock)
5620           v2ij=v2(j,itori,itori1,iblock)
5621           cosphi=dcos(j*phii)
5622           sinphi=dsin(j*phii)
5623           etors=etors+v1ij*cosphi+v2ij*sinphi
5624           if (energy_dec) etors_ii=etors_ii+
5625      &                v1ij*cosphi+v2ij*sinphi
5626           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5627         enddo
5628 C Lorentz terms
5629 C                         v1
5630 C  E = SUM ----------------------------------- - v1
5631 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5632 C
5633         cosphi=dcos(0.5d0*phii)
5634         sinphi=dsin(0.5d0*phii)
5635         do j=1,nlor(itori,itori1,iblock)
5636           vl1ij=vlor1(j,itori,itori1)
5637           vl2ij=vlor2(j,itori,itori1)
5638           vl3ij=vlor3(j,itori,itori1)
5639           pom=vl2ij*cosphi+vl3ij*sinphi
5640           pom1=1.0d0/(pom*pom+1.0d0)
5641           etors=etors+vl1ij*pom1
5642           if (energy_dec) etors_ii=etors_ii+
5643      &                vl1ij*pom1
5644           pom=-pom*pom1*pom1
5645           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5646         enddo
5647 C Subtract the constant term
5648         etors=etors-v0(itori,itori1,iblock)
5649           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5650      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5651         if (lprn)
5652      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5653      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5654      &  (v1(j,itori,itori1,iblock),j=1,6),
5655      &  (v2(j,itori,itori1,iblock),j=1,6)
5656         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5657 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5658       enddo
5659 ! 6/20/98 - dihedral angle constraints
5660       edihcnstr=0.0d0
5661 c      do i=1,ndih_constr
5662       do i=idihconstr_start,idihconstr_end
5663         itori=idih_constr(i)
5664         phii=phi(itori)
5665         difi=pinorm(phii-phi0(i))
5666         if (difi.gt.drange(i)) then
5667           difi=difi-drange(i)
5668           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5669           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5670         else if (difi.lt.-drange(i)) then
5671           difi=difi+drange(i)
5672           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5673           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5674         else
5675           difi=0.0
5676         endif
5677 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5678 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5679 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5680       enddo
5681 cd       write (iout,*) 'edihcnstr',edihcnstr
5682       return
5683       end
5684 c----------------------------------------------------------------------------
5685       subroutine etor_d(etors_d)
5686 C 6/23/01 Compute double torsional energy
5687       implicit real*8 (a-h,o-z)
5688       include 'DIMENSIONS'
5689       include 'COMMON.VAR'
5690       include 'COMMON.GEO'
5691       include 'COMMON.LOCAL'
5692       include 'COMMON.TORSION'
5693       include 'COMMON.INTERACT'
5694       include 'COMMON.DERIV'
5695       include 'COMMON.CHAIN'
5696       include 'COMMON.NAMES'
5697       include 'COMMON.IOUNITS'
5698       include 'COMMON.FFIELD'
5699       include 'COMMON.TORCNSTR'
5700       logical lprn
5701 C Set lprn=.true. for debugging
5702       lprn=.false.
5703 c     lprn=.true.
5704       etors_d=0.0D0
5705 c      write(iout,*) "a tu??"
5706       do i=iphid_start,iphid_end
5707         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5708      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5709         itori=itortyp(itype(i-2))
5710         itori1=itortyp(itype(i-1))
5711         itori2=itortyp(itype(i))
5712         phii=phi(i)
5713         phii1=phi(i+1)
5714         gloci1=0.0D0
5715         gloci2=0.0D0
5716         iblock=1
5717         if (iabs(itype(i+1)).eq.20) iblock=2
5718
5719 C Regular cosine and sine terms
5720         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5721           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5722           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5723           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5724           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5725           cosphi1=dcos(j*phii)
5726           sinphi1=dsin(j*phii)
5727           cosphi2=dcos(j*phii1)
5728           sinphi2=dsin(j*phii1)
5729           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5730      &     v2cij*cosphi2+v2sij*sinphi2
5731           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5732           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5733         enddo
5734         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5735           do l=1,k-1
5736             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5737             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5738             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5739             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5740             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5741             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5742             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5743             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5744             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5745      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5746             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5747      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5748             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5749      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5750           enddo
5751         enddo
5752         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5753         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5754       enddo
5755       return
5756       end
5757 #endif
5758 c------------------------------------------------------------------------------
5759       subroutine eback_sc_corr(esccor)
5760 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5761 c        conformational states; temporarily implemented as differences
5762 c        between UNRES torsional potentials (dependent on three types of
5763 c        residues) and the torsional potentials dependent on all 20 types
5764 c        of residues computed from AM1  energy surfaces of terminally-blocked
5765 c        amino-acid residues.
5766       implicit real*8 (a-h,o-z)
5767       include 'DIMENSIONS'
5768       include 'COMMON.VAR'
5769       include 'COMMON.GEO'
5770       include 'COMMON.LOCAL'
5771       include 'COMMON.TORSION'
5772       include 'COMMON.SCCOR'
5773       include 'COMMON.INTERACT'
5774       include 'COMMON.DERIV'
5775       include 'COMMON.CHAIN'
5776       include 'COMMON.NAMES'
5777       include 'COMMON.IOUNITS'
5778       include 'COMMON.FFIELD'
5779       include 'COMMON.CONTROL'
5780       logical lprn
5781 C Set lprn=.true. for debugging
5782       lprn=.false.
5783 c      lprn=.true.
5784 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5785       esccor=0.0D0
5786       do i=itau_start,itau_end
5787         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5788         esccor_ii=0.0D0
5789         isccori=isccortyp(itype(i-2))
5790         isccori1=isccortyp(itype(i-1))
5791 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5792         phii=phi(i)
5793         do intertyp=1,3 !intertyp
5794 cc Added 09 May 2012 (Adasko)
5795 cc  Intertyp means interaction type of backbone mainchain correlation:
5796 c   1 = SC...Ca...Ca...Ca
5797 c   2 = Ca...Ca...Ca...SC
5798 c   3 = SC...Ca...Ca...SCi
5799         gloci=0.0D0
5800         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5801      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5802      &      (itype(i-1).eq.ntyp1)))
5803      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5804      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5805      &     .or.(itype(i).eq.ntyp1)))
5806      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5807      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5808      &      (itype(i-3).eq.ntyp1)))) cycle
5809         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5810         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5811      & cycle
5812        do j=1,nterm_sccor(isccori,isccori1)
5813           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5814           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5815           cosphi=dcos(j*tauangle(intertyp,i))
5816           sinphi=dsin(j*tauangle(intertyp,i))
5817           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5818           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5819         enddo
5820 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5821         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5822         if (lprn)
5823      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5824      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5825      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5826      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5827         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5828        enddo !intertyp
5829       enddo
5830
5831       return
5832       end
5833 c----------------------------------------------------------------------------
5834       subroutine multibody(ecorr)
5835 C This subroutine calculates multi-body contributions to energy following
5836 C the idea of Skolnick et al. If side chains I and J make a contact and
5837 C at the same time side chains I+1 and J+1 make a contact, an extra
5838 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5839       implicit real*8 (a-h,o-z)
5840       include 'DIMENSIONS'
5841       include 'COMMON.IOUNITS'
5842       include 'COMMON.DERIV'
5843       include 'COMMON.INTERACT'
5844       include 'COMMON.CONTACTS'
5845       double precision gx(3),gx1(3)
5846       logical lprn
5847
5848 C Set lprn=.true. for debugging
5849       lprn=.false.
5850
5851       if (lprn) then
5852         write (iout,'(a)') 'Contact function values:'
5853         do i=nnt,nct-2
5854           write (iout,'(i2,20(1x,i2,f10.5))')
5855      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5856         enddo
5857       endif
5858       ecorr=0.0D0
5859       do i=nnt,nct
5860         do j=1,3
5861           gradcorr(j,i)=0.0D0
5862           gradxorr(j,i)=0.0D0
5863         enddo
5864       enddo
5865       do i=nnt,nct-2
5866
5867         DO ISHIFT = 3,4
5868
5869         i1=i+ishift
5870         num_conti=num_cont(i)
5871         num_conti1=num_cont(i1)
5872         do jj=1,num_conti
5873           j=jcont(jj,i)
5874           do kk=1,num_conti1
5875             j1=jcont(kk,i1)
5876             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5877 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5878 cd   &                   ' ishift=',ishift
5879 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5880 C The system gains extra energy.
5881               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5882             endif   ! j1==j+-ishift
5883           enddo     ! kk
5884         enddo       ! jj
5885
5886         ENDDO ! ISHIFT
5887
5888       enddo         ! i
5889       return
5890       end
5891 c------------------------------------------------------------------------------
5892       double precision function esccorr(i,j,k,l,jj,kk)
5893       implicit real*8 (a-h,o-z)
5894       include 'DIMENSIONS'
5895       include 'COMMON.IOUNITS'
5896       include 'COMMON.DERIV'
5897       include 'COMMON.INTERACT'
5898       include 'COMMON.CONTACTS'
5899       double precision gx(3),gx1(3)
5900       logical lprn
5901       lprn=.false.
5902       eij=facont(jj,i)
5903       ekl=facont(kk,k)
5904 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5905 C Calculate the multi-body contribution to energy.
5906 C Calculate multi-body contributions to the gradient.
5907 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5908 cd   & k,l,(gacont(m,kk,k),m=1,3)
5909       do m=1,3
5910         gx(m) =ekl*gacont(m,jj,i)
5911         gx1(m)=eij*gacont(m,kk,k)
5912         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5913         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5914         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5915         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5916       enddo
5917       do m=i,j-1
5918         do ll=1,3
5919           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5920         enddo
5921       enddo
5922       do m=k,l-1
5923         do ll=1,3
5924           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5925         enddo
5926       enddo
5927       esccorr=-eij*ekl
5928       return
5929       end
5930 c------------------------------------------------------------------------------
5931       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5932 C This subroutine calculates multi-body contributions to hydrogen-bonding
5933       implicit real*8 (a-h,o-z)
5934       include 'DIMENSIONS'
5935       include 'COMMON.IOUNITS'
5936 #ifdef MPI
5937       include "mpif.h"
5938       parameter (max_cont=maxconts)
5939       parameter (max_dim=26)
5940       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5941       double precision zapas(max_dim,maxconts,max_fg_procs),
5942      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5943       common /przechowalnia/ zapas
5944       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5945      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5946 #endif
5947       include 'COMMON.SETUP'
5948       include 'COMMON.FFIELD'
5949       include 'COMMON.DERIV'
5950       include 'COMMON.INTERACT'
5951       include 'COMMON.CONTACTS'
5952       include 'COMMON.CONTROL'
5953       include 'COMMON.LOCAL'
5954       double precision gx(3),gx1(3),time00
5955       logical lprn,ldone
5956
5957 C Set lprn=.true. for debugging
5958       lprn=.false.
5959 #ifdef MPI
5960       n_corr=0
5961       n_corr1=0
5962       if (nfgtasks.le.1) goto 30
5963       if (lprn) then
5964         write (iout,'(a)') 'Contact function values before RECEIVE:'
5965         do i=nnt,nct-2
5966           write (iout,'(2i3,50(1x,i2,f5.2))')
5967      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5968      &    j=1,num_cont_hb(i))
5969         enddo
5970       endif
5971       call flush(iout)
5972       do i=1,ntask_cont_from
5973         ncont_recv(i)=0
5974       enddo
5975       do i=1,ntask_cont_to
5976         ncont_sent(i)=0
5977       enddo
5978 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5979 c     & ntask_cont_to
5980 C Make the list of contacts to send to send to other procesors
5981 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5982 c      call flush(iout)
5983       do i=iturn3_start,iturn3_end
5984 c        write (iout,*) "make contact list turn3",i," num_cont",
5985 c     &    num_cont_hb(i)
5986         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5987       enddo
5988       do i=iturn4_start,iturn4_end
5989 c        write (iout,*) "make contact list turn4",i," num_cont",
5990 c     &   num_cont_hb(i)
5991         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5992       enddo
5993       do ii=1,nat_sent
5994         i=iat_sent(ii)
5995 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5996 c     &    num_cont_hb(i)
5997         do j=1,num_cont_hb(i)
5998         do k=1,4
5999           jjc=jcont_hb(j,i)
6000           iproc=iint_sent_local(k,jjc,ii)
6001 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6002           if (iproc.gt.0) then
6003             ncont_sent(iproc)=ncont_sent(iproc)+1
6004             nn=ncont_sent(iproc)
6005             zapas(1,nn,iproc)=i
6006             zapas(2,nn,iproc)=jjc
6007             zapas(3,nn,iproc)=facont_hb(j,i)
6008             zapas(4,nn,iproc)=ees0p(j,i)
6009             zapas(5,nn,iproc)=ees0m(j,i)
6010             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6011             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6012             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6013             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6014             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6015             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6016             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6017             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6018             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6019             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6020             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6021             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6022             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6023             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6024             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6025             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6026             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6027             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6028             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6029             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6030             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6031           endif
6032         enddo
6033         enddo
6034       enddo
6035       if (lprn) then
6036       write (iout,*)
6037      &  "Numbers of contacts to be sent to other processors",
6038      &  (ncont_sent(i),i=1,ntask_cont_to)
6039       write (iout,*) "Contacts sent"
6040       do ii=1,ntask_cont_to
6041         nn=ncont_sent(ii)
6042         iproc=itask_cont_to(ii)
6043         write (iout,*) nn," contacts to processor",iproc,
6044      &   " of CONT_TO_COMM group"
6045         do i=1,nn
6046           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6047         enddo
6048       enddo
6049       call flush(iout)
6050       endif
6051       CorrelType=477
6052       CorrelID=fg_rank+1
6053       CorrelType1=478
6054       CorrelID1=nfgtasks+fg_rank+1
6055       ireq=0
6056 C Receive the numbers of needed contacts from other processors
6057       do ii=1,ntask_cont_from
6058         iproc=itask_cont_from(ii)
6059         ireq=ireq+1
6060         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6061      &    FG_COMM,req(ireq),IERR)
6062       enddo
6063 c      write (iout,*) "IRECV ended"
6064 c      call flush(iout)
6065 C Send the number of contacts needed by other processors
6066       do ii=1,ntask_cont_to
6067         iproc=itask_cont_to(ii)
6068         ireq=ireq+1
6069         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6070      &    FG_COMM,req(ireq),IERR)
6071       enddo
6072 c      write (iout,*) "ISEND ended"
6073 c      write (iout,*) "number of requests (nn)",ireq
6074       call flush(iout)
6075       if (ireq.gt.0)
6076      &  call MPI_Waitall(ireq,req,status_array,ierr)
6077 c      write (iout,*)
6078 c     &  "Numbers of contacts to be received from other processors",
6079 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6080 c      call flush(iout)
6081 C Receive contacts
6082       ireq=0
6083       do ii=1,ntask_cont_from
6084         iproc=itask_cont_from(ii)
6085         nn=ncont_recv(ii)
6086 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6087 c     &   " of CONT_TO_COMM group"
6088         call flush(iout)
6089         if (nn.gt.0) then
6090           ireq=ireq+1
6091           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6092      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6093 c          write (iout,*) "ireq,req",ireq,req(ireq)
6094         endif
6095       enddo
6096 C Send the contacts to processors that need them
6097       do ii=1,ntask_cont_to
6098         iproc=itask_cont_to(ii)
6099         nn=ncont_sent(ii)
6100 c        write (iout,*) nn," contacts to processor",iproc,
6101 c     &   " of CONT_TO_COMM group"
6102         if (nn.gt.0) then
6103           ireq=ireq+1
6104           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6105      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6106 c          write (iout,*) "ireq,req",ireq,req(ireq)
6107 c          do i=1,nn
6108 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6109 c          enddo
6110         endif
6111       enddo
6112 c      write (iout,*) "number of requests (contacts)",ireq
6113 c      write (iout,*) "req",(req(i),i=1,4)
6114 c      call flush(iout)
6115       if (ireq.gt.0)
6116      & call MPI_Waitall(ireq,req,status_array,ierr)
6117       do iii=1,ntask_cont_from
6118         iproc=itask_cont_from(iii)
6119         nn=ncont_recv(iii)
6120         if (lprn) then
6121         write (iout,*) "Received",nn," contacts from processor",iproc,
6122      &   " of CONT_FROM_COMM group"
6123         call flush(iout)
6124         do i=1,nn
6125           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6126         enddo
6127         call flush(iout)
6128         endif
6129         do i=1,nn
6130           ii=zapas_recv(1,i,iii)
6131 c Flag the received contacts to prevent double-counting
6132           jj=-zapas_recv(2,i,iii)
6133 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6134 c          call flush(iout)
6135           nnn=num_cont_hb(ii)+1
6136           num_cont_hb(ii)=nnn
6137           jcont_hb(nnn,ii)=jj
6138           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6139           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6140           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6141           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6142           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6143           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6144           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6145           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6146           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6147           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6148           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6149           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6150           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6151           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6152           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6153           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6154           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6155           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6156           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6157           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6158           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6159           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6160           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6161           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6162         enddo
6163       enddo
6164       call flush(iout)
6165       if (lprn) then
6166         write (iout,'(a)') 'Contact function values after receive:'
6167         do i=nnt,nct-2
6168           write (iout,'(2i3,50(1x,i3,f5.2))')
6169      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6170      &    j=1,num_cont_hb(i))
6171         enddo
6172         call flush(iout)
6173       endif
6174    30 continue
6175 #endif
6176       if (lprn) then
6177         write (iout,'(a)') 'Contact function values:'
6178         do i=nnt,nct-2
6179           write (iout,'(2i3,50(1x,i3,f5.2))')
6180      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6181      &    j=1,num_cont_hb(i))
6182         enddo
6183       endif
6184       ecorr=0.0D0
6185 C Remove the loop below after debugging !!!
6186       do i=nnt,nct
6187         do j=1,3
6188           gradcorr(j,i)=0.0D0
6189           gradxorr(j,i)=0.0D0
6190         enddo
6191       enddo
6192 C Calculate the local-electrostatic correlation terms
6193       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6194         i1=i+1
6195         num_conti=num_cont_hb(i)
6196         num_conti1=num_cont_hb(i+1)
6197         do jj=1,num_conti
6198           j=jcont_hb(jj,i)
6199           jp=iabs(j)
6200           do kk=1,num_conti1
6201             j1=jcont_hb(kk,i1)
6202             jp1=iabs(j1)
6203 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6204 c     &         ' jj=',jj,' kk=',kk
6205             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6206      &          .or. j.lt.0 .and. j1.gt.0) .and.
6207      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6208 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6209 C The system gains extra energy.
6210               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6211               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6212      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6213               n_corr=n_corr+1
6214             else if (j1.eq.j) then
6215 C Contacts I-J and I-(J+1) occur simultaneously.
6216 C The system loses extra energy.
6217 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6218             endif
6219           enddo ! kk
6220           do kk=1,num_conti
6221             j1=jcont_hb(kk,i)
6222 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6223 c    &         ' jj=',jj,' kk=',kk
6224             if (j1.eq.j+1) then
6225 C Contacts I-J and (I+1)-J occur simultaneously.
6226 C The system loses extra energy.
6227 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6228             endif ! j1==j+1
6229           enddo ! kk
6230         enddo ! jj
6231       enddo ! i
6232       return
6233       end
6234 c------------------------------------------------------------------------------
6235       subroutine add_hb_contact(ii,jj,itask)
6236       implicit real*8 (a-h,o-z)
6237       include "DIMENSIONS"
6238       include "COMMON.IOUNITS"
6239       integer max_cont
6240       integer max_dim
6241       parameter (max_cont=maxconts)
6242       parameter (max_dim=26)
6243       include "COMMON.CONTACTS"
6244       double precision zapas(max_dim,maxconts,max_fg_procs),
6245      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6246       common /przechowalnia/ zapas
6247       integer i,j,ii,jj,iproc,itask(4),nn
6248 c      write (iout,*) "itask",itask
6249       do i=1,2
6250         iproc=itask(i)
6251         if (iproc.gt.0) then
6252           do j=1,num_cont_hb(ii)
6253             jjc=jcont_hb(j,ii)
6254 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6255             if (jjc.eq.jj) then
6256               ncont_sent(iproc)=ncont_sent(iproc)+1
6257               nn=ncont_sent(iproc)
6258               zapas(1,nn,iproc)=ii
6259               zapas(2,nn,iproc)=jjc
6260               zapas(3,nn,iproc)=facont_hb(j,ii)
6261               zapas(4,nn,iproc)=ees0p(j,ii)
6262               zapas(5,nn,iproc)=ees0m(j,ii)
6263               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6264               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6265               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6266               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6267               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6268               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6269               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6270               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6271               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6272               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6273               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6274               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6275               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6276               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6277               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6278               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6279               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6280               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6281               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6282               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6283               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6284               exit
6285             endif
6286           enddo
6287         endif
6288       enddo
6289       return
6290       end
6291 c------------------------------------------------------------------------------
6292       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6293      &  n_corr1)
6294 C This subroutine calculates multi-body contributions to hydrogen-bonding
6295       implicit real*8 (a-h,o-z)
6296       include 'DIMENSIONS'
6297       include 'COMMON.IOUNITS'
6298 #ifdef MPI
6299       include "mpif.h"
6300       parameter (max_cont=maxconts)
6301       parameter (max_dim=70)
6302       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6303       double precision zapas(max_dim,maxconts,max_fg_procs),
6304      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6305       common /przechowalnia/ zapas
6306       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6307      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6308 #endif
6309       include 'COMMON.SETUP'
6310       include 'COMMON.FFIELD'
6311       include 'COMMON.DERIV'
6312       include 'COMMON.LOCAL'
6313       include 'COMMON.INTERACT'
6314       include 'COMMON.CONTACTS'
6315       include 'COMMON.CHAIN'
6316       include 'COMMON.CONTROL'
6317       double precision gx(3),gx1(3)
6318       integer num_cont_hb_old(maxres)
6319       logical lprn,ldone
6320       double precision eello4,eello5,eelo6,eello_turn6
6321       external eello4,eello5,eello6,eello_turn6
6322 C Set lprn=.true. for debugging
6323       lprn=.false.
6324       eturn6=0.0d0
6325 #ifdef MPI
6326       do i=1,nres
6327         num_cont_hb_old(i)=num_cont_hb(i)
6328       enddo
6329       n_corr=0
6330       n_corr1=0
6331       if (nfgtasks.le.1) goto 30
6332       if (lprn) then
6333         write (iout,'(a)') 'Contact function values before RECEIVE:'
6334         do i=nnt,nct-2
6335           write (iout,'(2i3,50(1x,i2,f5.2))')
6336      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6337      &    j=1,num_cont_hb(i))
6338         enddo
6339       endif
6340       call flush(iout)
6341       do i=1,ntask_cont_from
6342         ncont_recv(i)=0
6343       enddo
6344       do i=1,ntask_cont_to
6345         ncont_sent(i)=0
6346       enddo
6347 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6348 c     & ntask_cont_to
6349 C Make the list of contacts to send to send to other procesors
6350       do i=iturn3_start,iturn3_end
6351 c        write (iout,*) "make contact list turn3",i," num_cont",
6352 c     &    num_cont_hb(i)
6353         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6354       enddo
6355       do i=iturn4_start,iturn4_end
6356 c        write (iout,*) "make contact list turn4",i," num_cont",
6357 c     &   num_cont_hb(i)
6358         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6359       enddo
6360       do ii=1,nat_sent
6361         i=iat_sent(ii)
6362 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6363 c     &    num_cont_hb(i)
6364         do j=1,num_cont_hb(i)
6365         do k=1,4
6366           jjc=jcont_hb(j,i)
6367           iproc=iint_sent_local(k,jjc,ii)
6368 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6369           if (iproc.ne.0) then
6370             ncont_sent(iproc)=ncont_sent(iproc)+1
6371             nn=ncont_sent(iproc)
6372             zapas(1,nn,iproc)=i
6373             zapas(2,nn,iproc)=jjc
6374             zapas(3,nn,iproc)=d_cont(j,i)
6375             ind=3
6376             do kk=1,3
6377               ind=ind+1
6378               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6379             enddo
6380             do kk=1,2
6381               do ll=1,2
6382                 ind=ind+1
6383                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6384               enddo
6385             enddo
6386             do jj=1,5
6387               do kk=1,3
6388                 do ll=1,2
6389                   do mm=1,2
6390                     ind=ind+1
6391                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6392                   enddo
6393                 enddo
6394               enddo
6395             enddo
6396           endif
6397         enddo
6398         enddo
6399       enddo
6400       if (lprn) then
6401       write (iout,*)
6402      &  "Numbers of contacts to be sent to other processors",
6403      &  (ncont_sent(i),i=1,ntask_cont_to)
6404       write (iout,*) "Contacts sent"
6405       do ii=1,ntask_cont_to
6406         nn=ncont_sent(ii)
6407         iproc=itask_cont_to(ii)
6408         write (iout,*) nn," contacts to processor",iproc,
6409      &   " of CONT_TO_COMM group"
6410         do i=1,nn
6411           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6412         enddo
6413       enddo
6414       call flush(iout)
6415       endif
6416       CorrelType=477
6417       CorrelID=fg_rank+1
6418       CorrelType1=478
6419       CorrelID1=nfgtasks+fg_rank+1
6420       ireq=0
6421 C Receive the numbers of needed contacts from other processors
6422       do ii=1,ntask_cont_from
6423         iproc=itask_cont_from(ii)
6424         ireq=ireq+1
6425         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6426      &    FG_COMM,req(ireq),IERR)
6427       enddo
6428 c      write (iout,*) "IRECV ended"
6429 c      call flush(iout)
6430 C Send the number of contacts needed by other processors
6431       do ii=1,ntask_cont_to
6432         iproc=itask_cont_to(ii)
6433         ireq=ireq+1
6434         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6435      &    FG_COMM,req(ireq),IERR)
6436       enddo
6437 c      write (iout,*) "ISEND ended"
6438 c      write (iout,*) "number of requests (nn)",ireq
6439       call flush(iout)
6440       if (ireq.gt.0)
6441      &  call MPI_Waitall(ireq,req,status_array,ierr)
6442 c      write (iout,*)
6443 c     &  "Numbers of contacts to be received from other processors",
6444 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6445 c      call flush(iout)
6446 C Receive contacts
6447       ireq=0
6448       do ii=1,ntask_cont_from
6449         iproc=itask_cont_from(ii)
6450         nn=ncont_recv(ii)
6451 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6452 c     &   " of CONT_TO_COMM group"
6453         call flush(iout)
6454         if (nn.gt.0) then
6455           ireq=ireq+1
6456           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6457      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6458 c          write (iout,*) "ireq,req",ireq,req(ireq)
6459         endif
6460       enddo
6461 C Send the contacts to processors that need them
6462       do ii=1,ntask_cont_to
6463         iproc=itask_cont_to(ii)
6464         nn=ncont_sent(ii)
6465 c        write (iout,*) nn," contacts to processor",iproc,
6466 c     &   " of CONT_TO_COMM group"
6467         if (nn.gt.0) then
6468           ireq=ireq+1
6469           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6470      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6471 c          write (iout,*) "ireq,req",ireq,req(ireq)
6472 c          do i=1,nn
6473 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6474 c          enddo
6475         endif
6476       enddo
6477 c      write (iout,*) "number of requests (contacts)",ireq
6478 c      write (iout,*) "req",(req(i),i=1,4)
6479 c      call flush(iout)
6480       if (ireq.gt.0)
6481      & call MPI_Waitall(ireq,req,status_array,ierr)
6482       do iii=1,ntask_cont_from
6483         iproc=itask_cont_from(iii)
6484         nn=ncont_recv(iii)
6485         if (lprn) then
6486         write (iout,*) "Received",nn," contacts from processor",iproc,
6487      &   " of CONT_FROM_COMM group"
6488         call flush(iout)
6489         do i=1,nn
6490           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6491         enddo
6492         call flush(iout)
6493         endif
6494         do i=1,nn
6495           ii=zapas_recv(1,i,iii)
6496 c Flag the received contacts to prevent double-counting
6497           jj=-zapas_recv(2,i,iii)
6498 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6499 c          call flush(iout)
6500           nnn=num_cont_hb(ii)+1
6501           num_cont_hb(ii)=nnn
6502           jcont_hb(nnn,ii)=jj
6503           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6504           ind=3
6505           do kk=1,3
6506             ind=ind+1
6507             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6508           enddo
6509           do kk=1,2
6510             do ll=1,2
6511               ind=ind+1
6512               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6513             enddo
6514           enddo
6515           do jj=1,5
6516             do kk=1,3
6517               do ll=1,2
6518                 do mm=1,2
6519                   ind=ind+1
6520                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6521                 enddo
6522               enddo
6523             enddo
6524           enddo
6525         enddo
6526       enddo
6527       call flush(iout)
6528       if (lprn) then
6529         write (iout,'(a)') 'Contact function values after receive:'
6530         do i=nnt,nct-2
6531           write (iout,'(2i3,50(1x,i3,5f6.3))')
6532      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6533      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6534         enddo
6535         call flush(iout)
6536       endif
6537    30 continue
6538 #endif
6539       if (lprn) then
6540         write (iout,'(a)') 'Contact function values:'
6541         do i=nnt,nct-2
6542           write (iout,'(2i3,50(1x,i2,5f6.3))')
6543      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6544      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6545         enddo
6546       endif
6547       ecorr=0.0D0
6548       ecorr5=0.0d0
6549       ecorr6=0.0d0
6550 C Remove the loop below after debugging !!!
6551       do i=nnt,nct
6552         do j=1,3
6553           gradcorr(j,i)=0.0D0
6554           gradxorr(j,i)=0.0D0
6555         enddo
6556       enddo
6557 C Calculate the dipole-dipole interaction energies
6558       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6559       do i=iatel_s,iatel_e+1
6560         num_conti=num_cont_hb(i)
6561         do jj=1,num_conti
6562           j=jcont_hb(jj,i)
6563 #ifdef MOMENT
6564           call dipole(i,j,jj)
6565 #endif
6566         enddo
6567       enddo
6568       endif
6569 C Calculate the local-electrostatic correlation terms
6570 c                write (iout,*) "gradcorr5 in eello5 before loop"
6571 c                do iii=1,nres
6572 c                  write (iout,'(i5,3f10.5)')
6573 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6574 c                enddo
6575       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6576 c        write (iout,*) "corr loop i",i
6577         i1=i+1
6578         num_conti=num_cont_hb(i)
6579         num_conti1=num_cont_hb(i+1)
6580         do jj=1,num_conti
6581           j=jcont_hb(jj,i)
6582           jp=iabs(j)
6583           do kk=1,num_conti1
6584             j1=jcont_hb(kk,i1)
6585             jp1=iabs(j1)
6586 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6587 c     &         ' jj=',jj,' kk=',kk
6588 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6589             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6590      &          .or. j.lt.0 .and. j1.gt.0) .and.
6591      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6592 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6593 C The system gains extra energy.
6594               n_corr=n_corr+1
6595               sqd1=dsqrt(d_cont(jj,i))
6596               sqd2=dsqrt(d_cont(kk,i1))
6597               sred_geom = sqd1*sqd2
6598               IF (sred_geom.lt.cutoff_corr) THEN
6599                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6600      &            ekont,fprimcont)
6601 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6602 cd     &         ' jj=',jj,' kk=',kk
6603                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6604                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6605                 do l=1,3
6606                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6607                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6608                 enddo
6609                 n_corr1=n_corr1+1
6610 cd               write (iout,*) 'sred_geom=',sred_geom,
6611 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6612 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6613 cd               write (iout,*) "g_contij",g_contij
6614 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6615 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6616                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6617                 if (wcorr4.gt.0.0d0)
6618      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6619                   if (energy_dec.and.wcorr4.gt.0.0d0)
6620      1                 write (iout,'(a6,4i5,0pf7.3)')
6621      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6622 c                write (iout,*) "gradcorr5 before eello5"
6623 c                do iii=1,nres
6624 c                  write (iout,'(i5,3f10.5)')
6625 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6626 c                enddo
6627                 if (wcorr5.gt.0.0d0)
6628      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6629 c                write (iout,*) "gradcorr5 after eello5"
6630 c                do iii=1,nres
6631 c                  write (iout,'(i5,3f10.5)')
6632 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6633 c                enddo
6634                   if (energy_dec.and.wcorr5.gt.0.0d0)
6635      1                 write (iout,'(a6,4i5,0pf7.3)')
6636      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6637 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6638 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6639                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6640      &               .or. wturn6.eq.0.0d0))then
6641 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6642                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6643                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6644      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6645 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6646 cd     &            'ecorr6=',ecorr6
6647 cd                write (iout,'(4e15.5)') sred_geom,
6648 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6649 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6650 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6651                 else if (wturn6.gt.0.0d0
6652      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6653 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6654                   eturn6=eturn6+eello_turn6(i,jj,kk)
6655                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6656      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6657 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6658                 endif
6659               ENDIF
6660 1111          continue
6661             endif
6662           enddo ! kk
6663         enddo ! jj
6664       enddo ! i
6665       do i=1,nres
6666         num_cont_hb(i)=num_cont_hb_old(i)
6667       enddo
6668 c                write (iout,*) "gradcorr5 in eello5"
6669 c                do iii=1,nres
6670 c                  write (iout,'(i5,3f10.5)')
6671 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6672 c                enddo
6673       return
6674       end
6675 c------------------------------------------------------------------------------
6676       subroutine add_hb_contact_eello(ii,jj,itask)
6677       implicit real*8 (a-h,o-z)
6678       include "DIMENSIONS"
6679       include "COMMON.IOUNITS"
6680       integer max_cont
6681       integer max_dim
6682       parameter (max_cont=maxconts)
6683       parameter (max_dim=70)
6684       include "COMMON.CONTACTS"
6685       double precision zapas(max_dim,maxconts,max_fg_procs),
6686      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6687       common /przechowalnia/ zapas
6688       integer i,j,ii,jj,iproc,itask(4),nn
6689 c      write (iout,*) "itask",itask
6690       do i=1,2
6691         iproc=itask(i)
6692         if (iproc.gt.0) then
6693           do j=1,num_cont_hb(ii)
6694             jjc=jcont_hb(j,ii)
6695 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6696             if (jjc.eq.jj) then
6697               ncont_sent(iproc)=ncont_sent(iproc)+1
6698               nn=ncont_sent(iproc)
6699               zapas(1,nn,iproc)=ii
6700               zapas(2,nn,iproc)=jjc
6701               zapas(3,nn,iproc)=d_cont(j,ii)
6702               ind=3
6703               do kk=1,3
6704                 ind=ind+1
6705                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6706               enddo
6707               do kk=1,2
6708                 do ll=1,2
6709                   ind=ind+1
6710                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6711                 enddo
6712               enddo
6713               do jj=1,5
6714                 do kk=1,3
6715                   do ll=1,2
6716                     do mm=1,2
6717                       ind=ind+1
6718                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6719                     enddo
6720                   enddo
6721                 enddo
6722               enddo
6723               exit
6724             endif
6725           enddo
6726         endif
6727       enddo
6728       return
6729       end
6730 c------------------------------------------------------------------------------
6731       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6732       implicit real*8 (a-h,o-z)
6733       include 'DIMENSIONS'
6734       include 'COMMON.IOUNITS'
6735       include 'COMMON.DERIV'
6736       include 'COMMON.INTERACT'
6737       include 'COMMON.CONTACTS'
6738       double precision gx(3),gx1(3)
6739       logical lprn
6740       lprn=.false.
6741       eij=facont_hb(jj,i)
6742       ekl=facont_hb(kk,k)
6743       ees0pij=ees0p(jj,i)
6744       ees0pkl=ees0p(kk,k)
6745       ees0mij=ees0m(jj,i)
6746       ees0mkl=ees0m(kk,k)
6747       ekont=eij*ekl
6748       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6749 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6750 C Following 4 lines for diagnostics.
6751 cd    ees0pkl=0.0D0
6752 cd    ees0pij=1.0D0
6753 cd    ees0mkl=0.0D0
6754 cd    ees0mij=1.0D0
6755 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6756 c     & 'Contacts ',i,j,
6757 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6758 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6759 c     & 'gradcorr_long'
6760 C Calculate the multi-body contribution to energy.
6761 c      ecorr=ecorr+ekont*ees
6762 C Calculate multi-body contributions to the gradient.
6763       coeffpees0pij=coeffp*ees0pij
6764       coeffmees0mij=coeffm*ees0mij
6765       coeffpees0pkl=coeffp*ees0pkl
6766       coeffmees0mkl=coeffm*ees0mkl
6767       do ll=1,3
6768 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6769         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6770      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6771      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6772         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6773      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6774      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6775 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6776         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6777      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6778      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6779         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6780      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6781      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6782         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6783      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6784      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6785         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6786         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6787         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6788      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6789      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6790         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6791         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6792 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6793       enddo
6794 c      write (iout,*)
6795 cgrad      do m=i+1,j-1
6796 cgrad        do ll=1,3
6797 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6798 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6799 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6800 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6801 cgrad        enddo
6802 cgrad      enddo
6803 cgrad      do m=k+1,l-1
6804 cgrad        do ll=1,3
6805 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6806 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6807 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6808 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6809 cgrad        enddo
6810 cgrad      enddo
6811 c      write (iout,*) "ehbcorr",ekont*ees
6812       ehbcorr=ekont*ees
6813       return
6814       end
6815 #ifdef MOMENT
6816 C---------------------------------------------------------------------------
6817       subroutine dipole(i,j,jj)
6818       implicit real*8 (a-h,o-z)
6819       include 'DIMENSIONS'
6820       include 'COMMON.IOUNITS'
6821       include 'COMMON.CHAIN'
6822       include 'COMMON.FFIELD'
6823       include 'COMMON.DERIV'
6824       include 'COMMON.INTERACT'
6825       include 'COMMON.CONTACTS'
6826       include 'COMMON.TORSION'
6827       include 'COMMON.VAR'
6828       include 'COMMON.GEO'
6829       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6830      &  auxmat(2,2)
6831       iti1 = itortyp(itype(i+1))
6832       if (j.lt.nres-1) then
6833         itj1 = itortyp(itype(j+1))
6834       else
6835         itj1=ntortyp+1
6836       endif
6837       do iii=1,2
6838         dipi(iii,1)=Ub2(iii,i)
6839         dipderi(iii)=Ub2der(iii,i)
6840         dipi(iii,2)=b1(iii,iti1)
6841         dipj(iii,1)=Ub2(iii,j)
6842         dipderj(iii)=Ub2der(iii,j)
6843         dipj(iii,2)=b1(iii,itj1)
6844       enddo
6845       kkk=0
6846       do iii=1,2
6847         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6848         do jjj=1,2
6849           kkk=kkk+1
6850           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6851         enddo
6852       enddo
6853       do kkk=1,5
6854         do lll=1,3
6855           mmm=0
6856           do iii=1,2
6857             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6858      &        auxvec(1))
6859             do jjj=1,2
6860               mmm=mmm+1
6861               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6862             enddo
6863           enddo
6864         enddo
6865       enddo
6866       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6867       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6868       do iii=1,2
6869         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6870       enddo
6871       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6872       do iii=1,2
6873         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6874       enddo
6875       return
6876       end
6877 #endif
6878 C---------------------------------------------------------------------------
6879       subroutine calc_eello(i,j,k,l,jj,kk)
6880 C
6881 C This subroutine computes matrices and vectors needed to calculate
6882 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6883 C
6884       implicit real*8 (a-h,o-z)
6885       include 'DIMENSIONS'
6886       include 'COMMON.IOUNITS'
6887       include 'COMMON.CHAIN'
6888       include 'COMMON.DERIV'
6889       include 'COMMON.INTERACT'
6890       include 'COMMON.CONTACTS'
6891       include 'COMMON.TORSION'
6892       include 'COMMON.VAR'
6893       include 'COMMON.GEO'
6894       include 'COMMON.FFIELD'
6895       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6896      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6897       logical lprn
6898       common /kutas/ lprn
6899 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6900 cd     & ' jj=',jj,' kk=',kk
6901 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6902 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6903 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6904       do iii=1,2
6905         do jjj=1,2
6906           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6907           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6908         enddo
6909       enddo
6910       call transpose2(aa1(1,1),aa1t(1,1))
6911       call transpose2(aa2(1,1),aa2t(1,1))
6912       do kkk=1,5
6913         do lll=1,3
6914           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6915      &      aa1tder(1,1,lll,kkk))
6916           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6917      &      aa2tder(1,1,lll,kkk))
6918         enddo
6919       enddo
6920       if (l.eq.j+1) then
6921 C parallel orientation of the two CA-CA-CA frames.
6922         if (i.gt.1) then
6923           iti=itortyp(itype(i))
6924         else
6925           iti=ntortyp+1
6926         endif
6927         itk1=itortyp(itype(k+1))
6928         itj=itortyp(itype(j))
6929         if (l.lt.nres-1) then
6930           itl1=itortyp(itype(l+1))
6931         else
6932           itl1=ntortyp+1
6933         endif
6934 C A1 kernel(j+1) A2T
6935 cd        do iii=1,2
6936 cd          write (iout,'(3f10.5,5x,3f10.5)')
6937 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6938 cd        enddo
6939         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6940      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6941      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6942 C Following matrices are needed only for 6-th order cumulants
6943         IF (wcorr6.gt.0.0d0) THEN
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.,EUgC(1,1,l),EUgCder(1,1,l),
6946      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6947         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6948      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6949      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6950      &   ADtEAderx(1,1,1,1,1,1))
6951         lprn=.false.
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.,DtUg2EUg(1,1,l),
6954      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6955      &   ADtEA1derx(1,1,1,1,1,1))
6956         ENDIF
6957 C End 6-th order cumulants
6958 cd        lprn=.false.
6959 cd        if (lprn) then
6960 cd        write (2,*) 'In calc_eello6'
6961 cd        do iii=1,2
6962 cd          write (2,*) 'iii=',iii
6963 cd          do kkk=1,5
6964 cd            write (2,*) 'kkk=',kkk
6965 cd            do jjj=1,2
6966 cd              write (2,'(3(2f10.5),5x)')
6967 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6968 cd            enddo
6969 cd          enddo
6970 cd        enddo
6971 cd        endif
6972         call transpose2(EUgder(1,1,k),auxmat(1,1))
6973         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6974         call transpose2(EUg(1,1,k),auxmat(1,1))
6975         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6976         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6977         do iii=1,2
6978           do kkk=1,5
6979             do lll=1,3
6980               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6981      &          EAEAderx(1,1,lll,kkk,iii,1))
6982             enddo
6983           enddo
6984         enddo
6985 C A1T kernel(i+1) A2
6986         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6987      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6988      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6989 C Following matrices are needed only for 6-th order cumulants
6990         IF (wcorr6.gt.0.0d0) THEN
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.,EUgC(1,1,k),EUgCder(1,1,k),
6993      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6994         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6995      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6996      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6997      &   ADtEAderx(1,1,1,1,1,2))
6998         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6999      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7000      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7001      &   ADtEA1derx(1,1,1,1,1,2))
7002         ENDIF
7003 C End 6-th order cumulants
7004         call transpose2(EUgder(1,1,l),auxmat(1,1))
7005         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7006         call transpose2(EUg(1,1,l),auxmat(1,1))
7007         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7008         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7009         do iii=1,2
7010           do kkk=1,5
7011             do lll=1,3
7012               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7013      &          EAEAderx(1,1,lll,kkk,iii,2))
7014             enddo
7015           enddo
7016         enddo
7017 C AEAb1 and AEAb2
7018 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7019 C They are needed only when the fifth- or the sixth-order cumulants are
7020 C indluded.
7021         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7022         call transpose2(AEA(1,1,1),auxmat(1,1))
7023         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7024         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7025         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7026         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7027         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7028         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7029         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7030         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7031         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7032         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7033         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7034         call transpose2(AEA(1,1,2),auxmat(1,1))
7035         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7036         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7037         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7038         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7039         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7040         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7041         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7042         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7043         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7044         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7045         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7046 C Calculate the Cartesian derivatives of the vectors.
7047         do iii=1,2
7048           do kkk=1,5
7049             do lll=1,3
7050               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7051               call matvec2(auxmat(1,1),b1(1,iti),
7052      &          AEAb1derx(1,lll,kkk,iii,1,1))
7053               call matvec2(auxmat(1,1),Ub2(1,i),
7054      &          AEAb2derx(1,lll,kkk,iii,1,1))
7055               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7056      &          AEAb1derx(1,lll,kkk,iii,2,1))
7057               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7058      &          AEAb2derx(1,lll,kkk,iii,2,1))
7059               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7060               call matvec2(auxmat(1,1),b1(1,itj),
7061      &          AEAb1derx(1,lll,kkk,iii,1,2))
7062               call matvec2(auxmat(1,1),Ub2(1,j),
7063      &          AEAb2derx(1,lll,kkk,iii,1,2))
7064               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7065      &          AEAb1derx(1,lll,kkk,iii,2,2))
7066               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7067      &          AEAb2derx(1,lll,kkk,iii,2,2))
7068             enddo
7069           enddo
7070         enddo
7071         ENDIF
7072 C End vectors
7073       else
7074 C Antiparallel orientation of the two CA-CA-CA frames.
7075         if (i.gt.1) then
7076           iti=itortyp(itype(i))
7077         else
7078           iti=ntortyp+1
7079         endif
7080         itk1=itortyp(itype(k+1))
7081         itl=itortyp(itype(l))
7082         itj=itortyp(itype(j))
7083         if (j.lt.nres-1) then
7084           itj1=itortyp(itype(j+1))
7085         else
7086           itj1=ntortyp+1
7087         endif
7088 C A2 kernel(j-1)T A1T
7089         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7090      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7091      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7092 C Following matrices are needed only for 6-th order cumulants
7093         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7094      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7095         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7096      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7097      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7098         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7099      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7100      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7101      &   ADtEAderx(1,1,1,1,1,1))
7102         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7103      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7104      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7105      &   ADtEA1derx(1,1,1,1,1,1))
7106         ENDIF
7107 C End 6-th order cumulants
7108         call transpose2(EUgder(1,1,k),auxmat(1,1))
7109         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7110         call transpose2(EUg(1,1,k),auxmat(1,1))
7111         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7112         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7113         do iii=1,2
7114           do kkk=1,5
7115             do lll=1,3
7116               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7117      &          EAEAderx(1,1,lll,kkk,iii,1))
7118             enddo
7119           enddo
7120         enddo
7121 C A2T kernel(i+1)T A1
7122         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7123      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7124      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7125 C Following matrices are needed only for 6-th order cumulants
7126         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7127      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7128         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7129      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7130      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7131         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7132      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7133      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7134      &   ADtEAderx(1,1,1,1,1,2))
7135         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7136      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7137      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7138      &   ADtEA1derx(1,1,1,1,1,2))
7139         ENDIF
7140 C End 6-th order cumulants
7141         call transpose2(EUgder(1,1,j),auxmat(1,1))
7142         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7143         call transpose2(EUg(1,1,j),auxmat(1,1))
7144         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7145         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7146         do iii=1,2
7147           do kkk=1,5
7148             do lll=1,3
7149               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7150      &          EAEAderx(1,1,lll,kkk,iii,2))
7151             enddo
7152           enddo
7153         enddo
7154 C AEAb1 and AEAb2
7155 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7156 C They are needed only when the fifth- or the sixth-order cumulants are
7157 C indluded.
7158         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7159      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7160         call transpose2(AEA(1,1,1),auxmat(1,1))
7161         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7162         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7163         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7164         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7165         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7166         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7167         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7168         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7169         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7170         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7171         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7172         call transpose2(AEA(1,1,2),auxmat(1,1))
7173         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7174         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7175         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7176         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7177         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7178         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7179         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7180         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7181         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7182         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7183         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7184 C Calculate the Cartesian derivatives of the vectors.
7185         do iii=1,2
7186           do kkk=1,5
7187             do lll=1,3
7188               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7189               call matvec2(auxmat(1,1),b1(1,iti),
7190      &          AEAb1derx(1,lll,kkk,iii,1,1))
7191               call matvec2(auxmat(1,1),Ub2(1,i),
7192      &          AEAb2derx(1,lll,kkk,iii,1,1))
7193               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7194      &          AEAb1derx(1,lll,kkk,iii,2,1))
7195               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7196      &          AEAb2derx(1,lll,kkk,iii,2,1))
7197               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7198               call matvec2(auxmat(1,1),b1(1,itl),
7199      &          AEAb1derx(1,lll,kkk,iii,1,2))
7200               call matvec2(auxmat(1,1),Ub2(1,l),
7201      &          AEAb2derx(1,lll,kkk,iii,1,2))
7202               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7203      &          AEAb1derx(1,lll,kkk,iii,2,2))
7204               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7205      &          AEAb2derx(1,lll,kkk,iii,2,2))
7206             enddo
7207           enddo
7208         enddo
7209         ENDIF
7210 C End vectors
7211       endif
7212       return
7213       end
7214 C---------------------------------------------------------------------------
7215       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7216      &  KK,KKderg,AKA,AKAderg,AKAderx)
7217       implicit none
7218       integer nderg
7219       logical transp
7220       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7221      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7222      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7223       integer iii,kkk,lll
7224       integer jjj,mmm
7225       logical lprn
7226       common /kutas/ lprn
7227       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7228       do iii=1,nderg
7229         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7230      &    AKAderg(1,1,iii))
7231       enddo
7232 cd      if (lprn) write (2,*) 'In kernel'
7233       do kkk=1,5
7234 cd        if (lprn) write (2,*) 'kkk=',kkk
7235         do lll=1,3
7236           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7237      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7238 cd          if (lprn) then
7239 cd            write (2,*) 'lll=',lll
7240 cd            write (2,*) 'iii=1'
7241 cd            do jjj=1,2
7242 cd              write (2,'(3(2f10.5),5x)')
7243 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7244 cd            enddo
7245 cd          endif
7246           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7247      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7248 cd          if (lprn) then
7249 cd            write (2,*) 'lll=',lll
7250 cd            write (2,*) 'iii=2'
7251 cd            do jjj=1,2
7252 cd              write (2,'(3(2f10.5),5x)')
7253 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7254 cd            enddo
7255 cd          endif
7256         enddo
7257       enddo
7258       return
7259       end
7260 C---------------------------------------------------------------------------
7261       double precision function eello4(i,j,k,l,jj,kk)
7262       implicit real*8 (a-h,o-z)
7263       include 'DIMENSIONS'
7264       include 'COMMON.IOUNITS'
7265       include 'COMMON.CHAIN'
7266       include 'COMMON.DERIV'
7267       include 'COMMON.INTERACT'
7268       include 'COMMON.CONTACTS'
7269       include 'COMMON.TORSION'
7270       include 'COMMON.VAR'
7271       include 'COMMON.GEO'
7272       double precision pizda(2,2),ggg1(3),ggg2(3)
7273 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7274 cd        eello4=0.0d0
7275 cd        return
7276 cd      endif
7277 cd      print *,'eello4:',i,j,k,l,jj,kk
7278 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7279 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7280 cold      eij=facont_hb(jj,i)
7281 cold      ekl=facont_hb(kk,k)
7282 cold      ekont=eij*ekl
7283       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7284 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7285       gcorr_loc(k-1)=gcorr_loc(k-1)
7286      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7287       if (l.eq.j+1) then
7288         gcorr_loc(l-1)=gcorr_loc(l-1)
7289      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7290       else
7291         gcorr_loc(j-1)=gcorr_loc(j-1)
7292      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7293       endif
7294       do iii=1,2
7295         do kkk=1,5
7296           do lll=1,3
7297             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7298      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7299 cd            derx(lll,kkk,iii)=0.0d0
7300           enddo
7301         enddo
7302       enddo
7303 cd      gcorr_loc(l-1)=0.0d0
7304 cd      gcorr_loc(j-1)=0.0d0
7305 cd      gcorr_loc(k-1)=0.0d0
7306 cd      eel4=1.0d0
7307 cd      write (iout,*)'Contacts have occurred for peptide groups',
7308 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7309 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7310       if (j.lt.nres-1) then
7311         j1=j+1
7312         j2=j-1
7313       else
7314         j1=j-1
7315         j2=j-2
7316       endif
7317       if (l.lt.nres-1) then
7318         l1=l+1
7319         l2=l-1
7320       else
7321         l1=l-1
7322         l2=l-2
7323       endif
7324       do ll=1,3
7325 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7326 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7327         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7328         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7329 cgrad        ghalf=0.5d0*ggg1(ll)
7330         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7331         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7332         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7333         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7334         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7335         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7336 cgrad        ghalf=0.5d0*ggg2(ll)
7337         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7338         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7339         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7340         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7341         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7342         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7343       enddo
7344 cgrad      do m=i+1,j-1
7345 cgrad        do ll=1,3
7346 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7347 cgrad        enddo
7348 cgrad      enddo
7349 cgrad      do m=k+1,l-1
7350 cgrad        do ll=1,3
7351 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7352 cgrad        enddo
7353 cgrad      enddo
7354 cgrad      do m=i+2,j2
7355 cgrad        do ll=1,3
7356 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7357 cgrad        enddo
7358 cgrad      enddo
7359 cgrad      do m=k+2,l2
7360 cgrad        do ll=1,3
7361 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7362 cgrad        enddo
7363 cgrad      enddo
7364 cd      do iii=1,nres-3
7365 cd        write (2,*) iii,gcorr_loc(iii)
7366 cd      enddo
7367       eello4=ekont*eel4
7368 cd      write (2,*) 'ekont',ekont
7369 cd      write (iout,*) 'eello4',ekont*eel4
7370       return
7371       end
7372 C---------------------------------------------------------------------------
7373       double precision function eello5(i,j,k,l,jj,kk)
7374       implicit real*8 (a-h,o-z)
7375       include 'DIMENSIONS'
7376       include 'COMMON.IOUNITS'
7377       include 'COMMON.CHAIN'
7378       include 'COMMON.DERIV'
7379       include 'COMMON.INTERACT'
7380       include 'COMMON.CONTACTS'
7381       include 'COMMON.TORSION'
7382       include 'COMMON.VAR'
7383       include 'COMMON.GEO'
7384       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7385       double precision ggg1(3),ggg2(3)
7386 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7387 C                                                                              C
7388 C                            Parallel chains                                   C
7389 C                                                                              C
7390 C          o             o                   o             o                   C
7391 C         /l\           / \             \   / \           / \   /              C
7392 C        /   \         /   \             \ /   \         /   \ /               C
7393 C       j| o |l1       | o |              o| o |         | o |o                C
7394 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7395 C      \i/   \         /   \ /             /   \         /   \                 C
7396 C       o    k1             o                                                  C
7397 C         (I)          (II)                (III)          (IV)                 C
7398 C                                                                              C
7399 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7400 C                                                                              C
7401 C                            Antiparallel chains                               C
7402 C                                                                              C
7403 C          o             o                   o             o                   C
7404 C         /j\           / \             \   / \           / \   /              C
7405 C        /   \         /   \             \ /   \         /   \ /               C
7406 C      j1| o |l        | o |              o| o |         | o |o                C
7407 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7408 C      \i/   \         /   \ /             /   \         /   \                 C
7409 C       o     k1            o                                                  C
7410 C         (I)          (II)                (III)          (IV)                 C
7411 C                                                                              C
7412 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7413 C                                                                              C
7414 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7415 C                                                                              C
7416 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7417 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7418 cd        eello5=0.0d0
7419 cd        return
7420 cd      endif
7421 cd      write (iout,*)
7422 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7423 cd     &   ' and',k,l
7424       itk=itortyp(itype(k))
7425       itl=itortyp(itype(l))
7426       itj=itortyp(itype(j))
7427       eello5_1=0.0d0
7428       eello5_2=0.0d0
7429       eello5_3=0.0d0
7430       eello5_4=0.0d0
7431 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7432 cd     &   eel5_3_num,eel5_4_num)
7433       do iii=1,2
7434         do kkk=1,5
7435           do lll=1,3
7436             derx(lll,kkk,iii)=0.0d0
7437           enddo
7438         enddo
7439       enddo
7440 cd      eij=facont_hb(jj,i)
7441 cd      ekl=facont_hb(kk,k)
7442 cd      ekont=eij*ekl
7443 cd      write (iout,*)'Contacts have occurred for peptide groups',
7444 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7445 cd      goto 1111
7446 C Contribution from the graph I.
7447 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7448 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7449       call transpose2(EUg(1,1,k),auxmat(1,1))
7450       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7451       vv(1)=pizda(1,1)-pizda(2,2)
7452       vv(2)=pizda(1,2)+pizda(2,1)
7453       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7454      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7455 C Explicit gradient in virtual-dihedral angles.
7456       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7457      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7458      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7459       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7460       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7461       vv(1)=pizda(1,1)-pizda(2,2)
7462       vv(2)=pizda(1,2)+pizda(2,1)
7463       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7464      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7465      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7466       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7467       vv(1)=pizda(1,1)-pizda(2,2)
7468       vv(2)=pizda(1,2)+pizda(2,1)
7469       if (l.eq.j+1) then
7470         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7471      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7472      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7473       else
7474         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7475      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7476      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7477       endif
7478 C Cartesian gradient
7479       do iii=1,2
7480         do kkk=1,5
7481           do lll=1,3
7482             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7483      &        pizda(1,1))
7484             vv(1)=pizda(1,1)-pizda(2,2)
7485             vv(2)=pizda(1,2)+pizda(2,1)
7486             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7487      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7488      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7489           enddo
7490         enddo
7491       enddo
7492 c      goto 1112
7493 c1111  continue
7494 C Contribution from graph II
7495       call transpose2(EE(1,1,itk),auxmat(1,1))
7496       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7497       vv(1)=pizda(1,1)+pizda(2,2)
7498       vv(2)=pizda(2,1)-pizda(1,2)
7499       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7500      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7501 C Explicit gradient in virtual-dihedral angles.
7502       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7503      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7504       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7505       vv(1)=pizda(1,1)+pizda(2,2)
7506       vv(2)=pizda(2,1)-pizda(1,2)
7507       if (l.eq.j+1) then
7508         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7509      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7510      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7511       else
7512         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7513      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7514      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7515       endif
7516 C Cartesian gradient
7517       do iii=1,2
7518         do kkk=1,5
7519           do lll=1,3
7520             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7521      &        pizda(1,1))
7522             vv(1)=pizda(1,1)+pizda(2,2)
7523             vv(2)=pizda(2,1)-pizda(1,2)
7524             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7525      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7526      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7527           enddo
7528         enddo
7529       enddo
7530 cd      goto 1112
7531 cd1111  continue
7532       if (l.eq.j+1) then
7533 cd        goto 1110
7534 C Parallel orientation
7535 C Contribution from graph III
7536         call transpose2(EUg(1,1,l),auxmat(1,1))
7537         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7538         vv(1)=pizda(1,1)-pizda(2,2)
7539         vv(2)=pizda(1,2)+pizda(2,1)
7540         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7541      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7542 C Explicit gradient in virtual-dihedral angles.
7543         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7544      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7545      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7546         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7547         vv(1)=pizda(1,1)-pizda(2,2)
7548         vv(2)=pizda(1,2)+pizda(2,1)
7549         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7550      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7551      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7552         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7553         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7554         vv(1)=pizda(1,1)-pizda(2,2)
7555         vv(2)=pizda(1,2)+pizda(2,1)
7556         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7557      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7558      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7559 C Cartesian gradient
7560         do iii=1,2
7561           do kkk=1,5
7562             do lll=1,3
7563               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7564      &          pizda(1,1))
7565               vv(1)=pizda(1,1)-pizda(2,2)
7566               vv(2)=pizda(1,2)+pizda(2,1)
7567               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7568      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7569      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7570             enddo
7571           enddo
7572         enddo
7573 cd        goto 1112
7574 C Contribution from graph IV
7575 cd1110    continue
7576         call transpose2(EE(1,1,itl),auxmat(1,1))
7577         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7578         vv(1)=pizda(1,1)+pizda(2,2)
7579         vv(2)=pizda(2,1)-pizda(1,2)
7580         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7581      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7582 C Explicit gradient in virtual-dihedral angles.
7583         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7584      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7585         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7586         vv(1)=pizda(1,1)+pizda(2,2)
7587         vv(2)=pizda(2,1)-pizda(1,2)
7588         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7589      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7590      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7591 C Cartesian gradient
7592         do iii=1,2
7593           do kkk=1,5
7594             do lll=1,3
7595               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7596      &          pizda(1,1))
7597               vv(1)=pizda(1,1)+pizda(2,2)
7598               vv(2)=pizda(2,1)-pizda(1,2)
7599               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7600      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7601      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7602             enddo
7603           enddo
7604         enddo
7605       else
7606 C Antiparallel orientation
7607 C Contribution from graph III
7608 c        goto 1110
7609         call transpose2(EUg(1,1,j),auxmat(1,1))
7610         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7611         vv(1)=pizda(1,1)-pizda(2,2)
7612         vv(2)=pizda(1,2)+pizda(2,1)
7613         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7614      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7615 C Explicit gradient in virtual-dihedral angles.
7616         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7617      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7618      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7619         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7620         vv(1)=pizda(1,1)-pizda(2,2)
7621         vv(2)=pizda(1,2)+pizda(2,1)
7622         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7623      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7624      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7625         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7626         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7627         vv(1)=pizda(1,1)-pizda(2,2)
7628         vv(2)=pizda(1,2)+pizda(2,1)
7629         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7630      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7631      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7632 C Cartesian gradient
7633         do iii=1,2
7634           do kkk=1,5
7635             do lll=1,3
7636               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7637      &          pizda(1,1))
7638               vv(1)=pizda(1,1)-pizda(2,2)
7639               vv(2)=pizda(1,2)+pizda(2,1)
7640               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7641      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7642      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7643             enddo
7644           enddo
7645         enddo
7646 cd        goto 1112
7647 C Contribution from graph IV
7648 1110    continue
7649         call transpose2(EE(1,1,itj),auxmat(1,1))
7650         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7651         vv(1)=pizda(1,1)+pizda(2,2)
7652         vv(2)=pizda(2,1)-pizda(1,2)
7653         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7654      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7655 C Explicit gradient in virtual-dihedral angles.
7656         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7657      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7658         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7659         vv(1)=pizda(1,1)+pizda(2,2)
7660         vv(2)=pizda(2,1)-pizda(1,2)
7661         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7662      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7663      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7664 C Cartesian gradient
7665         do iii=1,2
7666           do kkk=1,5
7667             do lll=1,3
7668               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7669      &          pizda(1,1))
7670               vv(1)=pizda(1,1)+pizda(2,2)
7671               vv(2)=pizda(2,1)-pizda(1,2)
7672               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7673      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7674      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7675             enddo
7676           enddo
7677         enddo
7678       endif
7679 1112  continue
7680       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7681 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7682 cd        write (2,*) 'ijkl',i,j,k,l
7683 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7684 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7685 cd      endif
7686 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7687 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7688 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7689 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7690       if (j.lt.nres-1) then
7691         j1=j+1
7692         j2=j-1
7693       else
7694         j1=j-1
7695         j2=j-2
7696       endif
7697       if (l.lt.nres-1) then
7698         l1=l+1
7699         l2=l-1
7700       else
7701         l1=l-1
7702         l2=l-2
7703       endif
7704 cd      eij=1.0d0
7705 cd      ekl=1.0d0
7706 cd      ekont=1.0d0
7707 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7708 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7709 C        summed up outside the subrouine as for the other subroutines
7710 C        handling long-range interactions. The old code is commented out
7711 C        with "cgrad" to keep track of changes.
7712       do ll=1,3
7713 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7714 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7715         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7716         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7717 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7718 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7719 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7720 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7721 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7722 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7723 c     &   gradcorr5ij,
7724 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7725 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7726 cgrad        ghalf=0.5d0*ggg1(ll)
7727 cd        ghalf=0.0d0
7728         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7729         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7730         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7731         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7732         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7733         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7734 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7735 cgrad        ghalf=0.5d0*ggg2(ll)
7736 cd        ghalf=0.0d0
7737         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7738         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7739         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7740         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7741         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7742         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7743       enddo
7744 cd      goto 1112
7745 cgrad      do m=i+1,j-1
7746 cgrad        do ll=1,3
7747 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7748 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7749 cgrad        enddo
7750 cgrad      enddo
7751 cgrad      do m=k+1,l-1
7752 cgrad        do ll=1,3
7753 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7754 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7755 cgrad        enddo
7756 cgrad      enddo
7757 c1112  continue
7758 cgrad      do m=i+2,j2
7759 cgrad        do ll=1,3
7760 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7761 cgrad        enddo
7762 cgrad      enddo
7763 cgrad      do m=k+2,l2
7764 cgrad        do ll=1,3
7765 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7766 cgrad        enddo
7767 cgrad      enddo
7768 cd      do iii=1,nres-3
7769 cd        write (2,*) iii,g_corr5_loc(iii)
7770 cd      enddo
7771       eello5=ekont*eel5
7772 cd      write (2,*) 'ekont',ekont
7773 cd      write (iout,*) 'eello5',ekont*eel5
7774       return
7775       end
7776 c--------------------------------------------------------------------------
7777       double precision function eello6(i,j,k,l,jj,kk)
7778       implicit real*8 (a-h,o-z)
7779       include 'DIMENSIONS'
7780       include 'COMMON.IOUNITS'
7781       include 'COMMON.CHAIN'
7782       include 'COMMON.DERIV'
7783       include 'COMMON.INTERACT'
7784       include 'COMMON.CONTACTS'
7785       include 'COMMON.TORSION'
7786       include 'COMMON.VAR'
7787       include 'COMMON.GEO'
7788       include 'COMMON.FFIELD'
7789       double precision ggg1(3),ggg2(3)
7790 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7791 cd        eello6=0.0d0
7792 cd        return
7793 cd      endif
7794 cd      write (iout,*)
7795 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7796 cd     &   ' and',k,l
7797       eello6_1=0.0d0
7798       eello6_2=0.0d0
7799       eello6_3=0.0d0
7800       eello6_4=0.0d0
7801       eello6_5=0.0d0
7802       eello6_6=0.0d0
7803 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7804 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7805       do iii=1,2
7806         do kkk=1,5
7807           do lll=1,3
7808             derx(lll,kkk,iii)=0.0d0
7809           enddo
7810         enddo
7811       enddo
7812 cd      eij=facont_hb(jj,i)
7813 cd      ekl=facont_hb(kk,k)
7814 cd      ekont=eij*ekl
7815 cd      eij=1.0d0
7816 cd      ekl=1.0d0
7817 cd      ekont=1.0d0
7818       if (l.eq.j+1) then
7819         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7820         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7821         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7822         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7823         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7824         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7825       else
7826         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7827         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7828         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7829         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7830         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7831           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7832         else
7833           eello6_5=0.0d0
7834         endif
7835         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7836       endif
7837 C If turn contributions are considered, they will be handled separately.
7838       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7839 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7840 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7841 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7842 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7843 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7844 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7845 cd      goto 1112
7846       if (j.lt.nres-1) then
7847         j1=j+1
7848         j2=j-1
7849       else
7850         j1=j-1
7851         j2=j-2
7852       endif
7853       if (l.lt.nres-1) then
7854         l1=l+1
7855         l2=l-1
7856       else
7857         l1=l-1
7858         l2=l-2
7859       endif
7860       do ll=1,3
7861 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7862 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7863 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7864 cgrad        ghalf=0.5d0*ggg1(ll)
7865 cd        ghalf=0.0d0
7866         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7867         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7868         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7869         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7870         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7871         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7872         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7873         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7874 cgrad        ghalf=0.5d0*ggg2(ll)
7875 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7876 cd        ghalf=0.0d0
7877         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7878         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7879         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7880         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7881         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7882         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7883       enddo
7884 cd      goto 1112
7885 cgrad      do m=i+1,j-1
7886 cgrad        do ll=1,3
7887 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7888 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7889 cgrad        enddo
7890 cgrad      enddo
7891 cgrad      do m=k+1,l-1
7892 cgrad        do ll=1,3
7893 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7894 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7895 cgrad        enddo
7896 cgrad      enddo
7897 cgrad1112  continue
7898 cgrad      do m=i+2,j2
7899 cgrad        do ll=1,3
7900 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7901 cgrad        enddo
7902 cgrad      enddo
7903 cgrad      do m=k+2,l2
7904 cgrad        do ll=1,3
7905 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7906 cgrad        enddo
7907 cgrad      enddo
7908 cd      do iii=1,nres-3
7909 cd        write (2,*) iii,g_corr6_loc(iii)
7910 cd      enddo
7911       eello6=ekont*eel6
7912 cd      write (2,*) 'ekont',ekont
7913 cd      write (iout,*) 'eello6',ekont*eel6
7914       return
7915       end
7916 c--------------------------------------------------------------------------
7917       double precision function eello6_graph1(i,j,k,l,imat,swap)
7918       implicit real*8 (a-h,o-z)
7919       include 'DIMENSIONS'
7920       include 'COMMON.IOUNITS'
7921       include 'COMMON.CHAIN'
7922       include 'COMMON.DERIV'
7923       include 'COMMON.INTERACT'
7924       include 'COMMON.CONTACTS'
7925       include 'COMMON.TORSION'
7926       include 'COMMON.VAR'
7927       include 'COMMON.GEO'
7928       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7929       logical swap
7930       logical lprn
7931       common /kutas/ lprn
7932 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7933 C                                                                              C
7934 C      Parallel       Antiparallel                                             C
7935 C                                                                              C
7936 C          o             o                                                     C
7937 C         /l\           /j\                                                    C
7938 C        /   \         /   \                                                   C
7939 C       /| o |         | o |\                                                  C
7940 C     \ j|/k\|  /   \  |/k\|l /                                                C
7941 C      \ /   \ /     \ /   \ /                                                 C
7942 C       o     o       o     o                                                  C
7943 C       i             i                                                        C
7944 C                                                                              C
7945 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7946       itk=itortyp(itype(k))
7947       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7948       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7949       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7950       call transpose2(EUgC(1,1,k),auxmat(1,1))
7951       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7952       vv1(1)=pizda1(1,1)-pizda1(2,2)
7953       vv1(2)=pizda1(1,2)+pizda1(2,1)
7954       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7955       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7956       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7957       s5=scalar2(vv(1),Dtobr2(1,i))
7958 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7959       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7960       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7961      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7962      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7963      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7964      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7965      & +scalar2(vv(1),Dtobr2der(1,i)))
7966       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7967       vv1(1)=pizda1(1,1)-pizda1(2,2)
7968       vv1(2)=pizda1(1,2)+pizda1(2,1)
7969       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7970       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7971       if (l.eq.j+1) then
7972         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7973      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7974      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7975      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7976      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7977       else
7978         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7979      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7980      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7981      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7982      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7983       endif
7984       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7985       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7986       vv1(1)=pizda1(1,1)-pizda1(2,2)
7987       vv1(2)=pizda1(1,2)+pizda1(2,1)
7988       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7989      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7990      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7991      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7992       do iii=1,2
7993         if (swap) then
7994           ind=3-iii
7995         else
7996           ind=iii
7997         endif
7998         do kkk=1,5
7999           do lll=1,3
8000             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8001             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8002             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8003             call transpose2(EUgC(1,1,k),auxmat(1,1))
8004             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8005      &        pizda1(1,1))
8006             vv1(1)=pizda1(1,1)-pizda1(2,2)
8007             vv1(2)=pizda1(1,2)+pizda1(2,1)
8008             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8009             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8010      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8011             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8012      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8013             s5=scalar2(vv(1),Dtobr2(1,i))
8014             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8015           enddo
8016         enddo
8017       enddo
8018       return
8019       end
8020 c----------------------------------------------------------------------------
8021       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8022       implicit real*8 (a-h,o-z)
8023       include 'DIMENSIONS'
8024       include 'COMMON.IOUNITS'
8025       include 'COMMON.CHAIN'
8026       include 'COMMON.DERIV'
8027       include 'COMMON.INTERACT'
8028       include 'COMMON.CONTACTS'
8029       include 'COMMON.TORSION'
8030       include 'COMMON.VAR'
8031       include 'COMMON.GEO'
8032       logical swap
8033       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8034      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8035       logical lprn
8036       common /kutas/ lprn
8037 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8038 C                                                                              C
8039 C      Parallel       Antiparallel                                             C
8040 C                                                                              C
8041 C          o             o                                                     C
8042 C     \   /l\           /j\   /                                                C
8043 C      \ /   \         /   \ /                                                 C
8044 C       o| o |         | o |o                                                  C
8045 C     \ j|/k\|      \  |/k\|l                                                  C
8046 C      \ /   \       \ /   \                                                   C
8047 C       o             o                                                        C
8048 C       i             i                                                        C
8049 C                                                                              C
8050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8051 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8052 C AL 7/4/01 s1 would occur in the sixth-order moment,
8053 C           but not in a cluster cumulant
8054 #ifdef MOMENT
8055       s1=dip(1,jj,i)*dip(1,kk,k)
8056 #endif
8057       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8058       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8059       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8060       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8061       call transpose2(EUg(1,1,k),auxmat(1,1))
8062       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8063       vv(1)=pizda(1,1)-pizda(2,2)
8064       vv(2)=pizda(1,2)+pizda(2,1)
8065       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8066 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8067 #ifdef MOMENT
8068       eello6_graph2=-(s1+s2+s3+s4)
8069 #else
8070       eello6_graph2=-(s2+s3+s4)
8071 #endif
8072 c      eello6_graph2=-s3
8073 C Derivatives in gamma(i-1)
8074       if (i.gt.1) then
8075 #ifdef MOMENT
8076         s1=dipderg(1,jj,i)*dip(1,kk,k)
8077 #endif
8078         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8079         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8080         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8081         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8082 #ifdef MOMENT
8083         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8084 #else
8085         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8086 #endif
8087 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8088       endif
8089 C Derivatives in gamma(k-1)
8090 #ifdef MOMENT
8091       s1=dip(1,jj,i)*dipderg(1,kk,k)
8092 #endif
8093       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8094       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8095       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8096       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8097       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8098       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8099       vv(1)=pizda(1,1)-pizda(2,2)
8100       vv(2)=pizda(1,2)+pizda(2,1)
8101       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8102 #ifdef MOMENT
8103       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8104 #else
8105       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8106 #endif
8107 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8108 C Derivatives in gamma(j-1) or gamma(l-1)
8109       if (j.gt.1) then
8110 #ifdef MOMENT
8111         s1=dipderg(3,jj,i)*dip(1,kk,k)
8112 #endif
8113         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8114         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8115         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8116         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8117         vv(1)=pizda(1,1)-pizda(2,2)
8118         vv(2)=pizda(1,2)+pizda(2,1)
8119         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8120 #ifdef MOMENT
8121         if (swap) then
8122           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8123         else
8124           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8125         endif
8126 #endif
8127         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8128 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8129       endif
8130 C Derivatives in gamma(l-1) or gamma(j-1)
8131       if (l.gt.1) then
8132 #ifdef MOMENT
8133         s1=dip(1,jj,i)*dipderg(3,kk,k)
8134 #endif
8135         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8136         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8137         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8138         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8139         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8140         vv(1)=pizda(1,1)-pizda(2,2)
8141         vv(2)=pizda(1,2)+pizda(2,1)
8142         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8143 #ifdef MOMENT
8144         if (swap) then
8145           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8146         else
8147           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8148         endif
8149 #endif
8150         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8151 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8152       endif
8153 C Cartesian derivatives.
8154       if (lprn) then
8155         write (2,*) 'In eello6_graph2'
8156         do iii=1,2
8157           write (2,*) 'iii=',iii
8158           do kkk=1,5
8159             write (2,*) 'kkk=',kkk
8160             do jjj=1,2
8161               write (2,'(3(2f10.5),5x)')
8162      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8163             enddo
8164           enddo
8165         enddo
8166       endif
8167       do iii=1,2
8168         do kkk=1,5
8169           do lll=1,3
8170 #ifdef MOMENT
8171             if (iii.eq.1) then
8172               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8173             else
8174               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8175             endif
8176 #endif
8177             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8178      &        auxvec(1))
8179             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8180             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8181      &        auxvec(1))
8182             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8183             call transpose2(EUg(1,1,k),auxmat(1,1))
8184             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8185      &        pizda(1,1))
8186             vv(1)=pizda(1,1)-pizda(2,2)
8187             vv(2)=pizda(1,2)+pizda(2,1)
8188             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8189 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8190 #ifdef MOMENT
8191             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8192 #else
8193             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8194 #endif
8195             if (swap) then
8196               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8197             else
8198               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8199             endif
8200           enddo
8201         enddo
8202       enddo
8203       return
8204       end
8205 c----------------------------------------------------------------------------
8206       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8207       implicit real*8 (a-h,o-z)
8208       include 'DIMENSIONS'
8209       include 'COMMON.IOUNITS'
8210       include 'COMMON.CHAIN'
8211       include 'COMMON.DERIV'
8212       include 'COMMON.INTERACT'
8213       include 'COMMON.CONTACTS'
8214       include 'COMMON.TORSION'
8215       include 'COMMON.VAR'
8216       include 'COMMON.GEO'
8217       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8218       logical swap
8219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8220 C                                                                              C
8221 C      Parallel       Antiparallel                                             C
8222 C                                                                              C
8223 C          o             o                                                     C
8224 C         /l\   /   \   /j\                                                    C
8225 C        /   \ /     \ /   \                                                   C
8226 C       /| o |o       o| o |\                                                  C
8227 C       j|/k\|  /      |/k\|l /                                                C
8228 C        /   \ /       /   \ /                                                 C
8229 C       /     o       /     o                                                  C
8230 C       i             i                                                        C
8231 C                                                                              C
8232 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8233 C
8234 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8235 C           energy moment and not to the cluster cumulant.
8236       iti=itortyp(itype(i))
8237       if (j.lt.nres-1) then
8238         itj1=itortyp(itype(j+1))
8239       else
8240         itj1=ntortyp+1
8241       endif
8242       itk=itortyp(itype(k))
8243       itk1=itortyp(itype(k+1))
8244       if (l.lt.nres-1) then
8245         itl1=itortyp(itype(l+1))
8246       else
8247         itl1=ntortyp+1
8248       endif
8249 #ifdef MOMENT
8250       s1=dip(4,jj,i)*dip(4,kk,k)
8251 #endif
8252       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8253       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8254       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8255       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8256       call transpose2(EE(1,1,itk),auxmat(1,1))
8257       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8258       vv(1)=pizda(1,1)+pizda(2,2)
8259       vv(2)=pizda(2,1)-pizda(1,2)
8260       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8261 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8262 cd     & "sum",-(s2+s3+s4)
8263 #ifdef MOMENT
8264       eello6_graph3=-(s1+s2+s3+s4)
8265 #else
8266       eello6_graph3=-(s2+s3+s4)
8267 #endif
8268 c      eello6_graph3=-s4
8269 C Derivatives in gamma(k-1)
8270       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8271       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8272       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8273       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8274 C Derivatives in gamma(l-1)
8275       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8276       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8277       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8278       vv(1)=pizda(1,1)+pizda(2,2)
8279       vv(2)=pizda(2,1)-pizda(1,2)
8280       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8281       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8282 C Cartesian derivatives.
8283       do iii=1,2
8284         do kkk=1,5
8285           do lll=1,3
8286 #ifdef MOMENT
8287             if (iii.eq.1) then
8288               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8289             else
8290               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8291             endif
8292 #endif
8293             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8294      &        auxvec(1))
8295             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8296             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8297      &        auxvec(1))
8298             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8299             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8300      &        pizda(1,1))
8301             vv(1)=pizda(1,1)+pizda(2,2)
8302             vv(2)=pizda(2,1)-pizda(1,2)
8303             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8304 #ifdef MOMENT
8305             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8306 #else
8307             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8308 #endif
8309             if (swap) then
8310               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8311             else
8312               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8313             endif
8314 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8315           enddo
8316         enddo
8317       enddo
8318       return
8319       end
8320 c----------------------------------------------------------------------------
8321       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8322       implicit real*8 (a-h,o-z)
8323       include 'DIMENSIONS'
8324       include 'COMMON.IOUNITS'
8325       include 'COMMON.CHAIN'
8326       include 'COMMON.DERIV'
8327       include 'COMMON.INTERACT'
8328       include 'COMMON.CONTACTS'
8329       include 'COMMON.TORSION'
8330       include 'COMMON.VAR'
8331       include 'COMMON.GEO'
8332       include 'COMMON.FFIELD'
8333       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8334      & auxvec1(2),auxmat1(2,2)
8335       logical swap
8336 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8337 C                                                                              C
8338 C      Parallel       Antiparallel                                             C
8339 C                                                                              C
8340 C          o             o                                                     C
8341 C         /l\   /   \   /j\                                                    C
8342 C        /   \ /     \ /   \                                                   C
8343 C       /| o |o       o| o |\                                                  C
8344 C     \ j|/k\|      \  |/k\|l                                                  C
8345 C      \ /   \       \ /   \                                                   C
8346 C       o     \       o     \                                                  C
8347 C       i             i                                                        C
8348 C                                                                              C
8349 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8350 C
8351 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8352 C           energy moment and not to the cluster cumulant.
8353 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8354       iti=itortyp(itype(i))
8355       itj=itortyp(itype(j))
8356       if (j.lt.nres-1) then
8357         itj1=itortyp(itype(j+1))
8358       else
8359         itj1=ntortyp+1
8360       endif
8361       itk=itortyp(itype(k))
8362       if (k.lt.nres-1) then
8363         itk1=itortyp(itype(k+1))
8364       else
8365         itk1=ntortyp+1
8366       endif
8367       itl=itortyp(itype(l))
8368       if (l.lt.nres-1) then
8369         itl1=itortyp(itype(l+1))
8370       else
8371         itl1=ntortyp+1
8372       endif
8373 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8374 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8375 cd     & ' itl',itl,' itl1',itl1
8376 #ifdef MOMENT
8377       if (imat.eq.1) then
8378         s1=dip(3,jj,i)*dip(3,kk,k)
8379       else
8380         s1=dip(2,jj,j)*dip(2,kk,l)
8381       endif
8382 #endif
8383       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8384       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8385       if (j.eq.l+1) then
8386         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8387         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8388       else
8389         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8390         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8391       endif
8392       call transpose2(EUg(1,1,k),auxmat(1,1))
8393       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8394       vv(1)=pizda(1,1)-pizda(2,2)
8395       vv(2)=pizda(2,1)+pizda(1,2)
8396       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8397 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8398 #ifdef MOMENT
8399       eello6_graph4=-(s1+s2+s3+s4)
8400 #else
8401       eello6_graph4=-(s2+s3+s4)
8402 #endif
8403 C Derivatives in gamma(i-1)
8404       if (i.gt.1) then
8405 #ifdef MOMENT
8406         if (imat.eq.1) then
8407           s1=dipderg(2,jj,i)*dip(3,kk,k)
8408         else
8409           s1=dipderg(4,jj,j)*dip(2,kk,l)
8410         endif
8411 #endif
8412         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8413         if (j.eq.l+1) then
8414           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8415           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8416         else
8417           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8418           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8419         endif
8420         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8421         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8422 cd          write (2,*) 'turn6 derivatives'
8423 #ifdef MOMENT
8424           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8425 #else
8426           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8427 #endif
8428         else
8429 #ifdef MOMENT
8430           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8431 #else
8432           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8433 #endif
8434         endif
8435       endif
8436 C Derivatives in gamma(k-1)
8437 #ifdef MOMENT
8438       if (imat.eq.1) then
8439         s1=dip(3,jj,i)*dipderg(2,kk,k)
8440       else
8441         s1=dip(2,jj,j)*dipderg(4,kk,l)
8442       endif
8443 #endif
8444       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8445       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8446       if (j.eq.l+1) then
8447         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8448         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8449       else
8450         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8451         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8452       endif
8453       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8454       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8455       vv(1)=pizda(1,1)-pizda(2,2)
8456       vv(2)=pizda(2,1)+pizda(1,2)
8457       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8458       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8459 #ifdef MOMENT
8460         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8461 #else
8462         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8463 #endif
8464       else
8465 #ifdef MOMENT
8466         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8467 #else
8468         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8469 #endif
8470       endif
8471 C Derivatives in gamma(j-1) or gamma(l-1)
8472       if (l.eq.j+1 .and. l.gt.1) then
8473         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8474         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8475         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8476         vv(1)=pizda(1,1)-pizda(2,2)
8477         vv(2)=pizda(2,1)+pizda(1,2)
8478         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8479         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8480       else if (j.gt.1) then
8481         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8482         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8483         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8484         vv(1)=pizda(1,1)-pizda(2,2)
8485         vv(2)=pizda(2,1)+pizda(1,2)
8486         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8487         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8488           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8489         else
8490           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8491         endif
8492       endif
8493 C Cartesian derivatives.
8494       do iii=1,2
8495         do kkk=1,5
8496           do lll=1,3
8497 #ifdef MOMENT
8498             if (iii.eq.1) then
8499               if (imat.eq.1) then
8500                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8501               else
8502                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8503               endif
8504             else
8505               if (imat.eq.1) then
8506                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8507               else
8508                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8509               endif
8510             endif
8511 #endif
8512             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8513      &        auxvec(1))
8514             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8515             if (j.eq.l+1) then
8516               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8517      &          b1(1,itj1),auxvec(1))
8518               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8519             else
8520               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8521      &          b1(1,itl1),auxvec(1))
8522               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8523             endif
8524             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8525      &        pizda(1,1))
8526             vv(1)=pizda(1,1)-pizda(2,2)
8527             vv(2)=pizda(2,1)+pizda(1,2)
8528             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8529             if (swap) then
8530               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8531 #ifdef MOMENT
8532                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8533      &             -(s1+s2+s4)
8534 #else
8535                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8536      &             -(s2+s4)
8537 #endif
8538                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8539               else
8540 #ifdef MOMENT
8541                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8542 #else
8543                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8544 #endif
8545                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8546               endif
8547             else
8548 #ifdef MOMENT
8549               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8550 #else
8551               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8552 #endif
8553               if (l.eq.j+1) then
8554                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8555               else
8556                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8557               endif
8558             endif
8559           enddo
8560         enddo
8561       enddo
8562       return
8563       end
8564 c----------------------------------------------------------------------------
8565       double precision function eello_turn6(i,jj,kk)
8566       implicit real*8 (a-h,o-z)
8567       include 'DIMENSIONS'
8568       include 'COMMON.IOUNITS'
8569       include 'COMMON.CHAIN'
8570       include 'COMMON.DERIV'
8571       include 'COMMON.INTERACT'
8572       include 'COMMON.CONTACTS'
8573       include 'COMMON.TORSION'
8574       include 'COMMON.VAR'
8575       include 'COMMON.GEO'
8576       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8577      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8578      &  ggg1(3),ggg2(3)
8579       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8580      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8581 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8582 C           the respective energy moment and not to the cluster cumulant.
8583       s1=0.0d0
8584       s8=0.0d0
8585       s13=0.0d0
8586 c
8587       eello_turn6=0.0d0
8588       j=i+4
8589       k=i+1
8590       l=i+3
8591       iti=itortyp(itype(i))
8592       itk=itortyp(itype(k))
8593       itk1=itortyp(itype(k+1))
8594       itl=itortyp(itype(l))
8595       itj=itortyp(itype(j))
8596 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8597 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8598 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8599 cd        eello6=0.0d0
8600 cd        return
8601 cd      endif
8602 cd      write (iout,*)
8603 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8604 cd     &   ' and',k,l
8605 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8606       do iii=1,2
8607         do kkk=1,5
8608           do lll=1,3
8609             derx_turn(lll,kkk,iii)=0.0d0
8610           enddo
8611         enddo
8612       enddo
8613 cd      eij=1.0d0
8614 cd      ekl=1.0d0
8615 cd      ekont=1.0d0
8616       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8617 cd      eello6_5=0.0d0
8618 cd      write (2,*) 'eello6_5',eello6_5
8619 #ifdef MOMENT
8620       call transpose2(AEA(1,1,1),auxmat(1,1))
8621       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8622       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8623       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8624 #endif
8625       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8626       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8627       s2 = scalar2(b1(1,itk),vtemp1(1))
8628 #ifdef MOMENT
8629       call transpose2(AEA(1,1,2),atemp(1,1))
8630       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8631       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8632       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8633 #endif
8634       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8635       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8636       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8637 #ifdef MOMENT
8638       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8639       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8640       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8641       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8642       ss13 = scalar2(b1(1,itk),vtemp4(1))
8643       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8644 #endif
8645 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8646 c      s1=0.0d0
8647 c      s2=0.0d0
8648 c      s8=0.0d0
8649 c      s12=0.0d0
8650 c      s13=0.0d0
8651       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8652 C Derivatives in gamma(i+2)
8653       s1d =0.0d0
8654       s8d =0.0d0
8655 #ifdef MOMENT
8656       call transpose2(AEA(1,1,1),auxmatd(1,1))
8657       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8658       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8659       call transpose2(AEAderg(1,1,2),atempd(1,1))
8660       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8661       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8662 #endif
8663       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8664       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8665       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8666 c      s1d=0.0d0
8667 c      s2d=0.0d0
8668 c      s8d=0.0d0
8669 c      s12d=0.0d0
8670 c      s13d=0.0d0
8671       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8672 C Derivatives in gamma(i+3)
8673 #ifdef MOMENT
8674       call transpose2(AEA(1,1,1),auxmatd(1,1))
8675       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8676       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8677       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8678 #endif
8679       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8680       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8681       s2d = scalar2(b1(1,itk),vtemp1d(1))
8682 #ifdef MOMENT
8683       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8684       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8685 #endif
8686       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8687 #ifdef MOMENT
8688       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8689       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8690       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8691 #endif
8692 c      s1d=0.0d0
8693 c      s2d=0.0d0
8694 c      s8d=0.0d0
8695 c      s12d=0.0d0
8696 c      s13d=0.0d0
8697 #ifdef MOMENT
8698       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8699      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8700 #else
8701       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8702      &               -0.5d0*ekont*(s2d+s12d)
8703 #endif
8704 C Derivatives in gamma(i+4)
8705       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8706       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8707       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8708 #ifdef MOMENT
8709       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8710       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8711       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8712 #endif
8713 c      s1d=0.0d0
8714 c      s2d=0.0d0
8715 c      s8d=0.0d0
8716 C      s12d=0.0d0
8717 c      s13d=0.0d0
8718 #ifdef MOMENT
8719       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8720 #else
8721       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8722 #endif
8723 C Derivatives in gamma(i+5)
8724 #ifdef MOMENT
8725       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8726       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8727       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8728 #endif
8729       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8730       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8731       s2d = scalar2(b1(1,itk),vtemp1d(1))
8732 #ifdef MOMENT
8733       call transpose2(AEA(1,1,2),atempd(1,1))
8734       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8735       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8736 #endif
8737       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8738       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8739 #ifdef MOMENT
8740       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8741       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8742       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8743 #endif
8744 c      s1d=0.0d0
8745 c      s2d=0.0d0
8746 c      s8d=0.0d0
8747 c      s12d=0.0d0
8748 c      s13d=0.0d0
8749 #ifdef MOMENT
8750       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8751      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8752 #else
8753       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8754      &               -0.5d0*ekont*(s2d+s12d)
8755 #endif
8756 C Cartesian derivatives
8757       do iii=1,2
8758         do kkk=1,5
8759           do lll=1,3
8760 #ifdef MOMENT
8761             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8762             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8763             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8764 #endif
8765             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8766             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8767      &          vtemp1d(1))
8768             s2d = scalar2(b1(1,itk),vtemp1d(1))
8769 #ifdef MOMENT
8770             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8771             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8772             s8d = -(atempd(1,1)+atempd(2,2))*
8773      &           scalar2(cc(1,1,itl),vtemp2(1))
8774 #endif
8775             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8776      &           auxmatd(1,1))
8777             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8778             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8779 c      s1d=0.0d0
8780 c      s2d=0.0d0
8781 c      s8d=0.0d0
8782 c      s12d=0.0d0
8783 c      s13d=0.0d0
8784 #ifdef MOMENT
8785             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8786      &        - 0.5d0*(s1d+s2d)
8787 #else
8788             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8789      &        - 0.5d0*s2d
8790 #endif
8791 #ifdef MOMENT
8792             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8793      &        - 0.5d0*(s8d+s12d)
8794 #else
8795             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8796      &        - 0.5d0*s12d
8797 #endif
8798           enddo
8799         enddo
8800       enddo
8801 #ifdef MOMENT
8802       do kkk=1,5
8803         do lll=1,3
8804           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8805      &      achuj_tempd(1,1))
8806           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8807           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8808           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8809           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8810           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8811      &      vtemp4d(1))
8812           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8813           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8814           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8815         enddo
8816       enddo
8817 #endif
8818 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8819 cd     &  16*eel_turn6_num
8820 cd      goto 1112
8821       if (j.lt.nres-1) then
8822         j1=j+1
8823         j2=j-1
8824       else
8825         j1=j-1
8826         j2=j-2
8827       endif
8828       if (l.lt.nres-1) then
8829         l1=l+1
8830         l2=l-1
8831       else
8832         l1=l-1
8833         l2=l-2
8834       endif
8835       do ll=1,3
8836 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8837 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8838 cgrad        ghalf=0.5d0*ggg1(ll)
8839 cd        ghalf=0.0d0
8840         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8841         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8842         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8843      &    +ekont*derx_turn(ll,2,1)
8844         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8845         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8846      &    +ekont*derx_turn(ll,4,1)
8847         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8848         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8849         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8850 cgrad        ghalf=0.5d0*ggg2(ll)
8851 cd        ghalf=0.0d0
8852         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8853      &    +ekont*derx_turn(ll,2,2)
8854         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8855         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8856      &    +ekont*derx_turn(ll,4,2)
8857         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8858         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8859         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8860       enddo
8861 cd      goto 1112
8862 cgrad      do m=i+1,j-1
8863 cgrad        do ll=1,3
8864 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8865 cgrad        enddo
8866 cgrad      enddo
8867 cgrad      do m=k+1,l-1
8868 cgrad        do ll=1,3
8869 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8870 cgrad        enddo
8871 cgrad      enddo
8872 cgrad1112  continue
8873 cgrad      do m=i+2,j2
8874 cgrad        do ll=1,3
8875 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8876 cgrad        enddo
8877 cgrad      enddo
8878 cgrad      do m=k+2,l2
8879 cgrad        do ll=1,3
8880 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8881 cgrad        enddo
8882 cgrad      enddo
8883 cd      do iii=1,nres-3
8884 cd        write (2,*) iii,g_corr6_loc(iii)
8885 cd      enddo
8886       eello_turn6=ekont*eel_turn6
8887 cd      write (2,*) 'ekont',ekont
8888 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8889       return
8890       end
8891
8892 C-----------------------------------------------------------------------------
8893       double precision function scalar(u,v)
8894 !DIR$ INLINEALWAYS scalar
8895 #ifndef OSF
8896 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8897 #endif
8898       implicit none
8899       double precision u(3),v(3)
8900 cd      double precision sc
8901 cd      integer i
8902 cd      sc=0.0d0
8903 cd      do i=1,3
8904 cd        sc=sc+u(i)*v(i)
8905 cd      enddo
8906 cd      scalar=sc
8907
8908       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8909       return
8910       end
8911 crc-------------------------------------------------
8912       SUBROUTINE MATVEC2(A1,V1,V2)
8913 !DIR$ INLINEALWAYS MATVEC2
8914 #ifndef OSF
8915 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8916 #endif
8917       implicit real*8 (a-h,o-z)
8918       include 'DIMENSIONS'
8919       DIMENSION A1(2,2),V1(2),V2(2)
8920 c      DO 1 I=1,2
8921 c        VI=0.0
8922 c        DO 3 K=1,2
8923 c    3     VI=VI+A1(I,K)*V1(K)
8924 c        Vaux(I)=VI
8925 c    1 CONTINUE
8926
8927       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8928       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8929
8930       v2(1)=vaux1
8931       v2(2)=vaux2
8932       END
8933 C---------------------------------------
8934       SUBROUTINE MATMAT2(A1,A2,A3)
8935 #ifndef OSF
8936 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8937 #endif
8938       implicit real*8 (a-h,o-z)
8939       include 'DIMENSIONS'
8940       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8941 c      DIMENSION AI3(2,2)
8942 c        DO  J=1,2
8943 c          A3IJ=0.0
8944 c          DO K=1,2
8945 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8946 c          enddo
8947 c          A3(I,J)=A3IJ
8948 c       enddo
8949 c      enddo
8950
8951       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8952       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8953       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8954       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8955
8956       A3(1,1)=AI3_11
8957       A3(2,1)=AI3_21
8958       A3(1,2)=AI3_12
8959       A3(2,2)=AI3_22
8960       END
8961
8962 c-------------------------------------------------------------------------
8963       double precision function scalar2(u,v)
8964 !DIR$ INLINEALWAYS scalar2
8965       implicit none
8966       double precision u(2),v(2)
8967       double precision sc
8968       integer i
8969       scalar2=u(1)*v(1)+u(2)*v(2)
8970       return
8971       end
8972
8973 C-----------------------------------------------------------------------------
8974
8975       subroutine transpose2(a,at)
8976 !DIR$ INLINEALWAYS transpose2
8977 #ifndef OSF
8978 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8979 #endif
8980       implicit none
8981       double precision a(2,2),at(2,2)
8982       at(1,1)=a(1,1)
8983       at(1,2)=a(2,1)
8984       at(2,1)=a(1,2)
8985       at(2,2)=a(2,2)
8986       return
8987       end
8988 c--------------------------------------------------------------------------
8989       subroutine transpose(n,a,at)
8990       implicit none
8991       integer n,i,j
8992       double precision a(n,n),at(n,n)
8993       do i=1,n
8994         do j=1,n
8995           at(j,i)=a(i,j)
8996         enddo
8997       enddo
8998       return
8999       end
9000 C---------------------------------------------------------------------------
9001       subroutine prodmat3(a1,a2,kk,transp,prod)
9002 !DIR$ INLINEALWAYS prodmat3
9003 #ifndef OSF
9004 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9005 #endif
9006       implicit none
9007       integer i,j
9008       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9009       logical transp
9010 crc      double precision auxmat(2,2),prod_(2,2)
9011
9012       if (transp) then
9013 crc        call transpose2(kk(1,1),auxmat(1,1))
9014 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9015 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9016
9017            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9018      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9019            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9020      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9021            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9022      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9023            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9024      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9025
9026       else
9027 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9028 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9029
9030            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9031      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9032            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9033      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9034            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9035      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9036            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9037      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9038
9039       endif
9040 c      call transpose2(a2(1,1),a2t(1,1))
9041
9042 crc      print *,transp
9043 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9044 crc      print *,((prod(i,j),i=1,2),j=1,2)
9045
9046       return
9047       end
9048