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 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.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 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c    Here are the energies showed per procesor if the are more processors
 300 c    per molecule then we sum it up in sum_energy subroutine
 301 c      print *," Processor",myrank," calls SUM_ENERGY"
 302       call sum_energy(energia,.true.)
 303 c      print *," Processor",myrank," left SUM_ENERGY"
 304 #ifdef TIMING
 305       time_sumene=time_sumene+MPI_Wtime()-time00
 306 #endif
 307       return
 308       end
 309 c-------------------------------------------------------------------------------
 310       subroutine sum_energy(energia,reduce)
 311       implicit real*8 (a-h,o-z)
 312       include 'DIMENSIONS'
 313 #ifndef ISNAN
 314       external proc_proc
 315 #ifdef WINPGI
 316 cMS$ATTRIBUTES C ::  proc_proc
 317 #endif
 318 #endif
 319 #ifdef MPI
 320       include "mpif.h"
 321 #endif
 322       include 'COMMON.SETUP'
 323       include 'COMMON.IOUNITS'
 324       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 325       include 'COMMON.FFIELD'
 326       include 'COMMON.DERIV'
 327       include 'COMMON.INTERACT'
 328       include 'COMMON.SBRIDGE'
 329       include 'COMMON.CHAIN'
 330       include 'COMMON.VAR'
 331       include 'COMMON.CONTROL'
 332       include 'COMMON.TIME1'
 333       logical reduce
 334 #ifdef MPI
 335       if (nfgtasks.gt.1 .and. reduce) then
 336 #ifdef DEBUG
 337         write (iout,*) "energies before REDUCE"
 338         call enerprint(energia)
 339         call flush(iout)
 340 #endif
 341         do i=0,n_ene
 342           enebuff(i)=energia(i)
 343         enddo
 344         time00=MPI_Wtime()
 345         call MPI_Barrier(FG_COMM,IERR)
 346         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 347         time00=MPI_Wtime()
 348         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 349      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 350 #ifdef DEBUG
 351         write (iout,*) "energies after REDUCE"
 352         call enerprint(energia)
 353         call flush(iout)
 354 #endif
 355         time_Reduce=time_Reduce+MPI_Wtime()-time00
 356       endif
 357       if (fg_rank.eq.0) then
 358 #endif
 359       evdw=energia(1)
 360 #ifdef SCP14
 361       evdw2=energia(2)+energia(18)
 362       evdw2_14=energia(18)
 363 #else
 364       evdw2=energia(2)
 365 #endif
 366 #ifdef SPLITELE
 367       ees=energia(3)
 368       evdw1=energia(16)
 369 #else
 370       ees=energia(3)
 371       evdw1=0.0d0
 372 #endif
 373       ecorr=energia(4)
 374       ecorr5=energia(5)
 375       ecorr6=energia(6)
 376       eel_loc=energia(7)
 377       eello_turn3=energia(8)
 378       eello_turn4=energia(9)
 379       eturn6=energia(10)
 380       ebe=energia(11)
 381       escloc=energia(12)
 382       etors=energia(13)
 383       etors_d=energia(14)
 384       ehpb=energia(15)
 385       edihcnstr=energia(19)
 386       estr=energia(17)
 387       Uconst=energia(20)
 388       esccor=energia(21)
 389 #ifdef SPLITELE
 390       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 391      & +wang*ebe+wtor*etors+wscloc*escloc
 392      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 393      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 394      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 395      & +wbond*estr+Uconst+wsccor*esccor
 396 #else
 397       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #endif
 404       energia(0)=etot
 405 c detecting NaNQ
 406 #ifdef ISNAN
 407 #ifdef AIX
 408       if (isnan(etot).ne.0) energia(0)=1.0d+99
 409 #else
 410       if (isnan(etot)) energia(0)=1.0d+99
 411 #endif
 412 #else
 413       i=0
 414 #ifdef WINPGI
 415       idumm=proc_proc(etot,i)
 416 #else
 417       call proc_proc(etot,i)
 418 #endif
 419       if(i.eq.1)energia(0)=1.0d+99
 420 #endif
 421 #ifdef MPI
 422       endif
 423 #endif
 424       return
 425       end
 426 c-------------------------------------------------------------------------------
 427       subroutine sum_gradient
 428       implicit real*8 (a-h,o-z)
 429       include 'DIMENSIONS'
 430 #ifndef ISNAN
 431       external proc_proc
 432 #ifdef WINPGI
 433 cMS$ATTRIBUTES C ::  proc_proc
 434 #endif
 435 #endif
 436 #ifdef MPI
 437       include 'mpif.h'
 438       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 439      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 440 #endif
 441       include 'COMMON.SETUP'
 442       include 'COMMON.IOUNITS'
 443       include 'COMMON.FFIELD'
 444       include 'COMMON.DERIV'
 445       include 'COMMON.INTERACT'
 446       include 'COMMON.SBRIDGE'
 447       include 'COMMON.CHAIN'
 448       include 'COMMON.VAR'
 449       include 'COMMON.CONTROL'
 450       include 'COMMON.TIME1'
 451       include 'COMMON.MAXGRAD'
 452       include 'COMMON.SCCOR'
 453 #ifdef TIMING
 454       time01=MPI_Wtime()
 455 #endif
 456 #ifdef DEBUG
 457       write (iout,*) "sum_gradient gvdwc, gvdwx"
 458       do i=1,nres
 459         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 460      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 461       enddo
 462       call flush(iout)
 463 #endif
 464 #ifdef MPI
 465 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 466         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 467      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 468 #endif
 469 C
 470 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 471 C            in virtual-bond-vector coordinates
 472 C
 473 #ifdef DEBUG
 474 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 475 c      do i=1,nres-1
 476 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 477 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 478 c      enddo
 479 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 482 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 483 c      enddo
 484       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 485       do i=1,nres
 486         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 487      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 488      &   g_corr5_loc(i)
 489       enddo
 490       call flush(iout)
 491 #endif
 492 #ifdef SPLITELE
 493       do i=1,nct
 494         do j=1,3
 495           gradbufc(j,i)=wsc*gvdwc(j,i)+
 496      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 497      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 498      &                wel_loc*gel_loc_long(j,i)+
 499      &                wcorr*gradcorr_long(j,i)+
 500      &                wcorr5*gradcorr5_long(j,i)+
 501      &                wcorr6*gradcorr6_long(j,i)+
 502      &                wturn6*gcorr6_turn_long(j,i)+
 503      &                wstrain*ghpbc(j,i)
 504         enddo
 505       enddo
 506 #else
 507       do i=1,nct
 508         do j=1,3
 509           gradbufc(j,i)=wsc*gvdwc(j,i)+
 510      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 511      &                welec*gelc_long(j,i)+
 512      &                wbond*gradb(j,i)+
 513      &                wel_loc*gel_loc_long(j,i)+
 514      &                wcorr*gradcorr_long(j,i)+
 515      &                wcorr5*gradcorr5_long(j,i)+
 516      &                wcorr6*gradcorr6_long(j,i)+
 517      &                wturn6*gcorr6_turn_long(j,i)+
 518      &                wstrain*ghpbc(j,i)
 519         enddo
 520       enddo
 521 #endif
 522 #ifdef MPI
 523       if (nfgtasks.gt.1) then
 524       time00=MPI_Wtime()
 525 #ifdef DEBUG
 526       write (iout,*) "gradbufc before allreduce"
 527       do i=1,nres
 528         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 529       enddo
 530       call flush(iout)
 531 #endif
 532       do i=1,nres
 533         do j=1,3
 534           gradbufc_sum(j,i)=gradbufc(j,i)
 535         enddo
 536       enddo
 537 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 538 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 539 c      time_reduce=time_reduce+MPI_Wtime()-time00
 540 #ifdef DEBUG
 541 c      write (iout,*) "gradbufc_sum after allreduce"
 542 c      do i=1,nres
 543 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 544 c      enddo
 545 c      call flush(iout)
 546 #endif
 547 #ifdef TIMING
 548 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 549 #endif
 550       do i=nnt,nres
 551         do k=1,3
 552           gradbufc(k,i)=0.0d0
 553         enddo
 554       enddo
 555 #ifdef DEBUG
 556       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 557       write (iout,*) (i," jgrad_start",jgrad_start(i),
 558      &                  " jgrad_end  ",jgrad_end(i),
 559      &                  i=igrad_start,igrad_end)
 560 #endif
 561 c
 562 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 563 c do not parallelize this part.
 564 c
 565 c      do i=igrad_start,igrad_end
 566 c        do j=jgrad_start(i),jgrad_end(i)
 567 c          do k=1,3
 568 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 569 c          enddo
 570 c        enddo
 571 c      enddo
 572       do j=1,3
 573         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 574       enddo
 575       do i=nres-2,nnt,-1
 576         do j=1,3
 577           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc after summing"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       else
 588 #endif
 589 #ifdef DEBUG
 590       write (iout,*) "gradbufc"
 591       do i=1,nres
 592         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 593       enddo
 594       call flush(iout)
 595 #endif
 596       do i=1,nres
 597         do j=1,3
 598           gradbufc_sum(j,i)=gradbufc(j,i)
 599           gradbufc(j,i)=0.0d0
 600         enddo
 601       enddo
 602       do j=1,3
 603         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 604       enddo
 605       do i=nres-2,nnt,-1
 606         do j=1,3
 607           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 608         enddo
 609       enddo
 610 c      do i=nnt,nres-1
 611 c        do k=1,3
 612 c          gradbufc(k,i)=0.0d0
 613 c        enddo
 614 c        do j=i+1,nres
 615 c          do k=1,3
 616 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 617 c          enddo
 618 c        enddo
 619 c      enddo
 620 #ifdef DEBUG
 621       write (iout,*) "gradbufc after summing"
 622       do i=1,nres
 623         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 624       enddo
 625       call flush(iout)
 626 #endif
 627 #ifdef MPI
 628       endif
 629 #endif
 630       do k=1,3
 631         gradbufc(k,nres)=0.0d0
 632       enddo
 633       do i=1,nct
 634         do j=1,3
 635 #ifdef SPLITELE
 636           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 637      &                wel_loc*gel_loc(j,i)+
 638      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 639      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 640      &                wel_loc*gel_loc_long(j,i)+
 641      &                wcorr*gradcorr_long(j,i)+
 642      &                wcorr5*gradcorr5_long(j,i)+
 643      &                wcorr6*gradcorr6_long(j,i)+
 644      &                wturn6*gcorr6_turn_long(j,i))+
 645      &                wbond*gradb(j,i)+
 646      &                wcorr*gradcorr(j,i)+
 647      &                wturn3*gcorr3_turn(j,i)+
 648      &                wturn4*gcorr4_turn(j,i)+
 649      &                wcorr5*gradcorr5(j,i)+
 650      &                wcorr6*gradcorr6(j,i)+
 651      &                wturn6*gcorr6_turn(j,i)+
 652      &                wsccor*gsccorc(j,i)
 653      &               +wscloc*gscloc(j,i)
 654 #else
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #endif
 674           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 675      &                  wbond*gradbx(j,i)+
 676      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 677      &                  wsccor*gsccorx(j,i)
 678      &                 +wscloc*gsclocx(j,i)
 679         enddo
 680       enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gloc before adding corr"
 683       do i=1,4*nres
 684         write (iout,*) i,gloc(i,icg)
 685       enddo
 686 #endif
 687       do i=1,nres-3
 688         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 689      &   +wcorr5*g_corr5_loc(i)
 690      &   +wcorr6*g_corr6_loc(i)
 691      &   +wturn4*gel_loc_turn4(i)
 692      &   +wturn3*gel_loc_turn3(i)
 693      &   +wturn6*gel_loc_turn6(i)
 694      &   +wel_loc*gel_loc_loc(i)
 695       enddo
 696 #ifdef DEBUG
 697       write (iout,*) "gloc after adding corr"
 698       do i=1,4*nres
 699         write (iout,*) i,gloc(i,icg)
 700       enddo
 701 #endif
 702 #ifdef MPI
 703       if (nfgtasks.gt.1) then
 704         do j=1,3
 705           do i=1,nres
 706             gradbufc(j,i)=gradc(j,i,icg)
 707             gradbufx(j,i)=gradx(j,i,icg)
 708           enddo
 709         enddo
 710         do i=1,4*nres
 711           glocbuf(i)=gloc(i,icg)
 712         enddo
 713 #define DEBUG
 714 #ifdef DEBUG
 715       write (iout,*) "gloc_sc before reduce"
 716       do i=1,nres
 717        do j=1,1
 718         write (iout,*) i,j,gloc_sc(j,i,icg)
 719        enddo
 720       enddo
 721 #endif
 722 #undef DEBUG
 723         do i=1,nres
 724          do j=1,3
 725           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 726          enddo
 727         enddo
 728         time00=MPI_Wtime()
 729         call MPI_Barrier(FG_COMM,IERR)
 730         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 731         time00=MPI_Wtime()
 732         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 737      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 738         time_reduce=time_reduce+MPI_Wtime()-time00
 739         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         time_reduce=time_reduce+MPI_Wtime()-time00
 742 #define DEBUG
 743 #ifdef DEBUG
 744       write (iout,*) "gloc_sc after reduce"
 745       do i=1,nres
 746        do j=1,1
 747         write (iout,*) i,j,gloc_sc(j,i,icg)
 748        enddo
 749       enddo
 750 #endif
 751 #undef DEBUG
 752 #ifdef DEBUG
 753       write (iout,*) "gloc after reduce"
 754       do i=1,4*nres
 755         write (iout,*) i,gloc(i,icg)
 756       enddo
 757 #endif
 758       endif
 759 #endif
 760       if (gnorm_check) then
 761 c
 762 c Compute the maximum elements of the gradient
 763 c
 764       gvdwc_max=0.0d0
 765       gvdwc_scp_max=0.0d0
 766       gelc_max=0.0d0
 767       gvdwpp_max=0.0d0
 768       gradb_max=0.0d0
 769       ghpbc_max=0.0d0
 770       gradcorr_max=0.0d0
 771       gel_loc_max=0.0d0
 772       gcorr3_turn_max=0.0d0
 773       gcorr4_turn_max=0.0d0
 774       gradcorr5_max=0.0d0
 775       gradcorr6_max=0.0d0
 776       gcorr6_turn_max=0.0d0
 777       gsccorc_max=0.0d0
 778       gscloc_max=0.0d0
 779       gvdwx_max=0.0d0
 780       gradx_scp_max=0.0d0
 781       ghpbx_max=0.0d0
 782       gradxorr_max=0.0d0
 783       gsccorx_max=0.0d0
 784       gsclocx_max=0.0d0
 785       do i=1,nct
 786         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 787         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 788         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 789         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 790      &   gvdwc_scp_max=gvdwc_scp_norm
 791         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 792         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 793         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 794         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 795         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 796         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 797         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 798         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 799         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 800         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 801         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 802         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 803         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 804      &    gcorr3_turn(1,i)))
 805         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 806      &    gcorr3_turn_max=gcorr3_turn_norm
 807         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 808      &    gcorr4_turn(1,i)))
 809         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 810      &    gcorr4_turn_max=gcorr4_turn_norm
 811         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 812         if (gradcorr5_norm.gt.gradcorr5_max)
 813      &    gradcorr5_max=gradcorr5_norm
 814         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 815         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 816         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 817      &    gcorr6_turn(1,i)))
 818         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 819      &    gcorr6_turn_max=gcorr6_turn_norm
 820         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 821         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 822         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 823         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 824         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 825         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 826         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 827         if (gradx_scp_norm.gt.gradx_scp_max)
 828      &    gradx_scp_max=gradx_scp_norm
 829         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 830         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 831         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 832         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 833         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 834         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 835         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 836         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 837       enddo
 838       if (gradout) then
 839 #ifdef AIX
 840         open(istat,file=statname,position="append")
 841 #else
 842         open(istat,file=statname,access="append")
 843 #endif
 844         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 845      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 846      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 847      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 848      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 849      &     gsccorx_max,gsclocx_max
 850         close(istat)
 851         if (gvdwc_max.gt.1.0d4) then
 852           write (iout,*) "gvdwc gvdwx gradb gradbx"
 853           do i=nnt,nct
 854             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 855      &        gradb(j,i),gradbx(j,i),j=1,3)
 856           enddo
 857           call pdbout(0.0d0,'cipiszcze',iout)
 858           call flush(iout)
 859         endif
 860       endif
 861       endif
 862 #ifdef DEBUG
 863       write (iout,*) "gradc gradx gloc"
 864       do i=1,nres
 865         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 866      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 867       enddo
 868 #endif
 869 #ifdef TIMING
 870       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 871 #endif
 872       return
 873       end
 874 c-------------------------------------------------------------------------------
 875       subroutine rescale_weights(t_bath)
 876       implicit real*8 (a-h,o-z)
 877       include 'DIMENSIONS'
 878       include 'COMMON.IOUNITS'
 879       include 'COMMON.FFIELD'
 880       include 'COMMON.SBRIDGE'
 881       double precision kfac /2.4d0/
 882       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 883 c      facT=temp0/t_bath
 884 c      facT=2*temp0/(t_bath+temp0)
 885       if (rescale_mode.eq.0) then
 886         facT=1.0d0
 887         facT2=1.0d0
 888         facT3=1.0d0
 889         facT4=1.0d0
 890         facT5=1.0d0
 891       else if (rescale_mode.eq.1) then
 892         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 893         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 894         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 895         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 896         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 897       else if (rescale_mode.eq.2) then
 898         x=t_bath/temp0
 899         x2=x*x
 900         x3=x2*x
 901         x4=x3*x
 902         x5=x4*x
 903         facT=licznik/dlog(dexp(x)+dexp(-x))
 904         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 905         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 906         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 907         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 908       else
 909         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 910         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 911 #ifdef MPI
 912        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 913 #endif
 914        stop 555
 915       endif
 916       welec=weights(3)*fact
 917       wcorr=weights(4)*fact3
 918       wcorr5=weights(5)*fact4
 919       wcorr6=weights(6)*fact5
 920       wel_loc=weights(7)*fact2
 921       wturn3=weights(8)*fact2
 922       wturn4=weights(9)*fact3
 923       wturn6=weights(10)*fact5
 924       wtor=weights(13)*fact
 925       wtor_d=weights(14)*fact2
 926       wsccor=weights(21)*fact
 927
 928       return
 929       end
 930 C------------------------------------------------------------------------
 931       subroutine enerprint(energia)
 932       implicit real*8 (a-h,o-z)
 933       include 'DIMENSIONS'
 934       include 'COMMON.IOUNITS'
 935       include 'COMMON.FFIELD'
 936       include 'COMMON.SBRIDGE'
 937       include 'COMMON.MD'
 938       double precision energia(0:n_ene)
 939       etot=energia(0)
 940       evdw=energia(1)
 941       evdw2=energia(2)
 942 #ifdef SCP14
 943       evdw2=energia(2)+energia(18)
 944 #else
 945       evdw2=energia(2)
 946 #endif
 947       ees=energia(3)
 948 #ifdef SPLITELE
 949       evdw1=energia(16)
 950 #endif
 951       ecorr=energia(4)
 952       ecorr5=energia(5)
 953       ecorr6=energia(6)
 954       eel_loc=energia(7)
 955       eello_turn3=energia(8)
 956       eello_turn4=energia(9)
 957       eello_turn6=energia(10)
 958       ebe=energia(11)
 959       escloc=energia(12)
 960       etors=energia(13)
 961       etors_d=energia(14)
 962       ehpb=energia(15)
 963       edihcnstr=energia(19)
 964       estr=energia(17)
 965       Uconst=energia(20)
 966       esccor=energia(21)
 967 #ifdef SPLITELE
 968       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 969      &  estr,wbond,ebe,wang,
 970      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 971      &  ecorr,wcorr,
 972      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 973      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 974      &  edihcnstr,ebr*nss,
 975      &  Uconst,etot
 976    10 format (/'Virtual-chain energies:'//
 977      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 978      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 979      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 980      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 981      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 982      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 983      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 984      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 985      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 986      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 987      & ' (SS bridges & dist. cnstr.)'/
 988      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 992      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 993      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 994      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 995      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 996      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 997      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 998      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 999      & 'ETOT=  ',1pE16.6,' (total)')
1000 #else
1001       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1002      &  estr,wbond,ebe,wang,
1003      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1004      &  ecorr,wcorr,
1005      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1006      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1007      &  ebr*nss,Uconst,etot
1008    10 format (/'Virtual-chain energies:'//
1009      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1010      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1011      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1012      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1013      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1014      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1015      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1016      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1017      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1018      & ' (SS bridges & dist. cnstr.)'/
1019      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1023      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1024      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1025      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1026      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1027      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1028      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1029      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1030      & 'ETOT=  ',1pE16.6,' (total)')
1031 #endif
1032       return
1033       end
1034 C-----------------------------------------------------------------------
1035       subroutine elj(evdw)
1036 C
1037 C This subroutine calculates the interaction energy of nonbonded side chains
1038 C assuming the LJ potential of interaction.
1039 C
1040       implicit real*8 (a-h,o-z)
1041       include 'DIMENSIONS'
1042       parameter (accur=1.0d-10)
1043       include 'COMMON.GEO'
1044       include 'COMMON.VAR'
1045       include 'COMMON.LOCAL'
1046       include 'COMMON.CHAIN'
1047       include 'COMMON.DERIV'
1048       include 'COMMON.INTERACT'
1049       include 'COMMON.TORSION'
1050       include 'COMMON.SBRIDGE'
1051       include 'COMMON.NAMES'
1052       include 'COMMON.IOUNITS'
1053       include 'COMMON.CONTACTS'
1054       dimension gg(3)
1055 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1056       evdw=0.0D0
1057       do i=iatsc_s,iatsc_e
1058         itypi=iabs(itype(i))
1059         if (itypi.eq.ntyp1) cycle
1060         itypi1=iabs(itype(i+1))
1061         xi=c(1,nres+i)
1062         yi=c(2,nres+i)
1063         zi=c(3,nres+i)
1064 C Change 12/1/95
1065         num_conti=0
1066 C
1067 C Calculate SC interaction energy.
1068 C
1069         do iint=1,nint_gr(i)
1070 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1071 cd   &                  'iend=',iend(i,iint)
1072           do j=istart(i,iint),iend(i,iint)
1073             itypj=iabs(itype(j))
1074             if (itypj.eq.ntyp1) cycle
1075             xj=c(1,nres+j)-xi
1076             yj=c(2,nres+j)-yi
1077             zj=c(3,nres+j)-zi
1078 C Change 12/1/95 to calculate four-body interactions
1079             rij=xj*xj+yj*yj+zj*zj
1080             rrij=1.0D0/rij
1081 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1082             eps0ij=eps(itypi,itypj)
1083             fac=rrij**expon2
1084             e1=fac*fac*aa(itypi,itypj)
1085             e2=fac*bb(itypi,itypj)
1086             evdwij=e1+e2
1087 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1088 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1089 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1090 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1091 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1092 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1093             evdw=evdw+evdwij
1094 C
1095 C Calculate the components of the gradient in DC and X
1096 C
1097             fac=-rrij*(e1+evdwij)
1098             gg(1)=xj*fac
1099             gg(2)=yj*fac
1100             gg(3)=zj*fac
1101             do k=1,3
1102               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1103               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1104               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1105               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1106             enddo
1107 cgrad            do k=i,j-1
1108 cgrad              do l=1,3
1109 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1110 cgrad              enddo
1111 cgrad            enddo
1112 C
1113 C 12/1/95, revised on 5/20/97
1114 C
1115 C Calculate the contact function. The ith column of the array JCONT will
1116 C contain the numbers of atoms that make contacts with the atom I (of numbers
1117 C greater than I). The arrays FACONT and GACONT will contain the values of
1118 C the contact function and its derivative.
1119 C
1120 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1121 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1122 C Uncomment next line, if the correlation interactions are contact function only
1123             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1124               rij=dsqrt(rij)
1125               sigij=sigma(itypi,itypj)
1126               r0ij=rs0(itypi,itypj)
1127 C
1128 C Check whether the SC's are not too far to make a contact.
1129 C
1130               rcut=1.5d0*r0ij
1131               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1132 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1133 C
1134               if (fcont.gt.0.0D0) then
1135 C If the SC-SC distance if close to sigma, apply spline.
1136 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1137 cAdam &             fcont1,fprimcont1)
1138 cAdam           fcont1=1.0d0-fcont1
1139 cAdam           if (fcont1.gt.0.0d0) then
1140 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1141 cAdam             fcont=fcont*fcont1
1142 cAdam           endif
1143 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1144 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1145 cga             do k=1,3
1146 cga               gg(k)=gg(k)*eps0ij
1147 cga             enddo
1148 cga             eps0ij=-evdwij*eps0ij
1149 C Uncomment for AL's type of SC correlation interactions.
1150 cadam           eps0ij=-evdwij
1151                 num_conti=num_conti+1
1152                 jcont(num_conti,i)=j
1153                 facont(num_conti,i)=fcont*eps0ij
1154                 fprimcont=eps0ij*fprimcont/rij
1155                 fcont=expon*fcont
1156 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1157 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1158 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1159 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1160                 gacont(1,num_conti,i)=-fprimcont*xj
1161                 gacont(2,num_conti,i)=-fprimcont*yj
1162                 gacont(3,num_conti,i)=-fprimcont*zj
1163 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1164 cd              write (iout,'(2i3,3f10.5)')
1165 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1166               endif
1167             endif
1168           enddo      ! j
1169         enddo        ! iint
1170 C Change 12/1/95
1171         num_cont(i)=num_conti
1172       enddo          ! i
1173       do i=1,nct
1174         do j=1,3
1175           gvdwc(j,i)=expon*gvdwc(j,i)
1176           gvdwx(j,i)=expon*gvdwx(j,i)
1177         enddo
1178       enddo
1179 C******************************************************************************
1180 C
1181 C                              N O T E !!!
1182 C
1183 C To save time, the factor of EXPON has been extracted from ALL components
1184 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1185 C use!
1186 C
1187 C******************************************************************************
1188       return
1189       end
1190 C-----------------------------------------------------------------------------
1191       subroutine eljk(evdw)
1192 C
1193 C This subroutine calculates the interaction energy of nonbonded side chains
1194 C assuming the LJK potential of interaction.
1195 C
1196       implicit real*8 (a-h,o-z)
1197       include 'DIMENSIONS'
1198       include 'COMMON.GEO'
1199       include 'COMMON.VAR'
1200       include 'COMMON.LOCAL'
1201       include 'COMMON.CHAIN'
1202       include 'COMMON.DERIV'
1203       include 'COMMON.INTERACT'
1204       include 'COMMON.IOUNITS'
1205       include 'COMMON.NAMES'
1206       dimension gg(3)
1207       logical scheck
1208 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1209       evdw=0.0D0
1210       do i=iatsc_s,iatsc_e
1211         itypi=iabs(itype(i))
1212         if (itypi.eq.ntyp1) cycle
1213         itypi1=iabs(itype(i+1))
1214         xi=c(1,nres+i)
1215         yi=c(2,nres+i)
1216         zi=c(3,nres+i)
1217 C
1218 C Calculate SC interaction energy.
1219 C
1220         do iint=1,nint_gr(i)
1221           do j=istart(i,iint),iend(i,iint)
1222             itypj=iabs(itype(j))
1223             if (itypj.eq.ntyp1) cycle
1224             xj=c(1,nres+j)-xi
1225             yj=c(2,nres+j)-yi
1226             zj=c(3,nres+j)-zi
1227             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1228             fac_augm=rrij**expon
1229             e_augm=augm(itypi,itypj)*fac_augm
1230             r_inv_ij=dsqrt(rrij)
1231             rij=1.0D0/r_inv_ij
1232             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1233             fac=r_shift_inv**expon
1234             e1=fac*fac*aa(itypi,itypj)
1235             e2=fac*bb(itypi,itypj)
1236             evdwij=e_augm+e1+e2
1237 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1238 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1239 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1240 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1241 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1242 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1243 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1244             evdw=evdw+evdwij
1245 C
1246 C Calculate the components of the gradient in DC and X
1247 C
1248             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1249             gg(1)=xj*fac
1250             gg(2)=yj*fac
1251             gg(3)=zj*fac
1252             do k=1,3
1253               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1254               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1255               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1256               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1257             enddo
1258 cgrad            do k=i,j-1
1259 cgrad              do l=1,3
1260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1261 cgrad              enddo
1262 cgrad            enddo
1263           enddo      ! j
1264         enddo        ! iint
1265       enddo          ! i
1266       do i=1,nct
1267         do j=1,3
1268           gvdwc(j,i)=expon*gvdwc(j,i)
1269           gvdwx(j,i)=expon*gvdwx(j,i)
1270         enddo
1271       enddo
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine ebp(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the Berne-Pechukas potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.NAMES'
1288       include 'COMMON.INTERACT'
1289       include 'COMMON.IOUNITS'
1290       include 'COMMON.CALC'
1291       common /srutu/ icall
1292 c     double precision rrsave(maxdim)
1293       logical lprn
1294       evdw=0.0D0
1295 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1296       evdw=0.0D0
1297 c     if (icall.eq.0) then
1298 c       lprn=.true.
1299 c     else
1300         lprn=.false.
1301 c     endif
1302       ind=0
1303       do i=iatsc_s,iatsc_e
1304         itypi=iabs(itype(i))
1305         if (itypi.eq.ntyp1) cycle
1306         itypi1=iabs(itype(i+1))
1307         xi=c(1,nres+i)
1308         yi=c(2,nres+i)
1309         zi=c(3,nres+i)
1310         dxi=dc_norm(1,nres+i)
1311         dyi=dc_norm(2,nres+i)
1312         dzi=dc_norm(3,nres+i)
1313 c        dsci_inv=dsc_inv(itypi)
1314         dsci_inv=vbld_inv(i+nres)
1315 C
1316 C Calculate SC interaction energy.
1317 C
1318         do iint=1,nint_gr(i)
1319           do j=istart(i,iint),iend(i,iint)
1320             ind=ind+1
1321             itypj=iabs(itype(j))
1322             if (itypj.eq.ntyp1) cycle
1323 c            dscj_inv=dsc_inv(itypj)
1324             dscj_inv=vbld_inv(j+nres)
1325             chi1=chi(itypi,itypj)
1326             chi2=chi(itypj,itypi)
1327             chi12=chi1*chi2
1328             chip1=chip(itypi)
1329             chip2=chip(itypj)
1330             chip12=chip1*chip2
1331             alf1=alp(itypi)
1332             alf2=alp(itypj)
1333             alf12=0.5D0*(alf1+alf2)
1334 C For diagnostics only!!!
1335 c           chi1=0.0D0
1336 c           chi2=0.0D0
1337 c           chi12=0.0D0
1338 c           chip1=0.0D0
1339 c           chip2=0.0D0
1340 c           chip12=0.0D0
1341 c           alf1=0.0D0
1342 c           alf2=0.0D0
1343 c           alf12=0.0D0
1344             xj=c(1,nres+j)-xi
1345             yj=c(2,nres+j)-yi
1346             zj=c(3,nres+j)-zi
1347             dxj=dc_norm(1,nres+j)
1348             dyj=dc_norm(2,nres+j)
1349             dzj=dc_norm(3,nres+j)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351 cd          if (icall.eq.0) then
1352 cd            rrsave(ind)=rrij
1353 cd          else
1354 cd            rrij=rrsave(ind)
1355 cd          endif
1356             rij=dsqrt(rrij)
1357 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1358             call sc_angular
1359 C Calculate whole angle-dependent part of epsilon and contributions
1360 C to its derivatives
1361             fac=(rrij*sigsq)**expon2
1362             e1=fac*fac*aa(itypi,itypj)
1363             e2=fac*bb(itypi,itypj)
1364             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1365             eps2der=evdwij*eps3rt
1366             eps3der=evdwij*eps2rt
1367             evdwij=evdwij*eps2rt*eps3rt
1368             evdw=evdw+evdwij
1369             if (lprn) then
1370             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1371             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1372 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1373 cd     &        restyp(itypi),i,restyp(itypj),j,
1374 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1375 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1376 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1377 cd     &        evdwij
1378             endif
1379 C Calculate gradient components.
1380             e1=e1*eps1*eps2rt**2*eps3rt**2
1381             fac=-expon*(e1+evdwij)
1382             sigder=fac/sigsq
1383             fac=rrij*fac
1384 C Calculate radial part of the gradient
1385             gg(1)=xj*fac
1386             gg(2)=yj*fac
1387             gg(3)=zj*fac
1388 C Calculate the angular part of the gradient and sum add the contributions
1389 C to the appropriate components of the Cartesian gradient.
1390             call sc_grad
1391           enddo      ! j
1392         enddo        ! iint
1393       enddo          ! i
1394 c     stop
1395       return
1396       end
1397 C-----------------------------------------------------------------------------
1398       subroutine egb(evdw)
1399 C
1400 C This subroutine calculates the interaction energy of nonbonded side chains
1401 C assuming the Gay-Berne potential of interaction.
1402 C
1403       implicit real*8 (a-h,o-z)
1404       include 'DIMENSIONS'
1405       include 'COMMON.GEO'
1406       include 'COMMON.VAR'
1407       include 'COMMON.LOCAL'
1408       include 'COMMON.CHAIN'
1409       include 'COMMON.DERIV'
1410       include 'COMMON.NAMES'
1411       include 'COMMON.INTERACT'
1412       include 'COMMON.IOUNITS'
1413       include 'COMMON.CALC'
1414       include 'COMMON.CONTROL'
1415       logical lprn
1416       evdw=0.0D0
1417 ccccc      energy_dec=.false.
1418 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       lprn=.false.
1421 c     if (icall.eq.0) lprn=.false.
1422       ind=0
1423       do i=iatsc_s,iatsc_e
1424         itypi=iabs(itype(i))
1425         if (itypi.eq.ntyp1) cycle
1426         itypi1=iabs(itype(i+1))
1427         xi=c(1,nres+i)
1428         yi=c(2,nres+i)
1429         zi=c(3,nres+i)
1430         dxi=dc_norm(1,nres+i)
1431         dyi=dc_norm(2,nres+i)
1432         dzi=dc_norm(3,nres+i)
1433 c        dsci_inv=dsc_inv(itypi)
1434         dsci_inv=vbld_inv(i+nres)
1435 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1436 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1437 C
1438 C Calculate SC interaction energy.
1439 C
1440         do iint=1,nint_gr(i)
1441           do j=istart(i,iint),iend(i,iint)
1442             ind=ind+1
1443             itypj=iabs(itype(j))
1444             if (itypj.eq.ntyp1) cycle
1445 c            dscj_inv=dsc_inv(itypj)
1446             dscj_inv=vbld_inv(j+nres)
1447 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1448 c     &       1.0d0/vbld(j+nres)
1449 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1450             sig0ij=sigma(itypi,itypj)
1451             chi1=chi(itypi,itypj)
1452             chi2=chi(itypj,itypi)
1453             chi12=chi1*chi2
1454             chip1=chip(itypi)
1455             chip2=chip(itypj)
1456             chip12=chip1*chip2
1457             alf1=alp(itypi)
1458             alf2=alp(itypj)
1459             alf12=0.5D0*(alf1+alf2)
1460 C For diagnostics only!!!
1461 c           chi1=0.0D0
1462 c           chi2=0.0D0
1463 c           chi12=0.0D0
1464 c           chip1=0.0D0
1465 c           chip2=0.0D0
1466 c           chip12=0.0D0
1467 c           alf1=0.0D0
1468 c           alf2=0.0D0
1469 c           alf12=0.0D0
1470             xj=c(1,nres+j)-xi
1471             yj=c(2,nres+j)-yi
1472             zj=c(3,nres+j)-zi
1473             dxj=dc_norm(1,nres+j)
1474             dyj=dc_norm(2,nres+j)
1475             dzj=dc_norm(3,nres+j)
1476 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1477 c            write (iout,*) "j",j," dc_norm",
1478 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480             rij=dsqrt(rrij)
1481 C Calculate angle-dependent terms of energy and contributions to their
1482 C derivatives.
1483             call sc_angular
1484             sigsq=1.0D0/sigsq
1485             sig=sig0ij*dsqrt(sigsq)
1486             rij_shift=1.0D0/rij-sig+sig0ij
1487 c for diagnostics; uncomment
1488 c            rij_shift=1.2*sig0ij
1489 C I hate to put IF's in the loops, but here don't have another choice!!!!
1490             if (rij_shift.le.0.0D0) then
1491               evdw=1.0D20
1492 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1493 cd     &        restyp(itypi),i,restyp(itypj),j,
1494 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1495               return
1496             endif
1497             sigder=-sig*sigsq
1498 c---------------------------------------------------------------
1499             rij_shift=1.0D0/rij_shift
1500             fac=rij_shift**expon
1501             e1=fac*fac*aa(itypi,itypj)
1502             e2=fac*bb(itypi,itypj)
1503             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1504             eps2der=evdwij*eps3rt
1505             eps3der=evdwij*eps2rt
1506 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1507 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1508             evdwij=evdwij*eps2rt*eps3rt
1509             evdw=evdw+evdwij
1510             if (lprn) then
1511             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1512             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1513             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1514      &        restyp(itypi),i,restyp(itypj),j,
1515      &        epsi,sigm,chi1,chi2,chip1,chip2,
1516      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1517      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1518      &        evdwij
1519             endif
1520
1521             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1522      &                        'evdw',i,j,evdwij
1523
1524 C Calculate gradient components.
1525             e1=e1*eps1*eps2rt**2*eps3rt**2
1526             fac=-expon*(e1+evdwij)*rij_shift
1527             sigder=fac*sigder
1528             fac=rij*fac
1529 c            fac=0.0d0
1530 C Calculate the radial part of the gradient
1531             gg(1)=xj*fac
1532             gg(2)=yj*fac
1533             gg(3)=zj*fac
1534 C Calculate angular part of the gradient.
1535             call sc_grad
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c      write (iout,*) "Number of loop steps in EGB:",ind
1540 cccc      energy_dec=.false.
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egbv(evdw)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne-Vorobjev potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       common /srutu/ icall
1561       logical lprn
1562       evdw=0.0D0
1563 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1564       evdw=0.0D0
1565       lprn=.false.
1566 c     if (icall.eq.0) lprn=.true.
1567       ind=0
1568       do i=iatsc_s,iatsc_e
1569         itypi=iabs(itype(i))
1570         if (itypi.eq.ntyp1) cycle
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 C
1581 C Calculate SC interaction energy.
1582 C
1583         do iint=1,nint_gr(i)
1584           do j=istart(i,iint),iend(i,iint)
1585             ind=ind+1
1586             itypj=iabs(itype(j))
1587             if (itypj.eq.ntyp1) cycle
1588 c            dscj_inv=dsc_inv(itypj)
1589             dscj_inv=vbld_inv(j+nres)
1590             sig0ij=sigma(itypi,itypj)
1591             r0ij=r0(itypi,itypj)
1592             chi1=chi(itypi,itypj)
1593             chi2=chi(itypj,itypi)
1594             chi12=chi1*chi2
1595             chip1=chip(itypi)
1596             chip2=chip(itypj)
1597             chip12=chip1*chip2
1598             alf1=alp(itypi)
1599             alf2=alp(itypj)
1600             alf12=0.5D0*(alf1+alf2)
1601 C For diagnostics only!!!
1602 c           chi1=0.0D0
1603 c           chi2=0.0D0
1604 c           chi12=0.0D0
1605 c           chip1=0.0D0
1606 c           chip2=0.0D0
1607 c           chip12=0.0D0
1608 c           alf1=0.0D0
1609 c           alf2=0.0D0
1610 c           alf12=0.0D0
1611             xj=c(1,nres+j)-xi
1612             yj=c(2,nres+j)-yi
1613             zj=c(3,nres+j)-zi
1614             dxj=dc_norm(1,nres+j)
1615             dyj=dc_norm(2,nres+j)
1616             dzj=dc_norm(3,nres+j)
1617             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1618             rij=dsqrt(rrij)
1619 C Calculate angle-dependent terms of energy and contributions to their
1620 C derivatives.
1621             call sc_angular
1622             sigsq=1.0D0/sigsq
1623             sig=sig0ij*dsqrt(sigsq)
1624             rij_shift=1.0D0/rij-sig+r0ij
1625 C I hate to put IF's in the loops, but here don't have another choice!!!!
1626             if (rij_shift.le.0.0D0) then
1627               evdw=1.0D20
1628               return
1629             endif
1630             sigder=-sig*sigsq
1631 c---------------------------------------------------------------
1632             rij_shift=1.0D0/rij_shift
1633             fac=rij_shift**expon
1634             e1=fac*fac*aa(itypi,itypj)
1635             e2=fac*bb(itypi,itypj)
1636             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1637             eps2der=evdwij*eps3rt
1638             eps3der=evdwij*eps2rt
1639             fac_augm=rrij**expon
1640             e_augm=augm(itypi,itypj)*fac_augm
1641             evdwij=evdwij*eps2rt*eps3rt
1642             evdw=evdw+evdwij+e_augm
1643             if (lprn) then
1644             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1645             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1646             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1647      &        restyp(itypi),i,restyp(itypj),j,
1648      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1649      &        chi1,chi2,chip1,chip2,
1650      &        eps1,eps2rt**2,eps3rt**2,
1651      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1652      &        evdwij+e_augm
1653             endif
1654 C Calculate gradient components.
1655             e1=e1*eps1*eps2rt**2*eps3rt**2
1656             fac=-expon*(e1+evdwij)*rij_shift
1657             sigder=fac*sigder
1658             fac=rij*fac-2*expon*rrij*e_augm
1659 C Calculate the radial part of the gradient
1660             gg(1)=xj*fac
1661             gg(2)=yj*fac
1662             gg(3)=zj*fac
1663 C Calculate angular part of the gradient.
1664             call sc_grad
1665           enddo      ! j
1666         enddo        ! iint
1667       enddo          ! i
1668       end
1669 C-----------------------------------------------------------------------------
1670       subroutine sc_angular
1671 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1672 C om12. Called by ebp, egb, and egbv.
1673       implicit none
1674       include 'COMMON.CALC'
1675       include 'COMMON.IOUNITS'
1676       erij(1)=xj*rij
1677       erij(2)=yj*rij
1678       erij(3)=zj*rij
1679       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1680       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1681       om12=dxi*dxj+dyi*dyj+dzi*dzj
1682       chiom12=chi12*om12
1683 C Calculate eps1(om12) and its derivative in om12
1684       faceps1=1.0D0-om12*chiom12
1685       faceps1_inv=1.0D0/faceps1
1686       eps1=dsqrt(faceps1_inv)
1687 C Following variable is eps1*deps1/dom12
1688       eps1_om12=faceps1_inv*chiom12
1689 c diagnostics only
1690 c      faceps1_inv=om12
1691 c      eps1=om12
1692 c      eps1_om12=1.0d0
1693 c      write (iout,*) "om12",om12," eps1",eps1
1694 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1695 C and om12.
1696       om1om2=om1*om2
1697       chiom1=chi1*om1
1698       chiom2=chi2*om2
1699       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1700       sigsq=1.0D0-facsig*faceps1_inv
1701       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1702       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1703       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1704 c diagnostics only
1705 c      sigsq=1.0d0
1706 c      sigsq_om1=0.0d0
1707 c      sigsq_om2=0.0d0
1708 c      sigsq_om12=0.0d0
1709 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1710 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1711 c     &    " eps1",eps1
1712 C Calculate eps2 and its derivatives in om1, om2, and om12.
1713       chipom1=chip1*om1
1714       chipom2=chip2*om2
1715       chipom12=chip12*om12
1716       facp=1.0D0-om12*chipom12
1717       facp_inv=1.0D0/facp
1718       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1719 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1720 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1721 C Following variable is the square root of eps2
1722       eps2rt=1.0D0-facp1*facp_inv
1723 C Following three variables are the derivatives of the square root of eps
1724 C in om1, om2, and om12.
1725       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1726       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1727       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1728 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1729       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1730 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1731 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1732 c     &  " eps2rt_om12",eps2rt_om12
1733 C Calculate whole angle-dependent part of epsilon and contributions
1734 C to its derivatives
1735       return
1736       end
1737 C----------------------------------------------------------------------------
1738       subroutine sc_grad
1739       implicit real*8 (a-h,o-z)
1740       include 'DIMENSIONS'
1741       include 'COMMON.CHAIN'
1742       include 'COMMON.DERIV'
1743       include 'COMMON.CALC'
1744       include 'COMMON.IOUNITS'
1745       double precision dcosom1(3),dcosom2(3)
1746       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1747       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1748       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1749      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1750 c diagnostics only
1751 c      eom1=0.0d0
1752 c      eom2=0.0d0
1753 c      eom12=evdwij*eps1_om12
1754 c end diagnostics
1755 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1756 c     &  " sigder",sigder
1757 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1758 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1759       do k=1,3
1760         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1761         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1762       enddo
1763       do k=1,3
1764         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1765       enddo
1766 c      write (iout,*) "gg",(gg(k),k=1,3)
1767       do k=1,3
1768         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1769      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1770      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1771         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1772      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1773      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1774 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1775 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1776 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1777 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1778       enddo
1779 C
1780 C Calculate the components of the gradient in DC and X
1781 C
1782 cgrad      do k=i,j-1
1783 cgrad        do l=1,3
1784 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1785 cgrad        enddo
1786 cgrad      enddo
1787       do l=1,3
1788         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1789         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1790       enddo
1791       return
1792       end
1793 C-----------------------------------------------------------------------
1794       subroutine e_softsphere(evdw)
1795 C
1796 C This subroutine calculates the interaction energy of nonbonded side chains
1797 C assuming the LJ potential of interaction.
1798 C
1799       implicit real*8 (a-h,o-z)
1800       include 'DIMENSIONS'
1801       parameter (accur=1.0d-10)
1802       include 'COMMON.GEO'
1803       include 'COMMON.VAR'
1804       include 'COMMON.LOCAL'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.INTERACT'
1808       include 'COMMON.TORSION'
1809       include 'COMMON.SBRIDGE'
1810       include 'COMMON.NAMES'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CONTACTS'
1813       dimension gg(3)
1814 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1815       evdw=0.0D0
1816       do i=iatsc_s,iatsc_e
1817         itypi=iabs(itype(i))
1818         if (itypi.eq.ntyp1) cycle
1819         itypi1=iabs(itype(i+1))
1820         xi=c(1,nres+i)
1821         yi=c(2,nres+i)
1822         zi=c(3,nres+i)
1823 C
1824 C Calculate SC interaction energy.
1825 C
1826         do iint=1,nint_gr(i)
1827 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1828 cd   &                  'iend=',iend(i,iint)
1829           do j=istart(i,iint),iend(i,iint)
1830             itypj=iabs(itype(j))
1831             if (itypj.eq.ntyp1) cycle
1832             xj=c(1,nres+j)-xi
1833             yj=c(2,nres+j)-yi
1834             zj=c(3,nres+j)-zi
1835             rij=xj*xj+yj*yj+zj*zj
1836 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1837             r0ij=r0(itypi,itypj)
1838             r0ijsq=r0ij*r0ij
1839 c            print *,i,j,r0ij,dsqrt(rij)
1840             if (rij.lt.r0ijsq) then
1841               evdwij=0.25d0*(rij-r0ijsq)**2
1842               fac=rij-r0ijsq
1843             else
1844               evdwij=0.0d0
1845               fac=0.0d0
1846             endif
1847             evdw=evdw+evdwij
1848 C
1849 C Calculate the components of the gradient in DC and X
1850 C
1851             gg(1)=xj*fac
1852             gg(2)=yj*fac
1853             gg(3)=zj*fac
1854             do k=1,3
1855               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1856               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1857               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1858               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1859             enddo
1860 cgrad            do k=i,j-1
1861 cgrad              do l=1,3
1862 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1863 cgrad              enddo
1864 cgrad            enddo
1865           enddo ! j
1866         enddo ! iint
1867       enddo ! i
1868       return
1869       end
1870 C--------------------------------------------------------------------------
1871       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1872      &              eello_turn4)
1873 C
1874 C Soft-sphere potential of p-p interaction
1875 C
1876       implicit real*8 (a-h,o-z)
1877       include 'DIMENSIONS'
1878       include 'COMMON.CONTROL'
1879       include 'COMMON.IOUNITS'
1880       include 'COMMON.GEO'
1881       include 'COMMON.VAR'
1882       include 'COMMON.LOCAL'
1883       include 'COMMON.CHAIN'
1884       include 'COMMON.DERIV'
1885       include 'COMMON.INTERACT'
1886       include 'COMMON.CONTACTS'
1887       include 'COMMON.TORSION'
1888       include 'COMMON.VECTORS'
1889       include 'COMMON.FFIELD'
1890       dimension ggg(3)
1891 cd      write(iout,*) 'In EELEC_soft_sphere'
1892       ees=0.0D0
1893       evdw1=0.0D0
1894       eel_loc=0.0d0
1895       eello_turn3=0.0d0
1896       eello_turn4=0.0d0
1897       ind=0
1898       do i=iatel_s,iatel_e
1899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1900         dxi=dc(1,i)
1901         dyi=dc(2,i)
1902         dzi=dc(3,i)
1903         xmedi=c(1,i)+0.5d0*dxi
1904         ymedi=c(2,i)+0.5d0*dyi
1905         zmedi=c(3,i)+0.5d0*dzi
1906         num_conti=0
1907 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1908         do j=ielstart(i),ielend(i)
1909           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1910           ind=ind+1
1911           iteli=itel(i)
1912           itelj=itel(j)
1913           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1914           r0ij=rpp(iteli,itelj)
1915           r0ijsq=r0ij*r0ij
1916           dxj=dc(1,j)
1917           dyj=dc(2,j)
1918           dzj=dc(3,j)
1919           xj=c(1,j)+0.5D0*dxj-xmedi
1920           yj=c(2,j)+0.5D0*dyj-ymedi
1921           zj=c(3,j)+0.5D0*dzj-zmedi
1922           rij=xj*xj+yj*yj+zj*zj
1923           if (rij.lt.r0ijsq) then
1924             evdw1ij=0.25d0*(rij-r0ijsq)**2
1925             fac=rij-r0ijsq
1926           else
1927             evdw1ij=0.0d0
1928             fac=0.0d0
1929           endif
1930           evdw1=evdw1+evdw1ij
1931 C
1932 C Calculate contributions to the Cartesian gradient.
1933 C
1934           ggg(1)=fac*xj
1935           ggg(2)=fac*yj
1936           ggg(3)=fac*zj
1937           do k=1,3
1938             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1940           enddo
1941 *
1942 * Loop over residues i+1 thru j-1.
1943 *
1944 cgrad          do k=i+1,j-1
1945 cgrad            do l=1,3
1946 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1947 cgrad            enddo
1948 cgrad          enddo
1949         enddo ! j
1950       enddo   ! i
1951 cgrad      do i=nnt,nct-1
1952 cgrad        do k=1,3
1953 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1954 cgrad        enddo
1955 cgrad        do j=i+1,nct-1
1956 cgrad          do k=1,3
1957 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1958 cgrad          enddo
1959 cgrad        enddo
1960 cgrad      enddo
1961       return
1962       end
1963 c------------------------------------------------------------------------------
1964       subroutine vec_and_deriv
1965       implicit real*8 (a-h,o-z)
1966       include 'DIMENSIONS'
1967 #ifdef MPI
1968       include 'mpif.h'
1969 #endif
1970       include 'COMMON.IOUNITS'
1971       include 'COMMON.GEO'
1972       include 'COMMON.VAR'
1973       include 'COMMON.LOCAL'
1974       include 'COMMON.CHAIN'
1975       include 'COMMON.VECTORS'
1976       include 'COMMON.SETUP'
1977       include 'COMMON.TIME1'
1978       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1979 C Compute the local reference systems. For reference system (i), the
1980 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1981 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1982 #ifdef PARVEC
1983       do i=ivec_start,ivec_end
1984 #else
1985       do i=1,nres-1
1986 #endif
1987           if (i.eq.nres-1) then
1988 C Case of the last full residue
1989 C Compute the Z-axis
1990             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1991             costh=dcos(pi-theta(nres))
1992             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1993             do k=1,3
1994               uz(k,i)=fac*uz(k,i)
1995             enddo
1996 C Compute the derivatives of uz
1997             uzder(1,1,1)= 0.0d0
1998             uzder(2,1,1)=-dc_norm(3,i-1)
1999             uzder(3,1,1)= dc_norm(2,i-1)
2000             uzder(1,2,1)= dc_norm(3,i-1)
2001             uzder(2,2,1)= 0.0d0
2002             uzder(3,2,1)=-dc_norm(1,i-1)
2003             uzder(1,3,1)=-dc_norm(2,i-1)
2004             uzder(2,3,1)= dc_norm(1,i-1)
2005             uzder(3,3,1)= 0.0d0
2006             uzder(1,1,2)= 0.0d0
2007             uzder(2,1,2)= dc_norm(3,i)
2008             uzder(3,1,2)=-dc_norm(2,i)
2009             uzder(1,2,2)=-dc_norm(3,i)
2010             uzder(2,2,2)= 0.0d0
2011             uzder(3,2,2)= dc_norm(1,i)
2012             uzder(1,3,2)= dc_norm(2,i)
2013             uzder(2,3,2)=-dc_norm(1,i)
2014             uzder(3,3,2)= 0.0d0
2015 C Compute the Y-axis
2016             facy=fac
2017             do k=1,3
2018               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2019             enddo
2020 C Compute the derivatives of uy
2021             do j=1,3
2022               do k=1,3
2023                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2024      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2025                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2026               enddo
2027               uyder(j,j,1)=uyder(j,j,1)-costh
2028               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2029             enddo
2030             do j=1,2
2031               do k=1,3
2032                 do l=1,3
2033                   uygrad(l,k,j,i)=uyder(l,k,j)
2034                   uzgrad(l,k,j,i)=uzder(l,k,j)
2035                 enddo
2036               enddo
2037             enddo
2038             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2039             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2040             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2041             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2042           else
2043 C Other residues
2044 C Compute the Z-axis
2045             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2046             costh=dcos(pi-theta(i+2))
2047             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2048             do k=1,3
2049               uz(k,i)=fac*uz(k,i)
2050             enddo
2051 C Compute the derivatives of uz
2052             uzder(1,1,1)= 0.0d0
2053             uzder(2,1,1)=-dc_norm(3,i+1)
2054             uzder(3,1,1)= dc_norm(2,i+1)
2055             uzder(1,2,1)= dc_norm(3,i+1)
2056             uzder(2,2,1)= 0.0d0
2057             uzder(3,2,1)=-dc_norm(1,i+1)
2058             uzder(1,3,1)=-dc_norm(2,i+1)
2059             uzder(2,3,1)= dc_norm(1,i+1)
2060             uzder(3,3,1)= 0.0d0
2061             uzder(1,1,2)= 0.0d0
2062             uzder(2,1,2)= dc_norm(3,i)
2063             uzder(3,1,2)=-dc_norm(2,i)
2064             uzder(1,2,2)=-dc_norm(3,i)
2065             uzder(2,2,2)= 0.0d0
2066             uzder(3,2,2)= dc_norm(1,i)
2067             uzder(1,3,2)= dc_norm(2,i)
2068             uzder(2,3,2)=-dc_norm(1,i)
2069             uzder(3,3,2)= 0.0d0
2070 C Compute the Y-axis
2071             facy=fac
2072             do k=1,3
2073               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2074             enddo
2075 C Compute the derivatives of uy
2076             do j=1,3
2077               do k=1,3
2078                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2079      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2080                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2081               enddo
2082               uyder(j,j,1)=uyder(j,j,1)-costh
2083               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2084             enddo
2085             do j=1,2
2086               do k=1,3
2087                 do l=1,3
2088                   uygrad(l,k,j,i)=uyder(l,k,j)
2089                   uzgrad(l,k,j,i)=uzder(l,k,j)
2090                 enddo
2091               enddo
2092             enddo
2093             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2094             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2095             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2096             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2097           endif
2098       enddo
2099       do i=1,nres-1
2100         vbld_inv_temp(1)=vbld_inv(i+1)
2101         if (i.lt.nres-1) then
2102           vbld_inv_temp(2)=vbld_inv(i+2)
2103           else
2104           vbld_inv_temp(2)=vbld_inv(i)
2105           endif
2106         do j=1,2
2107           do k=1,3
2108             do l=1,3
2109               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2110               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2111             enddo
2112           enddo
2113         enddo
2114       enddo
2115 #if defined(PARVEC) && defined(MPI)
2116       if (nfgtasks1.gt.1) then
2117         time00=MPI_Wtime()
2118 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2119 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2120 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2121         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2122      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2123      &   FG_COMM1,IERR)
2124         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2125      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2126      &   FG_COMM1,IERR)
2127         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2128      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2129      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2130         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2131      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2132      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2133         time_gather=time_gather+MPI_Wtime()-time00
2134       endif
2135 c      if (fg_rank.eq.0) then
2136 c        write (iout,*) "Arrays UY and UZ"
2137 c        do i=1,nres-1
2138 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2139 c     &     (uz(k,i),k=1,3)
2140 c        enddo
2141 c      endif
2142 #endif
2143       return
2144       end
2145 C-----------------------------------------------------------------------------
2146       subroutine check_vecgrad
2147       implicit real*8 (a-h,o-z)
2148       include 'DIMENSIONS'
2149       include 'COMMON.IOUNITS'
2150       include 'COMMON.GEO'
2151       include 'COMMON.VAR'
2152       include 'COMMON.LOCAL'
2153       include 'COMMON.CHAIN'
2154       include 'COMMON.VECTORS'
2155       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2156       dimension uyt(3,maxres),uzt(3,maxres)
2157       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2158       double precision delta /1.0d-7/
2159       call vec_and_deriv
2160 cd      do i=1,nres
2161 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2162 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2163 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2164 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2165 cd     &     (dc_norm(if90,i),if90=1,3)
2166 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2167 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2168 cd          write(iout,'(a)')
2169 cd      enddo
2170       do i=1,nres
2171         do j=1,2
2172           do k=1,3
2173             do l=1,3
2174               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2175               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2176             enddo
2177           enddo
2178         enddo
2179       enddo
2180       call vec_and_deriv
2181       do i=1,nres
2182         do j=1,3
2183           uyt(j,i)=uy(j,i)
2184           uzt(j,i)=uz(j,i)
2185         enddo
2186       enddo
2187       do i=1,nres
2188 cd        write (iout,*) 'i=',i
2189         do k=1,3
2190           erij(k)=dc_norm(k,i)
2191         enddo
2192         do j=1,3
2193           do k=1,3
2194             dc_norm(k,i)=erij(k)
2195           enddo
2196           dc_norm(j,i)=dc_norm(j,i)+delta
2197 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2198 c          do k=1,3
2199 c            dc_norm(k,i)=dc_norm(k,i)/fac
2200 c          enddo
2201 c          write (iout,*) (dc_norm(k,i),k=1,3)
2202 c          write (iout,*) (erij(k),k=1,3)
2203           call vec_and_deriv
2204           do k=1,3
2205             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2206             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2207             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2208             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2209           enddo
2210 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2211 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2212 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2213         enddo
2214         do k=1,3
2215           dc_norm(k,i)=erij(k)
2216         enddo
2217 cd        do k=1,3
2218 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2219 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2220 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2221 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2222 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2223 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2224 cd          write (iout,'(a)')
2225 cd        enddo
2226       enddo
2227       return
2228       end
2229 C--------------------------------------------------------------------------
2230       subroutine set_matrices
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233 #ifdef MPI
2234       include "mpif.h"
2235       include "COMMON.SETUP"
2236       integer IERR
2237       integer status(MPI_STATUS_SIZE)
2238 #endif
2239       include 'COMMON.IOUNITS'
2240       include 'COMMON.GEO'
2241       include 'COMMON.VAR'
2242       include 'COMMON.LOCAL'
2243       include 'COMMON.CHAIN'
2244       include 'COMMON.DERIV'
2245       include 'COMMON.INTERACT'
2246       include 'COMMON.CONTACTS'
2247       include 'COMMON.TORSION'
2248       include 'COMMON.VECTORS'
2249       include 'COMMON.FFIELD'
2250       double precision auxvec(2),auxmat(2,2)
2251 C
2252 C Compute the virtual-bond-torsional-angle dependent quantities needed
2253 C to calculate the el-loc multibody terms of various order.
2254 C
2255       write(iout,*) 'nphi=',nphi,nres
2256 #ifdef PARMAT
2257       do i=ivec_start+2,ivec_end+2
2258 #else
2259       do i=3,nres+1
2260 #endif
2261 #ifdef NEWCORR
2262         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2263           iti = itortyp(itype(i-2))
2264         else
2265           iti=ntortyp+1
2266         endif
2267 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2268         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2269           iti1 = itortyp(itype(i-1))
2270         else
2271           iti1=ntortyp+1
2272         endif
2273 c        write(iout,*),i
2274         b1(1,i-2)=bnew1(1,1,iti)*sin(theta(i-1)/2.0)
2275      &           +bnew1(2,1,iti)*sin(theta(i-1))
2276      &           +bnew1(3,1,iti)*cos(theta(i-1)/2.0)
2277         gtb1(1,i-2)=bnew1(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2278      &             +bnew1(2,1,iti)*cos(theta(i-1))
2279      &             -bnew1(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2280 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2281 c     &*(cos(theta(i)/2.0)
2282         b2(1,i-2)=bnew2(1,1,iti)*sin(theta(i-1)/2.0)
2283      &           +bnew2(2,1,iti)*sin(theta(i-1))
2284      &           +bnew2(3,1,iti)*cos(theta(i-1)/2.0)
2285 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2286 c     &*(cos(theta(i)/2.0)
2287         gtb2(1,i-2)=bnew2(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2288      &             +bnew2(2,1,iti)*cos(theta(i-1))
2289      &             -bnew2(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2290 c        if (ggb1(1,i).eq.0.0d0) then
2291 c        write(iout,*) 'i=',i,ggb1(1,i),
2292 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2293 c     &bnew1(2,1,iti)*cos(theta(i)),
2294 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2295 c        endif
2296         b1(2,i-2)=bnew1(1,2,iti)
2297         gtb1(2,i-2)=0.0
2298         b2(2,i-2)=bnew2(1,2,iti)
2299         gtb2(2,i-2)=0.0
2300         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2301         EE(1,2,i-2)=eeold(1,2,iti)
2302         EE(2,1,i-2)=eeold(2,1,iti)
2303         EE(2,2,i-2)=eeold(2,2,iti)
2304         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2305         gtEE(1,2,i-2)=0.0d0
2306         gtEE(2,2,i-2)=0.0d0
2307         gtEE(2,1,i-2)=0.0d0
2308 c        EE(2,2,iti)=0.0d0
2309 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2310 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2311 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2312 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2313        b1tilde(1,i-2)=b1(1,i-2)
2314        b1tilde(2,i-2)=-b1(2,i-2)
2315        b2tilde(1,i-2)=b2(1,i-2)
2316        b2tilde(2,i-2)=-b2(2,i-2)
2317 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2318 c       write (iout,*) 'theta=', theta(i-1)
2319        enddo
2320 #ifdef PARMAT
2321       do i=ivec_start+2,ivec_end+2
2322 #else
2323       do i=3,nres+1
2324 #endif
2325 #endif
2326         if (i .lt. nres+1) then
2327           sin1=dsin(phi(i))
2328           cos1=dcos(phi(i))
2329           sintab(i-2)=sin1
2330           costab(i-2)=cos1
2331           obrot(1,i-2)=cos1
2332           obrot(2,i-2)=sin1
2333           sin2=dsin(2*phi(i))
2334           cos2=dcos(2*phi(i))
2335           sintab2(i-2)=sin2
2336           costab2(i-2)=cos2
2337           obrot2(1,i-2)=cos2
2338           obrot2(2,i-2)=sin2
2339           Ug(1,1,i-2)=-cos1
2340           Ug(1,2,i-2)=-sin1
2341           Ug(2,1,i-2)=-sin1
2342           Ug(2,2,i-2)= cos1
2343           Ug2(1,1,i-2)=-cos2
2344           Ug2(1,2,i-2)=-sin2
2345           Ug2(2,1,i-2)=-sin2
2346           Ug2(2,2,i-2)= cos2
2347         else
2348           costab(i-2)=1.0d0
2349           sintab(i-2)=0.0d0
2350           obrot(1,i-2)=1.0d0
2351           obrot(2,i-2)=0.0d0
2352           obrot2(1,i-2)=0.0d0
2353           obrot2(2,i-2)=0.0d0
2354           Ug(1,1,i-2)=1.0d0
2355           Ug(1,2,i-2)=0.0d0
2356           Ug(2,1,i-2)=0.0d0
2357           Ug(2,2,i-2)=1.0d0
2358           Ug2(1,1,i-2)=0.0d0
2359           Ug2(1,2,i-2)=0.0d0
2360           Ug2(2,1,i-2)=0.0d0
2361           Ug2(2,2,i-2)=0.0d0
2362         endif
2363         if (i .gt. 3 .and. i .lt. nres+1) then
2364           obrot_der(1,i-2)=-sin1
2365           obrot_der(2,i-2)= cos1
2366           Ugder(1,1,i-2)= sin1
2367           Ugder(1,2,i-2)=-cos1
2368           Ugder(2,1,i-2)=-cos1
2369           Ugder(2,2,i-2)=-sin1
2370           dwacos2=cos2+cos2
2371           dwasin2=sin2+sin2
2372           obrot2_der(1,i-2)=-dwasin2
2373           obrot2_der(2,i-2)= dwacos2
2374           Ug2der(1,1,i-2)= dwasin2
2375           Ug2der(1,2,i-2)=-dwacos2
2376           Ug2der(2,1,i-2)=-dwacos2
2377           Ug2der(2,2,i-2)=-dwasin2
2378         else
2379           obrot_der(1,i-2)=0.0d0
2380           obrot_der(2,i-2)=0.0d0
2381           Ugder(1,1,i-2)=0.0d0
2382           Ugder(1,2,i-2)=0.0d0
2383           Ugder(2,1,i-2)=0.0d0
2384           Ugder(2,2,i-2)=0.0d0
2385           obrot2_der(1,i-2)=0.0d0
2386           obrot2_der(2,i-2)=0.0d0
2387           Ug2der(1,1,i-2)=0.0d0
2388           Ug2der(1,2,i-2)=0.0d0
2389           Ug2der(2,1,i-2)=0.0d0
2390           Ug2der(2,2,i-2)=0.0d0
2391         endif
2392 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2393         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2394           iti = itortyp(itype(i-2))
2395         else
2396           iti=ntortyp+1
2397         endif
2398 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2399         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2400           iti1 = itortyp(itype(i-1))
2401         else
2402           iti1=ntortyp+1
2403         endif
2404 cd        write (iout,*) '*******i',i,' iti1',iti
2405 cd        write (iout,*) 'b1',b1(:,iti)
2406 cd        write (iout,*) 'b2',b2(:,iti)
2407 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2408 c        if (i .gt. iatel_s+2) then
2409         if (i .gt. nnt+2) then
2410           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2411 #ifdef NEWCORR
2412           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2413 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2414 #endif
2415 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2416 c     &    EE(1,2,iti),EE(2,2,iti)
2417           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2418           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2419 c          write(iout,*) "Macierz EUG",
2420 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2421 c     &    eug(2,2,i-2)
2422           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2423      &    then
2424           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2425           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2426           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2427           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2428           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2429           endif
2430         else
2431           do k=1,2
2432             Ub2(k,i-2)=0.0d0
2433             Ctobr(k,i-2)=0.0d0
2434             Dtobr2(k,i-2)=0.0d0
2435             do l=1,2
2436               EUg(l,k,i-2)=0.0d0
2437               CUg(l,k,i-2)=0.0d0
2438               DUg(l,k,i-2)=0.0d0
2439               DtUg2(l,k,i-2)=0.0d0
2440             enddo
2441           enddo
2442         endif
2443         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2444         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2445         do k=1,2
2446           muder(k,i-2)=Ub2der(k,i-2)
2447         enddo
2448 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2449         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2450           if (itype(i-1).le.ntyp) then
2451             iti1 = itortyp(itype(i-1))
2452           else
2453             iti1=ntortyp+1
2454           endif
2455         else
2456           iti1=ntortyp+1
2457         endif
2458         do k=1,2
2459           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2460         enddo
2461 cd        write (iout,*) 'mu ',mu(:,i-2)
2462 cd        write (iout,*) 'mu1',mu1(:,i-2)
2463 cd        write (iout,*) 'mu2',mu2(:,i-2)
2464         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2465      &  then
2466         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2467         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2468         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2469         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2470         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2471 C Vectors and matrices dependent on a single virtual-bond dihedral.
2472         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2473         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2474         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2475         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2476         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2477         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2478         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2479         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2480         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2481         endif
2482       enddo
2483 C Matrices dependent on two consecutive virtual-bond dihedrals.
2484 C The order of matrices is from left to right.
2485       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2486      &then
2487 c      do i=max0(ivec_start,2),ivec_end
2488       do i=2,nres-1
2489         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2490         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2491         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2492         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2493         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2494         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2495         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2496         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2497       enddo
2498       endif
2499 #if defined(MPI) && defined(PARMAT)
2500 #ifdef DEBUG
2501 c      if (fg_rank.eq.0) then
2502         write (iout,*) "Arrays UG and UGDER before GATHER"
2503         do i=1,nres-1
2504           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2505      &     ((ug(l,k,i),l=1,2),k=1,2),
2506      &     ((ugder(l,k,i),l=1,2),k=1,2)
2507         enddo
2508         write (iout,*) "Arrays UG2 and UG2DER"
2509         do i=1,nres-1
2510           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2511      &     ((ug2(l,k,i),l=1,2),k=1,2),
2512      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2513         enddo
2514         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2515         do i=1,nres-1
2516           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2517      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2518      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2519         enddo
2520         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2521         do i=1,nres-1
2522           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2523      &     costab(i),sintab(i),costab2(i),sintab2(i)
2524         enddo
2525         write (iout,*) "Array MUDER"
2526         do i=1,nres-1
2527           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2528         enddo
2529 c      endif
2530 #endif
2531       if (nfgtasks.gt.1) then
2532         time00=MPI_Wtime()
2533 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2534 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2535 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2536 #ifdef MATGATHER
2537         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2538      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2539      &   FG_COMM1,IERR)
2540         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2541      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2542      &   FG_COMM1,IERR)
2543         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2544      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2545      &   FG_COMM1,IERR)
2546         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2547      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2548      &   FG_COMM1,IERR)
2549         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2550      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2551      &   FG_COMM1,IERR)
2552         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2556      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2557      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2558         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2559      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2560      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2561         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2562      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2563      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2564         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2565      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2566      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2567         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2568      &  then
2569         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2570      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2571      &   FG_COMM1,IERR)
2572         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2573      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2574      &   FG_COMM1,IERR)
2575         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2576      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2577      &   FG_COMM1,IERR)
2578        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2579      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2580      &   FG_COMM1,IERR)
2581         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2582      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2583      &   FG_COMM1,IERR)
2584         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2585      &   ivec_count(fg_rank1),
2586      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2587      &   FG_COMM1,IERR)
2588         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2589      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2590      &   FG_COMM1,IERR)
2591         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2592      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2593      &   FG_COMM1,IERR)
2594         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2595      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2596      &   FG_COMM1,IERR)
2597         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2598      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2599      &   FG_COMM1,IERR)
2600         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2601      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2602      &   FG_COMM1,IERR)
2603         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2604      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2605      &   FG_COMM1,IERR)
2606         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2610      &   ivec_count(fg_rank1),
2611      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2612      &   FG_COMM1,IERR)
2613         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2614      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2615      &   FG_COMM1,IERR)
2616        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2617      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2618      &   FG_COMM1,IERR)
2619         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2620      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2621      &   FG_COMM1,IERR)
2622        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2623      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2624      &   FG_COMM1,IERR)
2625         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2626      &   ivec_count(fg_rank1),
2627      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2628      &   FG_COMM1,IERR)
2629         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2630      &   ivec_count(fg_rank1),
2631      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2632      &   FG_COMM1,IERR)
2633         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2634      &   ivec_count(fg_rank1),
2635      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2636      &   MPI_MAT2,FG_COMM1,IERR)
2637         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2638      &   ivec_count(fg_rank1),
2639      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2640      &   MPI_MAT2,FG_COMM1,IERR)
2641         endif
2642 #else
2643 c Passes matrix info through the ring
2644       isend=fg_rank1
2645       irecv=fg_rank1-1
2646       if (irecv.lt.0) irecv=nfgtasks1-1
2647       iprev=irecv
2648       inext=fg_rank1+1
2649       if (inext.ge.nfgtasks1) inext=0
2650       do i=1,nfgtasks1-1
2651 c        write (iout,*) "isend",isend," irecv",irecv
2652 c        call flush(iout)
2653         lensend=lentyp(isend)
2654         lenrecv=lentyp(irecv)
2655 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2656 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2657 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2658 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2659 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2660 c        write (iout,*) "Gather ROTAT1"
2661 c        call flush(iout)
2662 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2663 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2664 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2665 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2666 c        write (iout,*) "Gather ROTAT2"
2667 c        call flush(iout)
2668         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2669      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2670      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2671      &   iprev,4400+irecv,FG_COMM,status,IERR)
2672 c        write (iout,*) "Gather ROTAT_OLD"
2673 c        call flush(iout)
2674         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2675      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2676      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2677      &   iprev,5500+irecv,FG_COMM,status,IERR)
2678 c        write (iout,*) "Gather PRECOMP11"
2679 c        call flush(iout)
2680         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2681      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2682      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2683      &   iprev,6600+irecv,FG_COMM,status,IERR)
2684 c        write (iout,*) "Gather PRECOMP12"
2685 c        call flush(iout)
2686         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2687      &  then
2688         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2689      &   MPI_ROTAT2(lensend),inext,7700+isend,
2690      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2691      &   iprev,7700+irecv,FG_COMM,status,IERR)
2692 c        write (iout,*) "Gather PRECOMP21"
2693 c        call flush(iout)
2694         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2695      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2696      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2697      &   iprev,8800+irecv,FG_COMM,status,IERR)
2698 c        write (iout,*) "Gather PRECOMP22"
2699 c        call flush(iout)
2700         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2701      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2702      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2703      &   MPI_PRECOMP23(lenrecv),
2704      &   iprev,9900+irecv,FG_COMM,status,IERR)
2705 c        write (iout,*) "Gather PRECOMP23"
2706 c        call flush(iout)
2707         endif
2708         isend=irecv
2709         irecv=irecv-1
2710         if (irecv.lt.0) irecv=nfgtasks1-1
2711       enddo
2712 #endif
2713         time_gather=time_gather+MPI_Wtime()-time00
2714       endif
2715 #ifdef DEBUG
2716 c      if (fg_rank.eq.0) then
2717         write (iout,*) "Arrays UG and UGDER"
2718         do i=1,nres-1
2719           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2720      &     ((ug(l,k,i),l=1,2),k=1,2),
2721      &     ((ugder(l,k,i),l=1,2),k=1,2)
2722         enddo
2723         write (iout,*) "Arrays UG2 and UG2DER"
2724         do i=1,nres-1
2725           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2726      &     ((ug2(l,k,i),l=1,2),k=1,2),
2727      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2728         enddo
2729         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2730         do i=1,nres-1
2731           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2732      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2733      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2734         enddo
2735         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2736         do i=1,nres-1
2737           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2738      &     costab(i),sintab(i),costab2(i),sintab2(i)
2739         enddo
2740         write (iout,*) "Array MUDER"
2741         do i=1,nres-1
2742           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2743         enddo
2744 c      endif
2745 #endif
2746 #endif
2747 cd      do i=1,nres
2748 cd        iti = itortyp(itype(i))
2749 cd        write (iout,*) i
2750 cd        do j=1,2
2751 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2752 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2753 cd        enddo
2754 cd      enddo
2755       return
2756       end
2757 C--------------------------------------------------------------------------
2758       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2759 C
2760 C This subroutine calculates the average interaction energy and its gradient
2761 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2762 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2763 C The potential depends both on the distance of peptide-group centers and on
2764 C the orientation of the CA-CA virtual bonds.
2765 C
2766       implicit real*8 (a-h,o-z)
2767 #ifdef MPI
2768       include 'mpif.h'
2769 #endif
2770       include 'DIMENSIONS'
2771       include 'COMMON.CONTROL'
2772       include 'COMMON.SETUP'
2773       include 'COMMON.IOUNITS'
2774       include 'COMMON.GEO'
2775       include 'COMMON.VAR'
2776       include 'COMMON.LOCAL'
2777       include 'COMMON.CHAIN'
2778       include 'COMMON.DERIV'
2779       include 'COMMON.INTERACT'
2780       include 'COMMON.CONTACTS'
2781       include 'COMMON.TORSION'
2782       include 'COMMON.VECTORS'
2783       include 'COMMON.FFIELD'
2784       include 'COMMON.TIME1'
2785       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2786      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2787       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2788      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2789       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2790      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2791      &    num_conti,j1,j2
2792 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2793 #ifdef MOMENT
2794       double precision scal_el /1.0d0/
2795 #else
2796       double precision scal_el /0.5d0/
2797 #endif
2798 C 12/13/98
2799 C 13-go grudnia roku pamietnego...
2800       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2801      &                   0.0d0,1.0d0,0.0d0,
2802      &                   0.0d0,0.0d0,1.0d0/
2803 cd      write(iout,*) 'In EELEC'
2804 cd      do i=1,nloctyp
2805 cd        write(iout,*) 'Type',i
2806 cd        write(iout,*) 'B1',B1(:,i)
2807 cd        write(iout,*) 'B2',B2(:,i)
2808 cd        write(iout,*) 'CC',CC(:,:,i)
2809 cd        write(iout,*) 'DD',DD(:,:,i)
2810 cd        write(iout,*) 'EE',EE(:,:,i)
2811 cd      enddo
2812 cd      call check_vecgrad
2813 cd      stop
2814       if (icheckgrad.eq.1) then
2815         do i=1,nres-1
2816           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2817           do k=1,3
2818             dc_norm(k,i)=dc(k,i)*fac
2819           enddo
2820 c          write (iout,*) 'i',i,' fac',fac
2821         enddo
2822       endif
2823       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2824      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2825      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2826 c        call vec_and_deriv
2827 #ifdef TIMING
2828         time01=MPI_Wtime()
2829 #endif
2830         call set_matrices
2831 #ifdef TIMING
2832         time_mat=time_mat+MPI_Wtime()-time01
2833 #endif
2834       endif
2835 cd      do i=1,nres-1
2836 cd        write (iout,*) 'i=',i
2837 cd        do k=1,3
2838 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2839 cd        enddo
2840 cd        do k=1,3
2841 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2842 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2843 cd        enddo
2844 cd      enddo
2845       t_eelecij=0.0d0
2846       ees=0.0D0
2847       evdw1=0.0D0
2848       eel_loc=0.0d0
2849       eello_turn3=0.0d0
2850       eello_turn4=0.0d0
2851       ind=0
2852       do i=1,nres
2853         num_cont_hb(i)=0
2854       enddo
2855 cd      print '(a)','Enter EELEC'
2856 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2857       do i=1,nres
2858         gel_loc_loc(i)=0.0d0
2859         gcorr_loc(i)=0.0d0
2860       enddo
2861 c
2862 c
2863 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2864 C
2865 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2866 C
2867       do i=iturn3_start,iturn3_end
2868         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2869      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2870         dxi=dc(1,i)
2871         dyi=dc(2,i)
2872         dzi=dc(3,i)
2873         dx_normi=dc_norm(1,i)
2874         dy_normi=dc_norm(2,i)
2875         dz_normi=dc_norm(3,i)
2876         xmedi=c(1,i)+0.5d0*dxi
2877         ymedi=c(2,i)+0.5d0*dyi
2878         zmedi=c(3,i)+0.5d0*dzi
2879         num_conti=0
2880         call eelecij(i,i+2,ees,evdw1,eel_loc)
2881         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2882         num_cont_hb(i)=num_conti
2883       enddo
2884       do i=iturn4_start,iturn4_end
2885         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2886      &    .or. itype(i+3).eq.ntyp1
2887      &    .or. itype(i+4).eq.ntyp1) cycle
2888         dxi=dc(1,i)
2889         dyi=dc(2,i)
2890         dzi=dc(3,i)
2891         dx_normi=dc_norm(1,i)
2892         dy_normi=dc_norm(2,i)
2893         dz_normi=dc_norm(3,i)
2894         xmedi=c(1,i)+0.5d0*dxi
2895         ymedi=c(2,i)+0.5d0*dyi
2896         zmedi=c(3,i)+0.5d0*dzi
2897         num_conti=num_cont_hb(i)
2898 c        write(iout,*) "JESTEM W PETLI"
2899         call eelecij(i,i+3,ees,evdw1,eel_loc)
2900         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2901      &   call eturn4(i,eello_turn4)
2902         num_cont_hb(i)=num_conti
2903       enddo   ! i
2904 c
2905 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2906 c
2907       do i=iatel_s,iatel_e
2908 c       do i=7,7
2909         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2910         dxi=dc(1,i)
2911         dyi=dc(2,i)
2912         dzi=dc(3,i)
2913         dx_normi=dc_norm(1,i)
2914         dy_normi=dc_norm(2,i)
2915         dz_normi=dc_norm(3,i)
2916         xmedi=c(1,i)+0.5d0*dxi
2917         ymedi=c(2,i)+0.5d0*dyi
2918         zmedi=c(3,i)+0.5d0*dzi
2919 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2920         num_conti=num_cont_hb(i)
2921         do j=ielstart(i),ielend(i)
2922 c         do j=13,13
2923 c          write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2924           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2925           call eelecij(i,j,ees,evdw1,eel_loc)
2926         enddo ! j
2927         num_cont_hb(i)=num_conti
2928       enddo   ! i
2929 c      write (iout,*) "Number of loop steps in EELEC:",ind
2930 cd      do i=1,nres
2931 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2932 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2933 cd      enddo
2934 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2935 ccc      eel_loc=eel_loc+eello_turn3
2936 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2937       return
2938       end
2939 C-------------------------------------------------------------------------------
2940       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2941       implicit real*8 (a-h,o-z)
2942       include 'DIMENSIONS'
2943 #ifdef MPI
2944       include "mpif.h"
2945 #endif
2946       include 'COMMON.CONTROL'
2947       include 'COMMON.IOUNITS'
2948       include 'COMMON.GEO'
2949       include 'COMMON.VAR'
2950       include 'COMMON.LOCAL'
2951       include 'COMMON.CHAIN'
2952       include 'COMMON.DERIV'
2953       include 'COMMON.INTERACT'
2954       include 'COMMON.CONTACTS'
2955       include 'COMMON.TORSION'
2956       include 'COMMON.VECTORS'
2957       include 'COMMON.FFIELD'
2958       include 'COMMON.TIME1'
2959       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2960      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2961       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2962      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2963      &    gmuij2(4),gmuji2(4)
2964       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2965      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2966      &    num_conti,j1,j2
2967 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2968 #ifdef MOMENT
2969       double precision scal_el /1.0d0/
2970 #else
2971       double precision scal_el /0.5d0/
2972 #endif
2973 C 12/13/98
2974 C 13-go grudnia roku pamietnego...
2975       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2976      &                   0.0d0,1.0d0,0.0d0,
2977      &                   0.0d0,0.0d0,1.0d0/
2978 c          time00=MPI_Wtime()
2979 cd      write (iout,*) "eelecij",i,j
2980 c          ind=ind+1
2981           iteli=itel(i)
2982           itelj=itel(j)
2983           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2984           aaa=app(iteli,itelj)
2985           bbb=bpp(iteli,itelj)
2986           ael6i=ael6(iteli,itelj)
2987           ael3i=ael3(iteli,itelj)
2988           dxj=dc(1,j)
2989           dyj=dc(2,j)
2990           dzj=dc(3,j)
2991           dx_normj=dc_norm(1,j)
2992           dy_normj=dc_norm(2,j)
2993           dz_normj=dc_norm(3,j)
2994           xj=c(1,j)+0.5D0*dxj-xmedi
2995           yj=c(2,j)+0.5D0*dyj-ymedi
2996           zj=c(3,j)+0.5D0*dzj-zmedi
2997           rij=xj*xj+yj*yj+zj*zj
2998           rrmij=1.0D0/rij
2999           rij=dsqrt(rij)
3000           rmij=1.0D0/rij
3001           r3ij=rrmij*rmij
3002           r6ij=r3ij*r3ij
3003           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3004           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3005           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3006           fac=cosa-3.0D0*cosb*cosg
3007           ev1=aaa*r6ij*r6ij
3008 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3009           if (j.eq.i+2) ev1=scal_el*ev1
3010           ev2=bbb*r6ij
3011           fac3=ael6i*r6ij
3012           fac4=ael3i*r3ij
3013           evdwij=ev1+ev2
3014           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3015           el2=fac4*fac
3016           eesij=el1+el2
3017 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3018           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3019           ees=ees+eesij
3020           evdw1=evdw1+evdwij
3021 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3022 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3023 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3024 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3025
3026           if (energy_dec) then
3027               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3028      &'evdw1',i,j,evdwij
3029      &,iteli,itelj,aaa,evdw1
3030               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3031           endif
3032
3033 C
3034 C Calculate contributions to the Cartesian gradient.
3035 C
3036 #ifdef SPLITELE
3037           facvdw=-6*rrmij*(ev1+evdwij)
3038           facel=-3*rrmij*(el1+eesij)
3039           fac1=fac
3040           erij(1)=xj*rmij
3041           erij(2)=yj*rmij
3042           erij(3)=zj*rmij
3043 *
3044 * Radial derivatives. First process both termini of the fragment (i,j)
3045 *
3046           ggg(1)=facel*xj
3047           ggg(2)=facel*yj
3048           ggg(3)=facel*zj
3049 c          do k=1,3
3050 c            ghalf=0.5D0*ggg(k)
3051 c            gelc(k,i)=gelc(k,i)+ghalf
3052 c            gelc(k,j)=gelc(k,j)+ghalf
3053 c          enddo
3054 c 9/28/08 AL Gradient compotents will be summed only at the end
3055           do k=1,3
3056             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3057             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3058           enddo
3059 *
3060 * Loop over residues i+1 thru j-1.
3061 *
3062 cgrad          do k=i+1,j-1
3063 cgrad            do l=1,3
3064 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3065 cgrad            enddo
3066 cgrad          enddo
3067           ggg(1)=facvdw*xj
3068           ggg(2)=facvdw*yj
3069           ggg(3)=facvdw*zj
3070 c          do k=1,3
3071 c            ghalf=0.5D0*ggg(k)
3072 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3073 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3074 c          enddo
3075 c 9/28/08 AL Gradient compotents will be summed only at the end
3076           do k=1,3
3077             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3078             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3079           enddo
3080 *
3081 * Loop over residues i+1 thru j-1.
3082 *
3083 cgrad          do k=i+1,j-1
3084 cgrad            do l=1,3
3085 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3086 cgrad            enddo
3087 cgrad          enddo
3088 #else
3089           facvdw=ev1+evdwij
3090           facel=el1+eesij
3091           fac1=fac
3092           fac=-3*rrmij*(facvdw+facvdw+facel)
3093           erij(1)=xj*rmij
3094           erij(2)=yj*rmij
3095           erij(3)=zj*rmij
3096 *
3097 * Radial derivatives. First process both termini of the fragment (i,j)
3098 *
3099           ggg(1)=fac*xj
3100           ggg(2)=fac*yj
3101           ggg(3)=fac*zj
3102 c          do k=1,3
3103 c            ghalf=0.5D0*ggg(k)
3104 c            gelc(k,i)=gelc(k,i)+ghalf
3105 c            gelc(k,j)=gelc(k,j)+ghalf
3106 c          enddo
3107 c 9/28/08 AL Gradient compotents will be summed only at the end
3108           do k=1,3
3109             gelc_long(k,j)=gelc(k,j)+ggg(k)
3110             gelc_long(k,i)=gelc(k,i)-ggg(k)
3111           enddo
3112 *
3113 * Loop over residues i+1 thru j-1.
3114 *
3115 cgrad          do k=i+1,j-1
3116 cgrad            do l=1,3
3117 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3118 cgrad            enddo
3119 cgrad          enddo
3120 c 9/28/08 AL Gradient compotents will be summed only at the end
3121           ggg(1)=facvdw*xj
3122           ggg(2)=facvdw*yj
3123           ggg(3)=facvdw*zj
3124           do k=1,3
3125             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3126             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3127           enddo
3128 #endif
3129 *
3130 * Angular part
3131 *
3132           ecosa=2.0D0*fac3*fac1+fac4
3133           fac4=-3.0D0*fac4
3134           fac3=-6.0D0*fac3
3135           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3136           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3137           do k=1,3
3138             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3139             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3140           enddo
3141 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3142 cd   &          (dcosg(k),k=1,3)
3143           do k=1,3
3144             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3145           enddo
3146 c          do k=1,3
3147 c            ghalf=0.5D0*ggg(k)
3148 c            gelc(k,i)=gelc(k,i)+ghalf
3149 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3150 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3151 c            gelc(k,j)=gelc(k,j)+ghalf
3152 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3153 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3154 c          enddo
3155 cgrad          do k=i+1,j-1
3156 cgrad            do l=1,3
3157 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3158 cgrad            enddo
3159 cgrad          enddo
3160           do k=1,3
3161             gelc(k,i)=gelc(k,i)
3162      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3163      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3164             gelc(k,j)=gelc(k,j)
3165      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3166      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3167             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3168             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3169           enddo
3170           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3171      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3172      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3173 C
3174 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3175 C   energy of a peptide unit is assumed in the form of a second-order
3176 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3177 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3178 C   are computed for EVERY pair of non-contiguous peptide groups.
3179 C
3180
3181           if (j.lt.nres-1) then
3182             j1=j+1
3183             j2=j-1
3184           else
3185             j1=j-1
3186             j2=j-2
3187           endif
3188           kkk=0
3189           lll=0
3190           do k=1,2
3191             do l=1,2
3192               kkk=kkk+1
3193               muij(kkk)=mu(k,i)*mu(l,j)
3194 #ifdef NEWCORR
3195              gmuij1(kkk)=gtb1(k,i)*mu(l,j)
3196 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(k,i),k,i
3197              gmuij2(kkk)=gUb2(k,i-1)*mu(l,j)
3198              gmuji1(kkk)=mu(k,i)*gtb1(l,j)
3199 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(l,j),l,j
3200              gmuji2(kkk)=mu(k,i)*gUb2(l,j-1)
3201 #endif
3202             enddo
3203           enddo
3204 cd         write (iout,*) 'EELEC: i',i,' j',j
3205 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3206 cd          write(iout,*) 'muij',muij
3207           ury=scalar(uy(1,i),erij)
3208           urz=scalar(uz(1,i),erij)
3209           vry=scalar(uy(1,j),erij)
3210           vrz=scalar(uz(1,j),erij)
3211           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3212           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3213           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3214           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3215           fac=dsqrt(-ael6i)*r3ij
3216           a22=a22*fac
3217           a23=a23*fac
3218           a32=a32*fac
3219           a33=a33*fac
3220 cd          write (iout,'(4i5,4f10.5)')
3221 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3222 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3223 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3224 cd     &      uy(:,j),uz(:,j)
3225 cd          write (iout,'(4f10.5)')
3226 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3227 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3228 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3229 cd           write (iout,'(9f10.5/)')
3230 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3231 C Derivatives of the elements of A in virtual-bond vectors
3232           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3233           do k=1,3
3234             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3235             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3236             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3237             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3238             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3239             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3240             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3241             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3242             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3243             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3244             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3245             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3246           enddo
3247 C Compute radial contributions to the gradient
3248           facr=-3.0d0*rrmij
3249           a22der=a22*facr
3250           a23der=a23*facr
3251           a32der=a32*facr
3252           a33der=a33*facr
3253           agg(1,1)=a22der*xj
3254           agg(2,1)=a22der*yj
3255           agg(3,1)=a22der*zj
3256           agg(1,2)=a23der*xj
3257           agg(2,2)=a23der*yj
3258           agg(3,2)=a23der*zj
3259           agg(1,3)=a32der*xj
3260           agg(2,3)=a32der*yj
3261           agg(3,3)=a32der*zj
3262           agg(1,4)=a33der*xj
3263           agg(2,4)=a33der*yj
3264           agg(3,4)=a33der*zj
3265 C Add the contributions coming from er
3266           fac3=-3.0d0*fac
3267           do k=1,3
3268             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3269             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3270             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3271             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3272           enddo
3273           do k=1,3
3274 C Derivatives in DC(i)
3275 cgrad            ghalf1=0.5d0*agg(k,1)
3276 cgrad            ghalf2=0.5d0*agg(k,2)
3277 cgrad            ghalf3=0.5d0*agg(k,3)
3278 cgrad            ghalf4=0.5d0*agg(k,4)
3279             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3280      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3281             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3282      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3283             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3284      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3285             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3286      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3287 C Derivatives in DC(i+1)
3288             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3289      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3290             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3291      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3292             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3293      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3294             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3295      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3296 C Derivatives in DC(j)
3297             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3298      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3299             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3300      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3301             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3302      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3303             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3304      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3305 C Derivatives in DC(j+1) or DC(nres-1)
3306             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3307      &      -3.0d0*vryg(k,3)*ury)
3308             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3309      &      -3.0d0*vrzg(k,3)*ury)
3310             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3311      &      -3.0d0*vryg(k,3)*urz)
3312             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3313      &      -3.0d0*vrzg(k,3)*urz)
3314 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3315 cgrad              do l=1,4
3316 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3317 cgrad              enddo
3318 cgrad            endif
3319           enddo
3320           acipa(1,1)=a22
3321           acipa(1,2)=a23
3322           acipa(2,1)=a32
3323           acipa(2,2)=a33
3324           a22=-a22
3325           a23=-a23
3326           do l=1,2
3327             do k=1,3
3328               agg(k,l)=-agg(k,l)
3329               aggi(k,l)=-aggi(k,l)
3330               aggi1(k,l)=-aggi1(k,l)
3331               aggj(k,l)=-aggj(k,l)
3332               aggj1(k,l)=-aggj1(k,l)
3333             enddo
3334           enddo
3335           if (j.lt.nres-1) then
3336             a22=-a22
3337             a32=-a32
3338             do l=1,3,2
3339               do k=1,3
3340                 agg(k,l)=-agg(k,l)
3341                 aggi(k,l)=-aggi(k,l)
3342                 aggi1(k,l)=-aggi1(k,l)
3343                 aggj(k,l)=-aggj(k,l)
3344                 aggj1(k,l)=-aggj1(k,l)
3345               enddo
3346             enddo
3347           else
3348             a22=-a22
3349             a23=-a23
3350             a32=-a32
3351             a33=-a33
3352             do l=1,4
3353               do k=1,3
3354                 agg(k,l)=-agg(k,l)
3355                 aggi(k,l)=-aggi(k,l)
3356                 aggi1(k,l)=-aggi1(k,l)
3357                 aggj(k,l)=-aggj(k,l)
3358                 aggj1(k,l)=-aggj1(k,l)
3359               enddo
3360             enddo
3361           endif
3362           ENDIF ! WCORR
3363           IF (wel_loc.gt.0.0d0) THEN
3364 C Contribution to the local-electrostatic energy coming from the i-j pair
3365           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3366      &     +a33*muij(4)
3367 C Calculate patrial derivative for theta angle
3368 #ifdef NEWCORR
3369          geel_loc_ij=a22*gmuij1(1)
3370      &     +a23*gmuij1(2)
3371      &     +a32*gmuij1(3)
3372      &     +a33*gmuij1(4)
3373 c         write(iout,*) "derivative over thatai"
3374 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3375 c     &   a33*gmuij1(4)
3376          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3377      &      geel_loc_ij*wel_loc
3378 c         write(iout,*) "derivative over thatai-1"
3379 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3380 c     &   a33*gmuij2(4)
3381          geel_loc_ij=a22*gmuij2(1)+a23*gmuij2(2)+a32*gmuij2(3)
3382      &     +a33*gmuij2(4)
3383          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3384      &      geel_loc_ij*wel_loc
3385          geel_loc_ji=a22*gmuji1(1)+a23*gmuji1(2)+a32*gmuji1(3)
3386      &     +a33*gmuji1(4)
3387 c         write(iout,*) "derivative over thataj"
3388 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3389 c     &   a33*gmuji1(4)
3390
3391          gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3392      &      geel_loc_ji*wel_loc
3393          geel_loc_ji=a22*gmuji2(1)+a23*gmuji2(2)+a32*gmuji2(3)
3394      &     +a33*gmuji2(4)
3395 c         write(iout,*) "derivative over thataj-1"
3396 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3397 c     &   a33*gmuji2(4)
3398          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3399      &      geel_loc_ji*wel_loc
3400 #endif
3401 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3402
3403           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3404      &            'eelloc',i,j,eel_loc_ij
3405 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3406
3407           eel_loc=eel_loc+eel_loc_ij
3408 C Partial derivatives in virtual-bond dihedral angles gamma
3409           if (i.gt.1)
3410      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3411      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3412      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3413           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3414      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3415      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3416 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3417           do l=1,3
3418             ggg(l)=agg(l,1)*muij(1)+
3419      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3420             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3421             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3422 cgrad            ghalf=0.5d0*ggg(l)
3423 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3424 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3425           enddo
3426 cgrad          do k=i+1,j2
3427 cgrad            do l=1,3
3428 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3429 cgrad            enddo
3430 cgrad          enddo
3431 C Remaining derivatives of eello
3432           do l=1,3
3433             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3434      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3435             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3436      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3437             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3438      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3439             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3440      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3441           enddo
3442           ENDIF
3443 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3444 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3445           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3446      &       .and. num_conti.le.maxconts) then
3447 c            write (iout,*) i,j," entered corr"
3448 C
3449 C Calculate the contact function. The ith column of the array JCONT will
3450 C contain the numbers of atoms that make contacts with the atom I (of numbers
3451 C greater than I). The arrays FACONT and GACONT will contain the values of
3452 C the contact function and its derivative.
3453 c           r0ij=1.02D0*rpp(iteli,itelj)
3454 c           r0ij=1.11D0*rpp(iteli,itelj)
3455             r0ij=2.20D0*rpp(iteli,itelj)
3456 c           r0ij=1.55D0*rpp(iteli,itelj)
3457             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3458             if (fcont.gt.0.0D0) then
3459               num_conti=num_conti+1
3460               if (num_conti.gt.maxconts) then
3461                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3462      &                         ' will skip next contacts for this conf.'
3463               else
3464                 jcont_hb(num_conti,i)=j
3465 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3466 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3467                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3468      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3469 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3470 C  terms.
3471                 d_cont(num_conti,i)=rij
3472 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3473 C     --- Electrostatic-interaction matrix ---
3474                 a_chuj(1,1,num_conti,i)=a22
3475                 a_chuj(1,2,num_conti,i)=a23
3476                 a_chuj(2,1,num_conti,i)=a32
3477                 a_chuj(2,2,num_conti,i)=a33
3478 C     --- Gradient of rij
3479                 do kkk=1,3
3480                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3481                 enddo
3482                 kkll=0
3483                 do k=1,2
3484                   do l=1,2
3485                     kkll=kkll+1
3486                     do m=1,3
3487                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3488                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3489                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3490                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3491                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3492                     enddo
3493                   enddo
3494                 enddo
3495                 ENDIF
3496                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3497 C Calculate contact energies
3498                 cosa4=4.0D0*cosa
3499                 wij=cosa-3.0D0*cosb*cosg
3500                 cosbg1=cosb+cosg
3501                 cosbg2=cosb-cosg
3502 c               fac3=dsqrt(-ael6i)/r0ij**3
3503                 fac3=dsqrt(-ael6i)*r3ij
3504 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3505                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3506                 if (ees0tmp.gt.0) then
3507                   ees0pij=dsqrt(ees0tmp)
3508                 else
3509                   ees0pij=0
3510                 endif
3511 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3512                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3513                 if (ees0tmp.gt.0) then
3514                   ees0mij=dsqrt(ees0tmp)
3515                 else
3516                   ees0mij=0
3517                 endif
3518 c               ees0mij=0.0D0
3519                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3520                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3521 C Diagnostics. Comment out or remove after debugging!
3522 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3523 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3524 c               ees0m(num_conti,i)=0.0D0
3525 C End diagnostics.
3526 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3527 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3528 C Angular derivatives of the contact function
3529                 ees0pij1=fac3/ees0pij
3530                 ees0mij1=fac3/ees0mij
3531                 fac3p=-3.0D0*fac3*rrmij
3532                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3533                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3534 c               ees0mij1=0.0D0
3535                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3536                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3537                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3538                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3539                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3540                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3541                 ecosap=ecosa1+ecosa2
3542                 ecosbp=ecosb1+ecosb2
3543                 ecosgp=ecosg1+ecosg2
3544                 ecosam=ecosa1-ecosa2
3545                 ecosbm=ecosb1-ecosb2
3546                 ecosgm=ecosg1-ecosg2
3547 C Diagnostics
3548 c               ecosap=ecosa1
3549 c               ecosbp=ecosb1
3550 c               ecosgp=ecosg1
3551 c               ecosam=0.0D0
3552 c               ecosbm=0.0D0
3553 c               ecosgm=0.0D0
3554 C End diagnostics
3555                 facont_hb(num_conti,i)=fcont
3556                 fprimcont=fprimcont/rij
3557 cd              facont_hb(num_conti,i)=1.0D0
3558 C Following line is for diagnostics.
3559 cd              fprimcont=0.0D0
3560                 do k=1,3
3561                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3562                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3563                 enddo
3564                 do k=1,3
3565                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3566                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3567                 enddo
3568                 gggp(1)=gggp(1)+ees0pijp*xj
3569                 gggp(2)=gggp(2)+ees0pijp*yj
3570                 gggp(3)=gggp(3)+ees0pijp*zj
3571                 gggm(1)=gggm(1)+ees0mijp*xj
3572                 gggm(2)=gggm(2)+ees0mijp*yj
3573                 gggm(3)=gggm(3)+ees0mijp*zj
3574 C Derivatives due to the contact function
3575                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3576                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3577                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3578                 do k=1,3
3579 c
3580 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3581 c          following the change of gradient-summation algorithm.
3582 c
3583 cgrad                  ghalfp=0.5D0*gggp(k)
3584 cgrad                  ghalfm=0.5D0*gggm(k)
3585                   gacontp_hb1(k,num_conti,i)=!ghalfp
3586      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3587      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3588                   gacontp_hb2(k,num_conti,i)=!ghalfp
3589      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3590      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3591                   gacontp_hb3(k,num_conti,i)=gggp(k)
3592                   gacontm_hb1(k,num_conti,i)=!ghalfm
3593      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3594      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3595                   gacontm_hb2(k,num_conti,i)=!ghalfm
3596      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3597      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3598                   gacontm_hb3(k,num_conti,i)=gggm(k)
3599                 enddo
3600 C Diagnostics. Comment out or remove after debugging!
3601 cdiag           do k=1,3
3602 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3603 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3604 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3605 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3606 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3607 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3608 cdiag           enddo
3609               ENDIF ! wcorr
3610               endif  ! num_conti.le.maxconts
3611             endif  ! fcont.gt.0
3612           endif    ! j.gt.i+1
3613           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3614             do k=1,4
3615               do l=1,3
3616                 ghalf=0.5d0*agg(l,k)
3617                 aggi(l,k)=aggi(l,k)+ghalf
3618                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3619                 aggj(l,k)=aggj(l,k)+ghalf
3620               enddo
3621             enddo
3622             if (j.eq.nres-1 .and. i.lt.j-2) then
3623               do k=1,4
3624                 do l=1,3
3625                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3626                 enddo
3627               enddo
3628             endif
3629           endif
3630 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3631       return
3632       end
3633 C-----------------------------------------------------------------------------
3634       subroutine eturn3(i,eello_turn3)
3635 C Third- and fourth-order contributions from turns
3636       implicit real*8 (a-h,o-z)
3637       include 'DIMENSIONS'
3638       include 'COMMON.IOUNITS'
3639       include 'COMMON.GEO'
3640       include 'COMMON.VAR'
3641       include 'COMMON.LOCAL'
3642       include 'COMMON.CHAIN'
3643       include 'COMMON.DERIV'
3644       include 'COMMON.INTERACT'
3645       include 'COMMON.CONTACTS'
3646       include 'COMMON.TORSION'
3647       include 'COMMON.VECTORS'
3648       include 'COMMON.FFIELD'
3649       include 'COMMON.CONTROL'
3650       dimension ggg(3)
3651       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3652      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3653      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3654      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3655      &  auxgmat2(2,2),auxgmatt2(2,2)
3656       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3657      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3658       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3659      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3660      &    num_conti,j1,j2
3661       j=i+2
3662 c      write (iout,*) "eturn3",i,j,j1,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 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3668 C
3669 C               Third-order contributions
3670 C
3671 C                 (i+2)o----(i+3)
3672 C                      | |
3673 C                      | |
3674 C                 (i+1)o----i
3675 C
3676 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3677 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3678         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3679 c auxalary matices for theta gradient
3680 c auxalary matrix for i+1 and constant i+2
3681         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3682 c auxalary matrix for i+2 and constant i+1
3683         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3684         call transpose2(auxmat(1,1),auxmat1(1,1))
3685         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3686         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3687         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3688         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3689         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3690         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3691 C Derivatives in theta
3692         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3693      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3694         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3695      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3696
3697         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3698      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3699 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3700 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3701 cd     &    ' eello_turn3_num',4*eello_turn3_num
3702 C Derivatives in gamma(i)
3703         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3704         call transpose2(auxmat2(1,1),auxmat3(1,1))
3705         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3706         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3707 C Derivatives in gamma(i+1)
3708         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3709         call transpose2(auxmat2(1,1),auxmat3(1,1))
3710         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3711         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3712      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3713 C Cartesian derivatives
3714         do l=1,3
3715 c            ghalf1=0.5d0*agg(l,1)
3716 c            ghalf2=0.5d0*agg(l,2)
3717 c            ghalf3=0.5d0*agg(l,3)
3718 c            ghalf4=0.5d0*agg(l,4)
3719           a_temp(1,1)=aggi(l,1)!+ghalf1
3720           a_temp(1,2)=aggi(l,2)!+ghalf2
3721           a_temp(2,1)=aggi(l,3)!+ghalf3
3722           a_temp(2,2)=aggi(l,4)!+ghalf4
3723           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3724           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3725      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3726           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3727           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3728           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3729           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3730           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3731           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3732      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3733           a_temp(1,1)=aggj(l,1)!+ghalf1
3734           a_temp(1,2)=aggj(l,2)!+ghalf2
3735           a_temp(2,1)=aggj(l,3)!+ghalf3
3736           a_temp(2,2)=aggj(l,4)!+ghalf4
3737           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3738           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3739      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3740           a_temp(1,1)=aggj1(l,1)
3741           a_temp(1,2)=aggj1(l,2)
3742           a_temp(2,1)=aggj1(l,3)
3743           a_temp(2,2)=aggj1(l,4)
3744           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3745           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3746      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3747         enddo
3748       return
3749       end
3750 C-------------------------------------------------------------------------------
3751       subroutine eturn4(i,eello_turn4)
3752 C Third- and fourth-order contributions from turns
3753       implicit real*8 (a-h,o-z)
3754       include 'DIMENSIONS'
3755       include 'COMMON.IOUNITS'
3756       include 'COMMON.GEO'
3757       include 'COMMON.VAR'
3758       include 'COMMON.LOCAL'
3759       include 'COMMON.CHAIN'
3760       include 'COMMON.DERIV'
3761       include 'COMMON.INTERACT'
3762       include 'COMMON.CONTACTS'
3763       include 'COMMON.TORSION'
3764       include 'COMMON.VECTORS'
3765       include 'COMMON.FFIELD'
3766       include 'COMMON.CONTROL'
3767       dimension ggg(3)
3768       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3769      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3770      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3771      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3772      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3773      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3774      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3775       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3776      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3777       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3778      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3779      &    num_conti,j1,j2
3780       j=i+3
3781 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3782 C
3783 C               Fourth-order contributions
3784 C
3785 C                 (i+3)o----(i+4)
3786 C                     /  |
3787 C               (i+2)o   |
3788 C                     \  |
3789 C                 (i+1)o----i
3790 C
3791 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3792 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3793 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3794 c        write(iout,*)"WCHODZE W PROGRAM"
3795         a_temp(1,1)=a22
3796         a_temp(1,2)=a23
3797         a_temp(2,1)=a32
3798         a_temp(2,2)=a33
3799         iti1=itortyp(itype(i+1))
3800         iti2=itortyp(itype(i+2))
3801         iti3=itortyp(itype(i+3))
3802 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3803         call transpose2(EUg(1,1,i+1),e1t(1,1))
3804         call transpose2(Eug(1,1,i+2),e2t(1,1))
3805         call transpose2(Eug(1,1,i+3),e3t(1,1))
3806 C Ematrix derivative in theta
3807         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3808         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3809         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3810         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3811 c       eta1 in derivative theta
3812         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3813         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3814 c       auxgvec is derivative of Ub2 so i+3 theta
3815         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3816 c       auxalary matrix of E i+1
3817         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3818 c        s1=0.0
3819 c        gs1=0.0
3820         s1=scalar2(b1(1,i+2),auxvec(1))
3821 c derivative of theta i+2 with constant i+3
3822         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3823 c derivative of theta i+2 with constant i+2
3824         gs32=scalar2(b1(1,i+2),auxgvec(1))
3825 c derivative of E matix in theta of i+1
3826         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3827
3828         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3829 c       ea31 in derivative theta
3830         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3831         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3832 c auxilary matrix auxgvec of Ub2 with constant E matirx
3833         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3834 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3835         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3836
3837 c        s2=0.0
3838 c        gs2=0.0
3839         s2=scalar2(b1(1,i+1),auxvec(1))
3840 c derivative of theta i+1 with constant i+3
3841         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3842 c derivative of theta i+2 with constant i+1
3843         gs21=scalar2(b1(1,i+1),auxgvec(1))
3844 c derivative of theta i+3 with constant i+1
3845         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3846 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3847 c     &  gtb1(1,i+1)
3848         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3849 c two derivatives over diffetent matrices
3850 c gtae3e2 is derivative over i+3
3851         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3852 c ae3gte2 is derivative over i+2
3853         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3854         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3855 c three possible derivative over theta E matices
3856 c i+1
3857         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3858 c i+2
3859         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3860 c i+3
3861         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3862         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3863
3864         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3865         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3866         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3867
3868         eello_turn4=eello_turn4-(s1+s2+s3)
3869 #ifdef NEWCORR
3870         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3871      &                  -(gs13+gsE13+gsEE1)*wturn4
3872         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3873      &                    -(gs23+gs21+gsEE2)*wturn4
3874         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3875      &                    -(gs32+gsE31+gsEE3)*wturn4
3876 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3877 c     &   gs2
3878 #endif
3879         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3880      &      'eturn4',i,j,-(s1+s2+s3)
3881 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3882 c     &    ' eello_turn4_num',8*eello_turn4_num
3883 C Derivatives in gamma(i)
3884         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3885         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3886         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3887         s1=scalar2(b1(1,i+2),auxvec(1))
3888         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3889         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3890         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3891 C Derivatives in gamma(i+1)
3892         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3893         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3894         s2=scalar2(b1(1,i+1),auxvec(1))
3895         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3896         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3897         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3898         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3899 C Derivatives in gamma(i+2)
3900         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3901         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3902         s1=scalar2(b1(1,i+2),auxvec(1))
3903         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3904         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3905         s2=scalar2(b1(1,i+1),auxvec(1))
3906         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3907         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3908         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3909         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3910 C Cartesian derivatives
3911 C Derivatives of this turn contributions in DC(i+2)
3912         if (j.lt.nres-1) then
3913           do l=1,3
3914             a_temp(1,1)=agg(l,1)
3915             a_temp(1,2)=agg(l,2)
3916             a_temp(2,1)=agg(l,3)
3917             a_temp(2,2)=agg(l,4)
3918             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3919             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3920             s1=scalar2(b1(1,i+2),auxvec(1))
3921             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3922             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3923             s2=scalar2(b1(1,i+1),auxvec(1))
3924             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3925             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3926             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3927             ggg(l)=-(s1+s2+s3)
3928             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3929           enddo
3930         endif
3931 C Remaining derivatives of this turn contribution
3932         do l=1,3
3933           a_temp(1,1)=aggi(l,1)
3934           a_temp(1,2)=aggi(l,2)
3935           a_temp(2,1)=aggi(l,3)
3936           a_temp(2,2)=aggi(l,4)
3937           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3938           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3939           s1=scalar2(b1(1,i+2),auxvec(1))
3940           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3941           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3942           s2=scalar2(b1(1,i+1),auxvec(1))
3943           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3944           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3945           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3946           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3947           a_temp(1,1)=aggi1(l,1)
3948           a_temp(1,2)=aggi1(l,2)
3949           a_temp(2,1)=aggi1(l,3)
3950           a_temp(2,2)=aggi1(l,4)
3951           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3952           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3953           s1=scalar2(b1(1,i+2),auxvec(1))
3954           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3955           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3956           s2=scalar2(b1(1,i+1),auxvec(1))
3957           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3958           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3959           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3960           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3961           a_temp(1,1)=aggj(l,1)
3962           a_temp(1,2)=aggj(l,2)
3963           a_temp(2,1)=aggj(l,3)
3964           a_temp(2,2)=aggj(l,4)
3965           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3966           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3967           s1=scalar2(b1(1,i+2),auxvec(1))
3968           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3969           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3970           s2=scalar2(b1(1,i+1),auxvec(1))
3971           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3972           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3973           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3974           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3975           a_temp(1,1)=aggj1(l,1)
3976           a_temp(1,2)=aggj1(l,2)
3977           a_temp(2,1)=aggj1(l,3)
3978           a_temp(2,2)=aggj1(l,4)
3979           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3980           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3981           s1=scalar2(b1(1,i+2),auxvec(1))
3982           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3983           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3984           s2=scalar2(b1(1,i+1),auxvec(1))
3985           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3986           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3987           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3988 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3989           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3990         enddo
3991       return
3992       end
3993 C-----------------------------------------------------------------------------
3994       subroutine vecpr(u,v,w)
3995       implicit real*8(a-h,o-z)
3996       dimension u(3),v(3),w(3)
3997       w(1)=u(2)*v(3)-u(3)*v(2)
3998       w(2)=-u(1)*v(3)+u(3)*v(1)
3999       w(3)=u(1)*v(2)-u(2)*v(1)
4000       return
4001       end
4002 C-----------------------------------------------------------------------------
4003       subroutine unormderiv(u,ugrad,unorm,ungrad)
4004 C This subroutine computes the derivatives of a normalized vector u, given
4005 C the derivatives computed without normalization conditions, ugrad. Returns
4006 C ungrad.
4007       implicit none
4008       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4009       double precision vec(3)
4010       double precision scalar
4011       integer i,j
4012 c      write (2,*) 'ugrad',ugrad
4013 c      write (2,*) 'u',u
4014       do i=1,3
4015         vec(i)=scalar(ugrad(1,i),u(1))
4016       enddo
4017 c      write (2,*) 'vec',vec
4018       do i=1,3
4019         do j=1,3
4020           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4021         enddo
4022       enddo
4023 c      write (2,*) 'ungrad',ungrad
4024       return
4025       end
4026 C-----------------------------------------------------------------------------
4027       subroutine escp_soft_sphere(evdw2,evdw2_14)
4028 C
4029 C This subroutine calculates the excluded-volume interaction energy between
4030 C peptide-group centers and side chains and its gradient in virtual-bond and
4031 C side-chain vectors.
4032 C
4033       implicit real*8 (a-h,o-z)
4034       include 'DIMENSIONS'
4035       include 'COMMON.GEO'
4036       include 'COMMON.VAR'
4037       include 'COMMON.LOCAL'
4038       include 'COMMON.CHAIN'
4039       include 'COMMON.DERIV'
4040       include 'COMMON.INTERACT'
4041       include 'COMMON.FFIELD'
4042       include 'COMMON.IOUNITS'
4043       include 'COMMON.CONTROL'
4044       dimension ggg(3)
4045       evdw2=0.0D0
4046       evdw2_14=0.0d0
4047       r0_scp=4.5d0
4048 cd    print '(a)','Enter ESCP'
4049 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4050       do i=iatscp_s,iatscp_e
4051         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4052         iteli=itel(i)
4053         xi=0.5D0*(c(1,i)+c(1,i+1))
4054         yi=0.5D0*(c(2,i)+c(2,i+1))
4055         zi=0.5D0*(c(3,i)+c(3,i+1))
4056
4057         do iint=1,nscp_gr(i)
4058
4059         do j=iscpstart(i,iint),iscpend(i,iint)
4060           if (itype(j).eq.ntyp1) cycle
4061           itypj=iabs(itype(j))
4062 C Uncomment following three lines for SC-p interactions
4063 c         xj=c(1,nres+j)-xi
4064 c         yj=c(2,nres+j)-yi
4065 c         zj=c(3,nres+j)-zi
4066 C Uncomment following three lines for Ca-p interactions
4067           xj=c(1,j)-xi
4068           yj=c(2,j)-yi
4069           zj=c(3,j)-zi
4070           rij=xj*xj+yj*yj+zj*zj
4071           r0ij=r0_scp
4072           r0ijsq=r0ij*r0ij
4073           if (rij.lt.r0ijsq) then
4074             evdwij=0.25d0*(rij-r0ijsq)**2
4075             fac=rij-r0ijsq
4076           else
4077             evdwij=0.0d0
4078             fac=0.0d0
4079           endif
4080           evdw2=evdw2+evdwij
4081 C
4082 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4083 C
4084           ggg(1)=xj*fac
4085           ggg(2)=yj*fac
4086           ggg(3)=zj*fac
4087 cgrad          if (j.lt.i) then
4088 cd          write (iout,*) 'j<i'
4089 C Uncomment following three lines for SC-p interactions
4090 c           do k=1,3
4091 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4092 c           enddo
4093 cgrad          else
4094 cd          write (iout,*) 'j>i'
4095 cgrad            do k=1,3
4096 cgrad              ggg(k)=-ggg(k)
4097 C Uncomment following line for SC-p interactions
4098 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4099 cgrad            enddo
4100 cgrad          endif
4101 cgrad          do k=1,3
4102 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4103 cgrad          enddo
4104 cgrad          kstart=min0(i+1,j)
4105 cgrad          kend=max0(i-1,j-1)
4106 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4107 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4108 cgrad          do k=kstart,kend
4109 cgrad            do l=1,3
4110 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4111 cgrad            enddo
4112 cgrad          enddo
4113           do k=1,3
4114             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4115             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4116           enddo
4117         enddo
4118
4119         enddo ! iint
4120       enddo ! i
4121       return
4122       end
4123 C-----------------------------------------------------------------------------
4124       subroutine escp(evdw2,evdw2_14)
4125 C
4126 C This subroutine calculates the excluded-volume interaction energy between
4127 C peptide-group centers and side chains and its gradient in virtual-bond and
4128 C side-chain vectors.
4129 C
4130       implicit real*8 (a-h,o-z)
4131       include 'DIMENSIONS'
4132       include 'COMMON.GEO'
4133       include 'COMMON.VAR'
4134       include 'COMMON.LOCAL'
4135       include 'COMMON.CHAIN'
4136       include 'COMMON.DERIV'
4137       include 'COMMON.INTERACT'
4138       include 'COMMON.FFIELD'
4139       include 'COMMON.IOUNITS'
4140       include 'COMMON.CONTROL'
4141       dimension ggg(3)
4142       evdw2=0.0D0
4143       evdw2_14=0.0d0
4144 cd    print '(a)','Enter ESCP'
4145 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4146       do i=iatscp_s,iatscp_e
4147         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4148         iteli=itel(i)
4149         xi=0.5D0*(c(1,i)+c(1,i+1))
4150         yi=0.5D0*(c(2,i)+c(2,i+1))
4151         zi=0.5D0*(c(3,i)+c(3,i+1))
4152
4153         do iint=1,nscp_gr(i)
4154
4155         do j=iscpstart(i,iint),iscpend(i,iint)
4156           itypj=iabs(itype(j))
4157           if (itypj.eq.ntyp1) cycle
4158 C Uncomment following three lines for SC-p interactions
4159 c         xj=c(1,nres+j)-xi
4160 c         yj=c(2,nres+j)-yi
4161 c         zj=c(3,nres+j)-zi
4162 C Uncomment following three lines for Ca-p interactions
4163           xj=c(1,j)-xi
4164           yj=c(2,j)-yi
4165           zj=c(3,j)-zi
4166           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4167           fac=rrij**expon2
4168           e1=fac*fac*aad(itypj,iteli)
4169           e2=fac*bad(itypj,iteli)
4170           if (iabs(j-i) .le. 2) then
4171             e1=scal14*e1
4172             e2=scal14*e2
4173             evdw2_14=evdw2_14+e1+e2
4174           endif
4175           evdwij=e1+e2
4176           evdw2=evdw2+evdwij
4177           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4178      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4179      &       bad(itypj,iteli)
4180 C
4181 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4182 C
4183           fac=-(evdwij+e1)*rrij
4184           ggg(1)=xj*fac
4185           ggg(2)=yj*fac
4186           ggg(3)=zj*fac
4187 cgrad          if (j.lt.i) then
4188 cd          write (iout,*) 'j<i'
4189 C Uncomment following three lines for SC-p interactions
4190 c           do k=1,3
4191 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4192 c           enddo
4193 cgrad          else
4194 cd          write (iout,*) 'j>i'
4195 cgrad            do k=1,3
4196 cgrad              ggg(k)=-ggg(k)
4197 C Uncomment following line for SC-p interactions
4198 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4199 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4200 cgrad            enddo
4201 cgrad          endif
4202 cgrad          do k=1,3
4203 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4204 cgrad          enddo
4205 cgrad          kstart=min0(i+1,j)
4206 cgrad          kend=max0(i-1,j-1)
4207 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4208 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4209 cgrad          do k=kstart,kend
4210 cgrad            do l=1,3
4211 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4212 cgrad            enddo
4213 cgrad          enddo
4214           do k=1,3
4215             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4216             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4217           enddo
4218         enddo
4219
4220         enddo ! iint
4221       enddo ! i
4222       do i=1,nct
4223         do j=1,3
4224           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4225           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4226           gradx_scp(j,i)=expon*gradx_scp(j,i)
4227         enddo
4228       enddo
4229 C******************************************************************************
4230 C
4231 C                              N O T E !!!
4232 C
4233 C To save time the factor EXPON has been extracted from ALL components
4234 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4235 C use!
4236 C
4237 C******************************************************************************
4238       return
4239       end
4240 C--------------------------------------------------------------------------
4241       subroutine edis(ehpb)
4242 C
4243 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4244 C
4245       implicit real*8 (a-h,o-z)
4246       include 'DIMENSIONS'
4247       include 'COMMON.SBRIDGE'
4248       include 'COMMON.CHAIN'
4249       include 'COMMON.DERIV'
4250       include 'COMMON.VAR'
4251       include 'COMMON.INTERACT'
4252       include 'COMMON.IOUNITS'
4253       dimension ggg(3)
4254       ehpb=0.0D0
4255 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4256 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4257       if (link_end.eq.0) return
4258       do i=link_start,link_end
4259 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4260 C CA-CA distance used in regularization of structure.
4261         ii=ihpb(i)
4262         jj=jhpb(i)
4263 C iii and jjj point to the residues for which the distance is assigned.
4264         if (ii.gt.nres) then
4265           iii=ii-nres
4266           jjj=jj-nres
4267         else
4268           iii=ii
4269           jjj=jj
4270         endif
4271 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4272 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4273 C    distance and angle dependent SS bond potential.
4274         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4275      & iabs(itype(jjj)).eq.1) then
4276           call ssbond_ene(iii,jjj,eij)
4277           ehpb=ehpb+2*eij
4278 cd          write (iout,*) "eij",eij
4279         else
4280 C Calculate the distance between the two points and its difference from the
4281 C target distance.
4282         dd=dist(ii,jj)
4283         rdis=dd-dhpb(i)
4284 C Get the force constant corresponding to this distance.
4285         waga=forcon(i)
4286 C Calculate the contribution to energy.
4287         ehpb=ehpb+waga*rdis*rdis
4288 C
4289 C Evaluate gradient.
4290 C
4291         fac=waga*rdis/dd
4292 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4293 cd   &   ' waga=',waga,' fac=',fac
4294         do j=1,3
4295           ggg(j)=fac*(c(j,jj)-c(j,ii))
4296         enddo
4297 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4298 C If this is a SC-SC distance, we need to calculate the contributions to the
4299 C Cartesian gradient in the SC vectors (ghpbx).
4300         if (iii.lt.ii) then
4301           do j=1,3
4302             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4303             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4304           enddo
4305         endif
4306 cgrad        do j=iii,jjj-1
4307 cgrad          do k=1,3
4308 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4309 cgrad          enddo
4310 cgrad        enddo
4311         do k=1,3
4312           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4313           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4314         enddo
4315         endif
4316       enddo
4317       ehpb=0.5D0*ehpb
4318       return
4319       end
4320 C--------------------------------------------------------------------------
4321       subroutine ssbond_ene(i,j,eij)
4322 C
4323 C Calculate the distance and angle dependent SS-bond potential energy
4324 C using a free-energy function derived based on RHF/6-31G** ab initio
4325 C calculations of diethyl disulfide.
4326 C
4327 C A. Liwo and U. Kozlowska, 11/24/03
4328 C
4329       implicit real*8 (a-h,o-z)
4330       include 'DIMENSIONS'
4331       include 'COMMON.SBRIDGE'
4332       include 'COMMON.CHAIN'
4333       include 'COMMON.DERIV'
4334       include 'COMMON.LOCAL'
4335       include 'COMMON.INTERACT'
4336       include 'COMMON.VAR'
4337       include 'COMMON.IOUNITS'
4338       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4339       itypi=iabs(itype(i))
4340       xi=c(1,nres+i)
4341       yi=c(2,nres+i)
4342       zi=c(3,nres+i)
4343       dxi=dc_norm(1,nres+i)
4344       dyi=dc_norm(2,nres+i)
4345       dzi=dc_norm(3,nres+i)
4346 c      dsci_inv=dsc_inv(itypi)
4347       dsci_inv=vbld_inv(nres+i)
4348       itypj=iabs(itype(j))
4349 c      dscj_inv=dsc_inv(itypj)
4350       dscj_inv=vbld_inv(nres+j)
4351       xj=c(1,nres+j)-xi
4352       yj=c(2,nres+j)-yi
4353       zj=c(3,nres+j)-zi
4354       dxj=dc_norm(1,nres+j)
4355       dyj=dc_norm(2,nres+j)
4356       dzj=dc_norm(3,nres+j)
4357       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4358       rij=dsqrt(rrij)
4359       erij(1)=xj*rij
4360       erij(2)=yj*rij
4361       erij(3)=zj*rij
4362       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4363       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4364       om12=dxi*dxj+dyi*dyj+dzi*dzj
4365       do k=1,3
4366         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4367         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4368       enddo
4369       rij=1.0d0/rij
4370       deltad=rij-d0cm
4371       deltat1=1.0d0-om1
4372       deltat2=1.0d0+om2
4373       deltat12=om2-om1+2.0d0
4374       cosphi=om12-om1*om2
4375       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4376      &  +akct*deltad*deltat12
4377      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4378 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4379 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4380 c     &  " deltat12",deltat12," eij",eij
4381       ed=2*akcm*deltad+akct*deltat12
4382       pom1=akct*deltad
4383       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4384       eom1=-2*akth*deltat1-pom1-om2*pom2
4385       eom2= 2*akth*deltat2+pom1-om1*pom2
4386       eom12=pom2
4387       do k=1,3
4388         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4389         ghpbx(k,i)=ghpbx(k,i)-ggk
4390      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4391      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4392         ghpbx(k,j)=ghpbx(k,j)+ggk
4393      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4394      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4395         ghpbc(k,i)=ghpbc(k,i)-ggk
4396         ghpbc(k,j)=ghpbc(k,j)+ggk
4397       enddo
4398 C
4399 C Calculate the components of the gradient in DC and X
4400 C
4401 cgrad      do k=i,j-1
4402 cgrad        do l=1,3
4403 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4404 cgrad        enddo
4405 cgrad      enddo
4406       return
4407       end
4408 C--------------------------------------------------------------------------
4409       subroutine ebond(estr)
4410 c
4411 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4412 c
4413       implicit real*8 (a-h,o-z)
4414       include 'DIMENSIONS'
4415       include 'COMMON.LOCAL'
4416       include 'COMMON.GEO'
4417       include 'COMMON.INTERACT'
4418       include 'COMMON.DERIV'
4419       include 'COMMON.VAR'
4420       include 'COMMON.CHAIN'
4421       include 'COMMON.IOUNITS'
4422       include 'COMMON.NAMES'
4423       include 'COMMON.FFIELD'
4424       include 'COMMON.CONTROL'
4425       include 'COMMON.SETUP'
4426       double precision u(3),ud(3)
4427       estr=0.0d0
4428       estr1=0.0d0
4429       do i=ibondp_start,ibondp_end
4430         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4431           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4432           do j=1,3
4433           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4434      &      *dc(j,i-1)/vbld(i)
4435           enddo
4436           if (energy_dec) write(iout,*)
4437      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4438         else
4439         diff = vbld(i)-vbldp0
4440         if (energy_dec) write (iout,*)
4441      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4442         estr=estr+diff*diff
4443         do j=1,3
4444           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4445         enddo
4446 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4447         endif
4448       enddo
4449       estr=0.5d0*AKP*estr+estr1
4450 c
4451 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4452 c
4453       do i=ibond_start,ibond_end
4454         iti=iabs(itype(i))
4455         if (iti.ne.10 .and. iti.ne.ntyp1) then
4456           nbi=nbondterm(iti)
4457           if (nbi.eq.1) then
4458             diff=vbld(i+nres)-vbldsc0(1,iti)
4459             if (energy_dec) write (iout,*)
4460      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4461      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4462             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4463             do j=1,3
4464               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4465             enddo
4466           else
4467             do j=1,nbi
4468               diff=vbld(i+nres)-vbldsc0(j,iti)
4469               ud(j)=aksc(j,iti)*diff
4470               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4471             enddo
4472             uprod=u(1)
4473             do j=2,nbi
4474               uprod=uprod*u(j)
4475             enddo
4476             usum=0.0d0
4477             usumsqder=0.0d0
4478             do j=1,nbi
4479               uprod1=1.0d0
4480               uprod2=1.0d0
4481               do k=1,nbi
4482                 if (k.ne.j) then
4483                   uprod1=uprod1*u(k)
4484                   uprod2=uprod2*u(k)*u(k)
4485                 endif
4486               enddo
4487               usum=usum+uprod1
4488               usumsqder=usumsqder+ud(j)*uprod2
4489             enddo
4490             estr=estr+uprod/usum
4491             do j=1,3
4492              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4493             enddo
4494           endif
4495         endif
4496       enddo
4497       return
4498       end
4499 #ifdef CRYST_THETA
4500 C--------------------------------------------------------------------------
4501       subroutine ebend(etheta)
4502 C
4503 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4504 C angles gamma and its derivatives in consecutive thetas and gammas.
4505 C
4506       implicit real*8 (a-h,o-z)
4507       include 'DIMENSIONS'
4508       include 'COMMON.LOCAL'
4509       include 'COMMON.GEO'
4510       include 'COMMON.INTERACT'
4511       include 'COMMON.DERIV'
4512       include 'COMMON.VAR'
4513       include 'COMMON.CHAIN'
4514       include 'COMMON.IOUNITS'
4515       include 'COMMON.NAMES'
4516       include 'COMMON.FFIELD'
4517       include 'COMMON.CONTROL'
4518       common /calcthet/ term1,term2,termm,diffak,ratak,
4519      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4520      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4521       double precision y(2),z(2)
4522       delta=0.02d0*pi
4523 c      time11=dexp(-2*time)
4524 c      time12=1.0d0
4525       etheta=0.0D0
4526 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4527       do i=ithet_start,ithet_end
4528         if (itype(i-1).eq.ntyp1) cycle
4529 C Zero the energy function and its derivative at 0 or pi.
4530         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4531         it=itype(i-1)
4532         ichir1=isign(1,itype(i-2))
4533         ichir2=isign(1,itype(i))
4534          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4535          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4536          if (itype(i-1).eq.10) then
4537           itype1=isign(10,itype(i-2))
4538           ichir11=isign(1,itype(i-2))
4539           ichir12=isign(1,itype(i-2))
4540           itype2=isign(10,itype(i))
4541           ichir21=isign(1,itype(i))
4542           ichir22=isign(1,itype(i))
4543          endif
4544
4545         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4546 #ifdef OSF
4547           phii=phi(i)
4548           if (phii.ne.phii) phii=150.0
4549 #else
4550           phii=phi(i)
4551 #endif
4552           y(1)=dcos(phii)
4553           y(2)=dsin(phii)
4554         else
4555           y(1)=0.0D0
4556           y(2)=0.0D0
4557         endif
4558         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4559 #ifdef OSF
4560           phii1=phi(i+1)
4561           if (phii1.ne.phii1) phii1=150.0
4562           phii1=pinorm(phii1)
4563           z(1)=cos(phii1)
4564 #else
4565           phii1=phi(i+1)
4566           z(1)=dcos(phii1)
4567 #endif
4568           z(2)=dsin(phii1)
4569         else
4570           z(1)=0.0D0
4571           z(2)=0.0D0
4572         endif
4573 C Calculate the "mean" value of theta from the part of the distribution
4574 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4575 C In following comments this theta will be referred to as t_c.
4576         thet_pred_mean=0.0d0
4577         do k=1,2
4578             athetk=athet(k,it,ichir1,ichir2)
4579             bthetk=bthet(k,it,ichir1,ichir2)
4580           if (it.eq.10) then
4581              athetk=athet(k,itype1,ichir11,ichir12)
4582              bthetk=bthet(k,itype2,ichir21,ichir22)
4583           endif
4584          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4585         enddo
4586         dthett=thet_pred_mean*ssd
4587         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4588 C Derivatives of the "mean" values in gamma1 and gamma2.
4589         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4590      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4591          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4592      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4593          if (it.eq.10) then
4594       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4595      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4596         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4597      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4598          endif
4599         if (theta(i).gt.pi-delta) then
4600           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4601      &         E_tc0)
4602           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4603           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4604           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4605      &        E_theta)
4606           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4607      &        E_tc)
4608         else if (theta(i).lt.delta) then
4609           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4610           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4611           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4612      &        E_theta)
4613           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4614           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4615      &        E_tc)
4616         else
4617           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4618      &        E_theta,E_tc)
4619         endif
4620         etheta=etheta+ethetai
4621         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4622      &      'ebend',i,ethetai
4623         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4624         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4625         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4626       enddo
4627 C Ufff.... We've done all this!!!
4628       return
4629       end
4630 C---------------------------------------------------------------------------
4631       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4632      &     E_tc)
4633       implicit real*8 (a-h,o-z)
4634       include 'DIMENSIONS'
4635       include 'COMMON.LOCAL'
4636       include 'COMMON.IOUNITS'
4637       common /calcthet/ term1,term2,termm,diffak,ratak,
4638      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4639      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4640 C Calculate the contributions to both Gaussian lobes.
4641 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4642 C The "polynomial part" of the "standard deviation" of this part of
4643 C the distribution.
4644         sig=polthet(3,it)
4645         do j=2,0,-1
4646           sig=sig*thet_pred_mean+polthet(j,it)
4647         enddo
4648 C Derivative of the "interior part" of the "standard deviation of the"
4649 C gamma-dependent Gaussian lobe in t_c.
4650         sigtc=3*polthet(3,it)
4651         do j=2,1,-1
4652           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4653         enddo
4654         sigtc=sig*sigtc
4655 C Set the parameters of both Gaussian lobes of the distribution.
4656 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4657         fac=sig*sig+sigc0(it)
4658         sigcsq=fac+fac
4659         sigc=1.0D0/sigcsq
4660 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4661         sigsqtc=-4.0D0*sigcsq*sigtc
4662 c       print *,i,sig,sigtc,sigsqtc
4663 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4664         sigtc=-sigtc/(fac*fac)
4665 C Following variable is sigma(t_c)**(-2)
4666         sigcsq=sigcsq*sigcsq
4667         sig0i=sig0(it)
4668         sig0inv=1.0D0/sig0i**2
4669         delthec=thetai-thet_pred_mean
4670         delthe0=thetai-theta0i
4671         term1=-0.5D0*sigcsq*delthec*delthec
4672         term2=-0.5D0*sig0inv*delthe0*delthe0
4673 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4674 C NaNs in taking the logarithm. We extract the largest exponent which is added
4675 C to the energy (this being the log of the distribution) at the end of energy
4676 C term evaluation for this virtual-bond angle.
4677         if (term1.gt.term2) then
4678           termm=term1
4679           term2=dexp(term2-termm)
4680           term1=1.0d0
4681         else
4682           termm=term2
4683           term1=dexp(term1-termm)
4684           term2=1.0d0
4685         endif
4686 C The ratio between the gamma-independent and gamma-dependent lobes of
4687 C the distribution is a Gaussian function of thet_pred_mean too.
4688         diffak=gthet(2,it)-thet_pred_mean
4689         ratak=diffak/gthet(3,it)**2
4690         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4691 C Let's differentiate it in thet_pred_mean NOW.
4692         aktc=ak*ratak
4693 C Now put together the distribution terms to make complete distribution.
4694         termexp=term1+ak*term2
4695         termpre=sigc+ak*sig0i
4696 C Contribution of the bending energy from this theta is just the -log of
4697 C the sum of the contributions from the two lobes and the pre-exponential
4698 C factor. Simple enough, isn't it?
4699         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4700 C NOW the derivatives!!!
4701 C 6/6/97 Take into account the deformation.
4702         E_theta=(delthec*sigcsq*term1
4703      &       +ak*delthe0*sig0inv*term2)/termexp
4704         E_tc=((sigtc+aktc*sig0i)/termpre
4705      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4706      &       aktc*term2)/termexp)
4707       return
4708       end
4709 c-----------------------------------------------------------------------------
4710       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4711       implicit real*8 (a-h,o-z)
4712       include 'DIMENSIONS'
4713       include 'COMMON.LOCAL'
4714       include 'COMMON.IOUNITS'
4715       common /calcthet/ term1,term2,termm,diffak,ratak,
4716      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4717      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4718       delthec=thetai-thet_pred_mean
4719       delthe0=thetai-theta0i
4720 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4721       t3 = thetai-thet_pred_mean
4722       t6 = t3**2
4723       t9 = term1
4724       t12 = t3*sigcsq
4725       t14 = t12+t6*sigsqtc
4726       t16 = 1.0d0
4727       t21 = thetai-theta0i
4728       t23 = t21**2
4729       t26 = term2
4730       t27 = t21*t26
4731       t32 = termexp
4732       t40 = t32**2
4733       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4734      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4735      & *(-t12*t9-ak*sig0inv*t27)
4736       return
4737       end
4738 #else
4739 C--------------------------------------------------------------------------
4740       subroutine ebend(etheta)
4741 C
4742 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4743 C angles gamma and its derivatives in consecutive thetas and gammas.
4744 C ab initio-derived potentials from
4745 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4746 C
4747       implicit real*8 (a-h,o-z)
4748       include 'DIMENSIONS'
4749       include 'COMMON.LOCAL'
4750       include 'COMMON.GEO'
4751       include 'COMMON.INTERACT'
4752       include 'COMMON.DERIV'
4753       include 'COMMON.VAR'
4754       include 'COMMON.CHAIN'
4755       include 'COMMON.IOUNITS'
4756       include 'COMMON.NAMES'
4757       include 'COMMON.FFIELD'
4758       include 'COMMON.CONTROL'
4759       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4760      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4761      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4762      & sinph1ph2(maxdouble,maxdouble)
4763       logical lprn /.false./, lprn1 /.false./
4764       etheta=0.0D0
4765       do i=ithet_start,ithet_end
4766         if (itype(i-1).eq.ntyp1) cycle
4767         if (iabs(itype(i+1)).eq.20) iblock=2
4768         if (iabs(itype(i+1)).ne.20) iblock=1
4769         dethetai=0.0d0
4770         dephii=0.0d0
4771         dephii1=0.0d0
4772         theti2=0.5d0*theta(i)
4773         ityp2=ithetyp((itype(i-1)))
4774         do k=1,nntheterm
4775           coskt(k)=dcos(k*theti2)
4776           sinkt(k)=dsin(k*theti2)
4777         enddo
4778         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4779 #ifdef OSF
4780           phii=phi(i)
4781           if (phii.ne.phii) phii=150.0
4782 #else
4783           phii=phi(i)
4784 #endif
4785           ityp1=ithetyp((itype(i-2)))
4786 C propagation of chirality for glycine type
4787           do k=1,nsingle
4788             cosph1(k)=dcos(k*phii)
4789             sinph1(k)=dsin(k*phii)
4790           enddo
4791         else
4792           phii=0.0d0
4793           ityp1=nthetyp+1
4794           do k=1,nsingle
4795             cosph1(k)=0.0d0
4796             sinph1(k)=0.0d0
4797           enddo
4798         endif
4799         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4800 #ifdef OSF
4801           phii1=phi(i+1)
4802           if (phii1.ne.phii1) phii1=150.0
4803           phii1=pinorm(phii1)
4804 #else
4805           phii1=phi(i+1)
4806 #endif
4807           ityp3=ithetyp((itype(i)))
4808           do k=1,nsingle
4809             cosph2(k)=dcos(k*phii1)
4810             sinph2(k)=dsin(k*phii1)
4811           enddo
4812         else
4813           phii1=0.0d0
4814           ityp3=nthetyp+1
4815           do k=1,nsingle
4816             cosph2(k)=0.0d0
4817             sinph2(k)=0.0d0
4818           enddo
4819         endif
4820         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4821         do k=1,ndouble
4822           do l=1,k-1
4823             ccl=cosph1(l)*cosph2(k-l)
4824             ssl=sinph1(l)*sinph2(k-l)
4825             scl=sinph1(l)*cosph2(k-l)
4826             csl=cosph1(l)*sinph2(k-l)
4827             cosph1ph2(l,k)=ccl-ssl
4828             cosph1ph2(k,l)=ccl+ssl
4829             sinph1ph2(l,k)=scl+csl
4830             sinph1ph2(k,l)=scl-csl
4831           enddo
4832         enddo
4833         if (lprn) then
4834         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4835      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4836         write (iout,*) "coskt and sinkt"
4837         do k=1,nntheterm
4838           write (iout,*) k,coskt(k),sinkt(k)
4839         enddo
4840         endif
4841         do k=1,ntheterm
4842           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4843           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4844      &      *coskt(k)
4845           if (lprn)
4846      &    write (iout,*) "k",k,"
4847      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4848      &     " ethetai",ethetai
4849         enddo
4850         if (lprn) then
4851         write (iout,*) "cosph and sinph"
4852         do k=1,nsingle
4853           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4854         enddo
4855         write (iout,*) "cosph1ph2 and sinph2ph2"
4856         do k=2,ndouble
4857           do l=1,k-1
4858             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4859      &         sinph1ph2(l,k),sinph1ph2(k,l)
4860           enddo
4861         enddo
4862         write(iout,*) "ethetai",ethetai
4863         endif
4864         do m=1,ntheterm2
4865           do k=1,nsingle
4866             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4867      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4868      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4869      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4870             ethetai=ethetai+sinkt(m)*aux
4871             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4872             dephii=dephii+k*sinkt(m)*(
4873      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4874      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4875             dephii1=dephii1+k*sinkt(m)*(
4876      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4877      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4878             if (lprn)
4879      &      write (iout,*) "m",m," k",k," bbthet",
4880      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4881      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4882      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4883      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4884           enddo
4885         enddo
4886         if (lprn)
4887      &  write(iout,*) "ethetai",ethetai
4888         do m=1,ntheterm3
4889           do k=2,ndouble
4890             do l=1,k-1
4891               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4892      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4893      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4894      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4895               ethetai=ethetai+sinkt(m)*aux
4896               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4897               dephii=dephii+l*sinkt(m)*(
4898      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4899      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4900      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4901      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4902               dephii1=dephii1+(k-l)*sinkt(m)*(
4903      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4904      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4905      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4906      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4907               if (lprn) then
4908               write (iout,*) "m",m," k",k," l",l," ffthet",
4909      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4910      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4911      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4912      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4913      &            " ethetai",ethetai
4914               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4915      &            cosph1ph2(k,l)*sinkt(m),
4916      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4917               endif
4918             enddo
4919           enddo
4920         enddo
4921 10      continue
4922 c        lprn1=.true.
4923         if (lprn1)
4924      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4925      &   i,theta(i)*rad2deg,phii*rad2deg,
4926      &   phii1*rad2deg,ethetai
4927 c        lprn1=.false.
4928         etheta=etheta+ethetai
4929         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4930         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4931         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
4932       enddo
4933       return
4934       end
4935 #endif
4936 #ifdef CRYST_SC
4937 c-----------------------------------------------------------------------------
4938       subroutine esc(escloc)
4939 C Calculate the local energy of a side chain and its derivatives in the
4940 C corresponding virtual-bond valence angles THETA and the spherical angles
4941 C ALPHA and OMEGA.
4942       implicit real*8 (a-h,o-z)
4943       include 'DIMENSIONS'
4944       include 'COMMON.GEO'
4945       include 'COMMON.LOCAL'
4946       include 'COMMON.VAR'
4947       include 'COMMON.INTERACT'
4948       include 'COMMON.DERIV'
4949       include 'COMMON.CHAIN'
4950       include 'COMMON.IOUNITS'
4951       include 'COMMON.NAMES'
4952       include 'COMMON.FFIELD'
4953       include 'COMMON.CONTROL'
4954       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4955      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4956       common /sccalc/ time11,time12,time112,theti,it,nlobit
4957       delta=0.02d0*pi
4958       escloc=0.0D0
4959 c     write (iout,'(a)') 'ESC'
4960       do i=loc_start,loc_end
4961         it=itype(i)
4962         if (it.eq.ntyp1) cycle
4963         if (it.eq.10) goto 1
4964         nlobit=nlob(iabs(it))
4965 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4966 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4967         theti=theta(i+1)-pipol
4968         x(1)=dtan(theti)
4969         x(2)=alph(i)
4970         x(3)=omeg(i)
4971
4972         if (x(2).gt.pi-delta) then
4973           xtemp(1)=x(1)
4974           xtemp(2)=pi-delta
4975           xtemp(3)=x(3)
4976           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4977           xtemp(2)=pi
4978           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4979           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4980      &        escloci,dersc(2))
4981           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4982      &        ddersc0(1),dersc(1))
4983           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4984      &        ddersc0(3),dersc(3))
4985           xtemp(2)=pi-delta
4986           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4987           xtemp(2)=pi
4988           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4989           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4990      &            dersc0(2),esclocbi,dersc02)
4991           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4992      &            dersc12,dersc01)
4993           call splinthet(x(2),0.5d0*delta,ss,ssd)
4994           dersc0(1)=dersc01
4995           dersc0(2)=dersc02
4996           dersc0(3)=0.0d0
4997           do k=1,3
4998             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4999           enddo
5000           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5001 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5002 c    &             esclocbi,ss,ssd
5003           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5004 c         escloci=esclocbi
5005 c         write (iout,*) escloci
5006         else if (x(2).lt.delta) then
5007           xtemp(1)=x(1)
5008           xtemp(2)=delta
5009           xtemp(3)=x(3)
5010           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5011           xtemp(2)=0.0d0
5012           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5013           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5014      &        escloci,dersc(2))
5015           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5016      &        ddersc0(1),dersc(1))
5017           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5018      &        ddersc0(3),dersc(3))
5019           xtemp(2)=delta
5020           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5021           xtemp(2)=0.0d0
5022           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5023           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5024      &            dersc0(2),esclocbi,dersc02)
5025           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5026      &            dersc12,dersc01)
5027           dersc0(1)=dersc01
5028           dersc0(2)=dersc02
5029           dersc0(3)=0.0d0
5030           call splinthet(x(2),0.5d0*delta,ss,ssd)
5031           do k=1,3
5032             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5033           enddo
5034           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5035 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5036 c    &             esclocbi,ss,ssd
5037           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5038 c         write (iout,*) escloci
5039         else
5040           call enesc(x,escloci,dersc,ddummy,.false.)
5041         endif
5042
5043         escloc=escloc+escloci
5044         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5045      &     'escloc',i,escloci
5046 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5047
5048         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5049      &   wscloc*dersc(1)
5050         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5051         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5052     1   continue
5053       enddo
5054       return
5055       end
5056 C---------------------------------------------------------------------------
5057       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5058       implicit real*8 (a-h,o-z)
5059       include 'DIMENSIONS'
5060       include 'COMMON.GEO'
5061       include 'COMMON.LOCAL'
5062       include 'COMMON.IOUNITS'
5063       common /sccalc/ time11,time12,time112,theti,it,nlobit
5064       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5065       double precision contr(maxlob,-1:1)
5066       logical mixed
5067 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5068         escloc_i=0.0D0
5069         do j=1,3
5070           dersc(j)=0.0D0
5071           if (mixed) ddersc(j)=0.0d0
5072         enddo
5073         x3=x(3)
5074
5075 C Because of periodicity of the dependence of the SC energy in omega we have
5076 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5077 C To avoid underflows, first compute & store the exponents.
5078
5079         do iii=-1,1
5080
5081           x(3)=x3+iii*dwapi
5082
5083           do j=1,nlobit
5084             do k=1,3
5085               z(k)=x(k)-censc(k,j,it)
5086             enddo
5087             do k=1,3
5088               Axk=0.0D0
5089               do l=1,3
5090                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5091               enddo
5092               Ax(k,j,iii)=Axk
5093             enddo
5094             expfac=0.0D0
5095             do k=1,3
5096               expfac=expfac+Ax(k,j,iii)*z(k)
5097             enddo
5098             contr(j,iii)=expfac
5099           enddo ! j
5100
5101         enddo ! iii
5102
5103         x(3)=x3
5104 C As in the case of ebend, we want to avoid underflows in exponentiation and
5105 C subsequent NaNs and INFs in energy calculation.
5106 C Find the largest exponent
5107         emin=contr(1,-1)
5108         do iii=-1,1
5109           do j=1,nlobit
5110             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5111           enddo
5112         enddo
5113         emin=0.5D0*emin
5114 cd      print *,'it=',it,' emin=',emin
5115
5116 C Compute the contribution to SC energy and derivatives
5117         do iii=-1,1
5118
5119           do j=1,nlobit
5120 #ifdef OSF
5121             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5122             if(adexp.ne.adexp) adexp=1.0
5123             expfac=dexp(adexp)
5124 #else
5125             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5126 #endif
5127 cd          print *,'j=',j,' expfac=',expfac
5128             escloc_i=escloc_i+expfac
5129             do k=1,3
5130               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5131             enddo
5132             if (mixed) then
5133               do k=1,3,2
5134                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5135      &            +gaussc(k,2,j,it))*expfac
5136               enddo
5137             endif
5138           enddo
5139
5140         enddo ! iii
5141
5142         dersc(1)=dersc(1)/cos(theti)**2
5143         ddersc(1)=ddersc(1)/cos(theti)**2
5144         ddersc(3)=ddersc(3)
5145
5146         escloci=-(dlog(escloc_i)-emin)
5147         do j=1,3
5148           dersc(j)=dersc(j)/escloc_i
5149         enddo
5150         if (mixed) then
5151           do j=1,3,2
5152             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5153           enddo
5154         endif
5155       return
5156       end
5157 C------------------------------------------------------------------------------
5158       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5159       implicit real*8 (a-h,o-z)
5160       include 'DIMENSIONS'
5161       include 'COMMON.GEO'
5162       include 'COMMON.LOCAL'
5163       include 'COMMON.IOUNITS'
5164       common /sccalc/ time11,time12,time112,theti,it,nlobit
5165       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5166       double precision contr(maxlob)
5167       logical mixed
5168
5169       escloc_i=0.0D0
5170
5171       do j=1,3
5172         dersc(j)=0.0D0
5173       enddo
5174
5175       do j=1,nlobit
5176         do k=1,2
5177           z(k)=x(k)-censc(k,j,it)
5178         enddo
5179         z(3)=dwapi
5180         do k=1,3
5181           Axk=0.0D0
5182           do l=1,3
5183             Axk=Axk+gaussc(l,k,j,it)*z(l)
5184           enddo
5185           Ax(k,j)=Axk
5186         enddo
5187         expfac=0.0D0
5188         do k=1,3
5189           expfac=expfac+Ax(k,j)*z(k)
5190         enddo
5191         contr(j)=expfac
5192       enddo ! j
5193
5194 C As in the case of ebend, we want to avoid underflows in exponentiation and
5195 C subsequent NaNs and INFs in energy calculation.
5196 C Find the largest exponent
5197       emin=contr(1)
5198       do j=1,nlobit
5199         if (emin.gt.contr(j)) emin=contr(j)
5200       enddo
5201       emin=0.5D0*emin
5202
5203 C Compute the contribution to SC energy and derivatives
5204
5205       dersc12=0.0d0
5206       do j=1,nlobit
5207         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5208         escloc_i=escloc_i+expfac
5209         do k=1,2
5210           dersc(k)=dersc(k)+Ax(k,j)*expfac
5211         enddo
5212         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5213      &            +gaussc(1,2,j,it))*expfac
5214         dersc(3)=0.0d0
5215       enddo
5216
5217       dersc(1)=dersc(1)/cos(theti)**2
5218       dersc12=dersc12/cos(theti)**2
5219       escloci=-(dlog(escloc_i)-emin)
5220       do j=1,2
5221         dersc(j)=dersc(j)/escloc_i
5222       enddo
5223       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5224       return
5225       end
5226 #else
5227 c----------------------------------------------------------------------------------
5228       subroutine esc(escloc)
5229 C Calculate the local energy of a side chain and its derivatives in the
5230 C corresponding virtual-bond valence angles THETA and the spherical angles
5231 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5232 C added by Urszula Kozlowska. 07/11/2007
5233 C
5234       implicit real*8 (a-h,o-z)
5235       include 'DIMENSIONS'
5236       include 'COMMON.GEO'
5237       include 'COMMON.LOCAL'
5238       include 'COMMON.VAR'
5239       include 'COMMON.SCROT'
5240       include 'COMMON.INTERACT'
5241       include 'COMMON.DERIV'
5242       include 'COMMON.CHAIN'
5243       include 'COMMON.IOUNITS'
5244       include 'COMMON.NAMES'
5245       include 'COMMON.FFIELD'
5246       include 'COMMON.CONTROL'
5247       include 'COMMON.VECTORS'
5248       double precision x_prime(3),y_prime(3),z_prime(3)
5249      &    , sumene,dsc_i,dp2_i,x(65),
5250      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5251      &    de_dxx,de_dyy,de_dzz,de_dt
5252       double precision s1_t,s1_6_t,s2_t,s2_6_t
5253       double precision
5254      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5255      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5256      & dt_dCi(3),dt_dCi1(3)
5257       common /sccalc/ time11,time12,time112,theti,it,nlobit
5258       delta=0.02d0*pi
5259       escloc=0.0D0
5260       do i=loc_start,loc_end
5261         if (itype(i).eq.ntyp1) cycle
5262         costtab(i+1) =dcos(theta(i+1))
5263         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5264         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5265         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5266         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5267         cosfac=dsqrt(cosfac2)
5268         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5269         sinfac=dsqrt(sinfac2)
5270         it=iabs(itype(i))
5271         if (it.eq.10) goto 1
5272 c
5273 C  Compute the axes of tghe local cartesian coordinates system; store in
5274 c   x_prime, y_prime and z_prime
5275 c
5276         do j=1,3
5277           x_prime(j) = 0.00
5278           y_prime(j) = 0.00
5279           z_prime(j) = 0.00
5280         enddo
5281 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5282 C     &   dc_norm(3,i+nres)
5283         do j = 1,3
5284           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5285           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5286         enddo
5287         do j = 1,3
5288           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5289         enddo
5290 c       write (2,*) "i",i
5291 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5292 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5293 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5294 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5295 c      & " xy",scalar(x_prime(1),y_prime(1)),
5296 c      & " xz",scalar(x_prime(1),z_prime(1)),
5297 c      & " yy",scalar(y_prime(1),y_prime(1)),
5298 c      & " yz",scalar(y_prime(1),z_prime(1)),
5299 c      & " zz",scalar(z_prime(1),z_prime(1))
5300 c
5301 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5302 C to local coordinate system. Store in xx, yy, zz.
5303 c
5304         xx=0.0d0
5305         yy=0.0d0
5306         zz=0.0d0
5307         do j = 1,3
5308           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5309           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5310           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5311         enddo
5312
5313         xxtab(i)=xx
5314         yytab(i)=yy
5315         zztab(i)=zz
5316 C
5317 C Compute the energy of the ith side cbain
5318 C
5319 c        write (2,*) "xx",xx," yy",yy," zz",zz
5320         it=iabs(itype(i))
5321         do j = 1,65
5322           x(j) = sc_parmin(j,it)
5323         enddo
5324 #ifdef CHECK_COORD
5325 Cc diagnostics - remove later
5326         xx1 = dcos(alph(2))
5327         yy1 = dsin(alph(2))*dcos(omeg(2))
5328         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5329         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5330      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5331      &    xx1,yy1,zz1
5332 C,"  --- ", xx_w,yy_w,zz_w
5333 c end diagnostics
5334 #endif
5335         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5336      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5337      &   + x(10)*yy*zz
5338         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5339      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5340      & + x(20)*yy*zz
5341         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5342      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5343      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5344      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5345      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5346      &  +x(40)*xx*yy*zz
5347         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5348      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5349      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5350      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5351      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5352      &  +x(60)*xx*yy*zz
5353         dsc_i   = 0.743d0+x(61)
5354         dp2_i   = 1.9d0+x(62)
5355         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5356      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5357         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5358      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5359         s1=(1+x(63))/(0.1d0 + dscp1)
5360         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5361         s2=(1+x(65))/(0.1d0 + dscp2)
5362         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5363         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5364      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5365 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5366 c     &   sumene4,
5367 c     &   dscp1,dscp2,sumene
5368 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5369         escloc = escloc + sumene
5370 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5371 c     & ,zz,xx,yy
5372 c#define DEBUG
5373 #ifdef DEBUG
5374 C
5375 C This section to check the numerical derivatives of the energy of ith side
5376 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5377 C #define DEBUG in the code to turn it on.
5378 C
5379         write (2,*) "sumene               =",sumene
5380         aincr=1.0d-7
5381         xxsave=xx
5382         xx=xx+aincr
5383         write (2,*) xx,yy,zz
5384         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5385         de_dxx_num=(sumenep-sumene)/aincr
5386         xx=xxsave
5387         write (2,*) "xx+ sumene from enesc=",sumenep
5388         yysave=yy
5389         yy=yy+aincr
5390         write (2,*) xx,yy,zz
5391         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5392         de_dyy_num=(sumenep-sumene)/aincr
5393         yy=yysave
5394         write (2,*) "yy+ sumene from enesc=",sumenep
5395         zzsave=zz
5396         zz=zz+aincr
5397         write (2,*) xx,yy,zz
5398         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5399         de_dzz_num=(sumenep-sumene)/aincr
5400         zz=zzsave
5401         write (2,*) "zz+ sumene from enesc=",sumenep
5402         costsave=cost2tab(i+1)
5403         sintsave=sint2tab(i+1)
5404         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5405         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5406         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5407         de_dt_num=(sumenep-sumene)/aincr
5408         write (2,*) " t+ sumene from enesc=",sumenep
5409         cost2tab(i+1)=costsave
5410         sint2tab(i+1)=sintsave
5411 C End of diagnostics section.
5412 #endif
5413 C
5414 C Compute the gradient of esc
5415 C
5416 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5417         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5418         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5419         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5420         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5421         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5422         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5423         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5424         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5425         pom1=(sumene3*sint2tab(i+1)+sumene1)
5426      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5427         pom2=(sumene4*cost2tab(i+1)+sumene2)
5428      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5429         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5430         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5431      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5432      &  +x(40)*yy*zz
5433         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5434         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5435      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5436      &  +x(60)*yy*zz
5437         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5438      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5439      &        +(pom1+pom2)*pom_dx
5440 #ifdef DEBUG
5441         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5442 #endif
5443 C
5444         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5445         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5446      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5447      &  +x(40)*xx*zz
5448         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5449         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5450      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5451      &  +x(59)*zz**2 +x(60)*xx*zz
5452         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5453      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5454      &        +(pom1-pom2)*pom_dy
5455 #ifdef DEBUG
5456         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5457 #endif
5458 C
5459         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5460      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5461      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5462      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5463      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5464      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5465      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5466      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5467 #ifdef DEBUG
5468         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5469 #endif
5470 C
5471         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5472      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5473      &  +pom1*pom_dt1+pom2*pom_dt2
5474 #ifdef DEBUG
5475         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5476 #endif
5477 c#undef DEBUG
5478 c
5479 C
5480        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5481        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5482        cosfac2xx=cosfac2*xx
5483        sinfac2yy=sinfac2*yy
5484        do k = 1,3
5485          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5486      &      vbld_inv(i+1)
5487          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5488      &      vbld_inv(i)
5489          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5490          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5491 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5492 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5493 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5494 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5495          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5496          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5497          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5498          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5499          dZZ_Ci1(k)=0.0d0
5500          dZZ_Ci(k)=0.0d0
5501          do j=1,3
5502            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5503      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5504            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5505      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5506          enddo
5507
5508          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5509          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5510          dZZ_XYZ(k)=vbld_inv(i+nres)*
5511      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5512 c
5513          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5514          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5515        enddo
5516
5517        do k=1,3
5518          dXX_Ctab(k,i)=dXX_Ci(k)
5519          dXX_C1tab(k,i)=dXX_Ci1(k)
5520          dYY_Ctab(k,i)=dYY_Ci(k)
5521          dYY_C1tab(k,i)=dYY_Ci1(k)
5522          dZZ_Ctab(k,i)=dZZ_Ci(k)
5523          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5524          dXX_XYZtab(k,i)=dXX_XYZ(k)
5525          dYY_XYZtab(k,i)=dYY_XYZ(k)
5526          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5527        enddo
5528
5529        do k = 1,3
5530 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5531 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5532 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5533 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5534 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5535 c     &    dt_dci(k)
5536 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5537 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5538          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5539      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5540          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5541      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5542          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5543      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5544        enddo
5545 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5546 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5547
5548 C to check gradient call subroutine check_grad
5549
5550     1 continue
5551       enddo
5552       return
5553       end
5554 c------------------------------------------------------------------------------
5555       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5556       implicit none
5557       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5558      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5559       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5560      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5561      &   + x(10)*yy*zz
5562       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5563      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5564      & + x(20)*yy*zz
5565       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5566      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5567      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5568      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5569      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5570      &  +x(40)*xx*yy*zz
5571       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5572      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5573      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5574      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5575      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5576      &  +x(60)*xx*yy*zz
5577       dsc_i   = 0.743d0+x(61)
5578       dp2_i   = 1.9d0+x(62)
5579       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5580      &          *(xx*cost2+yy*sint2))
5581       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5582      &          *(xx*cost2-yy*sint2))
5583       s1=(1+x(63))/(0.1d0 + dscp1)
5584       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5585       s2=(1+x(65))/(0.1d0 + dscp2)
5586       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5587       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5588      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5589       enesc=sumene
5590       return
5591       end
5592 #endif
5593 c------------------------------------------------------------------------------
5594       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5595 C
5596 C This procedure calculates two-body contact function g(rij) and its derivative:
5597 C
5598 C           eps0ij                                     !       x < -1
5599 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5600 C            0                                         !       x > 1
5601 C
5602 C where x=(rij-r0ij)/delta
5603 C
5604 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5605 C
5606       implicit none
5607       double precision rij,r0ij,eps0ij,fcont,fprimcont
5608       double precision x,x2,x4,delta
5609 c     delta=0.02D0*r0ij
5610 c      delta=0.2D0*r0ij
5611       x=(rij-r0ij)/delta
5612       if (x.lt.-1.0D0) then
5613         fcont=eps0ij
5614         fprimcont=0.0D0
5615       else if (x.le.1.0D0) then
5616         x2=x*x
5617         x4=x2*x2
5618         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5619         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5620       else
5621         fcont=0.0D0
5622         fprimcont=0.0D0
5623       endif
5624       return
5625       end
5626 c------------------------------------------------------------------------------
5627       subroutine splinthet(theti,delta,ss,ssder)
5628       implicit real*8 (a-h,o-z)
5629       include 'DIMENSIONS'
5630       include 'COMMON.VAR'
5631       include 'COMMON.GEO'
5632       thetup=pi-delta
5633       thetlow=delta
5634       if (theti.gt.pipol) then
5635         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5636       else
5637         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5638         ssder=-ssder
5639       endif
5640       return
5641       end
5642 c------------------------------------------------------------------------------
5643       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5644       implicit none
5645       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5646       double precision ksi,ksi2,ksi3,a1,a2,a3
5647       a1=fprim0*delta/(f1-f0)
5648       a2=3.0d0-2.0d0*a1
5649       a3=a1-2.0d0
5650       ksi=(x-x0)/delta
5651       ksi2=ksi*ksi
5652       ksi3=ksi2*ksi
5653       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5654       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5655       return
5656       end
5657 c------------------------------------------------------------------------------
5658       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5659       implicit none
5660       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5661       double precision ksi,ksi2,ksi3,a1,a2,a3
5662       ksi=(x-x0)/delta
5663       ksi2=ksi*ksi
5664       ksi3=ksi2*ksi
5665       a1=fprim0x*delta
5666       a2=3*(f1x-f0x)-2*fprim0x*delta
5667       a3=fprim0x*delta-2*(f1x-f0x)
5668       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5669       return
5670       end
5671 C-----------------------------------------------------------------------------
5672 #ifdef CRYST_TOR
5673 C-----------------------------------------------------------------------------
5674       subroutine etor(etors,edihcnstr)
5675       implicit real*8 (a-h,o-z)
5676       include 'DIMENSIONS'
5677       include 'COMMON.VAR'
5678       include 'COMMON.GEO'
5679       include 'COMMON.LOCAL'
5680       include 'COMMON.TORSION'
5681       include 'COMMON.INTERACT'
5682       include 'COMMON.DERIV'
5683       include 'COMMON.CHAIN'
5684       include 'COMMON.NAMES'
5685       include 'COMMON.IOUNITS'
5686       include 'COMMON.FFIELD'
5687       include 'COMMON.TORCNSTR'
5688       include 'COMMON.CONTROL'
5689       logical lprn
5690 C Set lprn=.true. for debugging
5691       lprn=.false.
5692 c      lprn=.true.
5693       etors=0.0D0
5694       do i=iphi_start,iphi_end
5695       etors_ii=0.0D0
5696         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5697      &      .or. itype(i).eq.ntyp1) cycle
5698         itori=itortyp(itype(i-2))
5699         itori1=itortyp(itype(i-1))
5700         phii=phi(i)
5701         gloci=0.0D0
5702 C Proline-Proline pair is a special case...
5703         if (itori.eq.3 .and. itori1.eq.3) then
5704           if (phii.gt.-dwapi3) then
5705             cosphi=dcos(3*phii)
5706             fac=1.0D0/(1.0D0-cosphi)
5707             etorsi=v1(1,3,3)*fac
5708             etorsi=etorsi+etorsi
5709             etors=etors+etorsi-v1(1,3,3)
5710             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5711             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5712           endif
5713           do j=1,3
5714             v1ij=v1(j+1,itori,itori1)
5715             v2ij=v2(j+1,itori,itori1)
5716             cosphi=dcos(j*phii)
5717             sinphi=dsin(j*phii)
5718             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5719             if (energy_dec) etors_ii=etors_ii+
5720      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5721             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5722           enddo
5723         else
5724           do j=1,nterm_old
5725             v1ij=v1(j,itori,itori1)
5726             v2ij=v2(j,itori,itori1)
5727             cosphi=dcos(j*phii)
5728             sinphi=dsin(j*phii)
5729             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5730             if (energy_dec) etors_ii=etors_ii+
5731      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5732             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5733           enddo
5734         endif
5735         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5736              'etor',i,etors_ii
5737         if (lprn)
5738      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5739      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5740      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5741         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5742 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5743       enddo
5744 ! 6/20/98 - dihedral angle constraints
5745       edihcnstr=0.0d0
5746       do i=1,ndih_constr
5747         itori=idih_constr(i)
5748         phii=phi(itori)
5749         difi=phii-phi0(i)
5750         if (difi.gt.drange(i)) then
5751           difi=difi-drange(i)
5752           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5753           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5754         else if (difi.lt.-drange(i)) then
5755           difi=difi+drange(i)
5756           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5757           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5758         endif
5759 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5760 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5761       enddo
5762 !      write (iout,*) 'edihcnstr',edihcnstr
5763       return
5764       end
5765 c------------------------------------------------------------------------------
5766       subroutine etor_d(etors_d)
5767       etors_d=0.0d0
5768       return
5769       end
5770 c----------------------------------------------------------------------------
5771 #else
5772       subroutine etor(etors,edihcnstr)
5773       implicit real*8 (a-h,o-z)
5774       include 'DIMENSIONS'
5775       include 'COMMON.VAR'
5776       include 'COMMON.GEO'
5777       include 'COMMON.LOCAL'
5778       include 'COMMON.TORSION'
5779       include 'COMMON.INTERACT'
5780       include 'COMMON.DERIV'
5781       include 'COMMON.CHAIN'
5782       include 'COMMON.NAMES'
5783       include 'COMMON.IOUNITS'
5784       include 'COMMON.FFIELD'
5785       include 'COMMON.TORCNSTR'
5786       include 'COMMON.CONTROL'
5787       logical lprn
5788 C Set lprn=.true. for debugging
5789       lprn=.false.
5790 c     lprn=.true.
5791       etors=0.0D0
5792       do i=iphi_start,iphi_end
5793         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5794      &       .or. itype(i).eq.ntyp1) cycle
5795         etors_ii=0.0D0
5796          if (iabs(itype(i)).eq.20) then
5797          iblock=2
5798          else
5799          iblock=1
5800          endif
5801         itori=itortyp(itype(i-2))
5802         itori1=itortyp(itype(i-1))
5803         phii=phi(i)
5804         gloci=0.0D0
5805 C Regular cosine and sine terms
5806         do j=1,nterm(itori,itori1,iblock)
5807           v1ij=v1(j,itori,itori1,iblock)
5808           v2ij=v2(j,itori,itori1,iblock)
5809           cosphi=dcos(j*phii)
5810           sinphi=dsin(j*phii)
5811           etors=etors+v1ij*cosphi+v2ij*sinphi
5812           if (energy_dec) etors_ii=etors_ii+
5813      &                v1ij*cosphi+v2ij*sinphi
5814           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5815         enddo
5816 C Lorentz terms
5817 C                         v1
5818 C  E = SUM ----------------------------------- - v1
5819 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5820 C
5821         cosphi=dcos(0.5d0*phii)
5822         sinphi=dsin(0.5d0*phii)
5823         do j=1,nlor(itori,itori1,iblock)
5824           vl1ij=vlor1(j,itori,itori1)
5825           vl2ij=vlor2(j,itori,itori1)
5826           vl3ij=vlor3(j,itori,itori1)
5827           pom=vl2ij*cosphi+vl3ij*sinphi
5828           pom1=1.0d0/(pom*pom+1.0d0)
5829           etors=etors+vl1ij*pom1
5830           if (energy_dec) etors_ii=etors_ii+
5831      &                vl1ij*pom1
5832           pom=-pom*pom1*pom1
5833           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5834         enddo
5835 C Subtract the constant term
5836         etors=etors-v0(itori,itori1,iblock)
5837           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5838      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5839         if (lprn)
5840      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5841      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5842      &  (v1(j,itori,itori1,iblock),j=1,6),
5843      &  (v2(j,itori,itori1,iblock),j=1,6)
5844         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5845 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5846       enddo
5847 ! 6/20/98 - dihedral angle constraints
5848       edihcnstr=0.0d0
5849 c      do i=1,ndih_constr
5850       do i=idihconstr_start,idihconstr_end
5851         itori=idih_constr(i)
5852         phii=phi(itori)
5853         difi=pinorm(phii-phi0(i))
5854         if (difi.gt.drange(i)) then
5855           difi=difi-drange(i)
5856           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5857           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5858         else if (difi.lt.-drange(i)) then
5859           difi=difi+drange(i)
5860           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5861           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5862         else
5863           difi=0.0
5864         endif
5865 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5866 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5867 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5868       enddo
5869 cd       write (iout,*) 'edihcnstr',edihcnstr
5870       return
5871       end
5872 c----------------------------------------------------------------------------
5873       subroutine etor_d(etors_d)
5874 C 6/23/01 Compute double torsional energy
5875       implicit real*8 (a-h,o-z)
5876       include 'DIMENSIONS'
5877       include 'COMMON.VAR'
5878       include 'COMMON.GEO'
5879       include 'COMMON.LOCAL'
5880       include 'COMMON.TORSION'
5881       include 'COMMON.INTERACT'
5882       include 'COMMON.DERIV'
5883       include 'COMMON.CHAIN'
5884       include 'COMMON.NAMES'
5885       include 'COMMON.IOUNITS'
5886       include 'COMMON.FFIELD'
5887       include 'COMMON.TORCNSTR'
5888       logical lprn
5889 C Set lprn=.true. for debugging
5890       lprn=.false.
5891 c     lprn=.true.
5892       etors_d=0.0D0
5893 c      write(iout,*) "a tu??"
5894       do i=iphid_start,iphid_end
5895         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5896      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5897         itori=itortyp(itype(i-2))
5898         itori1=itortyp(itype(i-1))
5899         itori2=itortyp(itype(i))
5900         phii=phi(i)
5901         phii1=phi(i+1)
5902         gloci1=0.0D0
5903         gloci2=0.0D0
5904         iblock=1
5905         if (iabs(itype(i+1)).eq.20) iblock=2
5906
5907 C Regular cosine and sine terms
5908         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5909           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5910           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5911           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5912           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5913           cosphi1=dcos(j*phii)
5914           sinphi1=dsin(j*phii)
5915           cosphi2=dcos(j*phii1)
5916           sinphi2=dsin(j*phii1)
5917           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5918      &     v2cij*cosphi2+v2sij*sinphi2
5919           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5920           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5921         enddo
5922         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5923           do l=1,k-1
5924             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5925             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5926             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5927             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5928             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5929             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5930             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5931             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5932             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5933      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5934             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5935      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5936             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5937      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5938           enddo
5939         enddo
5940         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5941         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5942       enddo
5943       return
5944       end
5945 #endif
5946 c------------------------------------------------------------------------------
5947       subroutine eback_sc_corr(esccor)
5948 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5949 c        conformational states; temporarily implemented as differences
5950 c        between UNRES torsional potentials (dependent on three types of
5951 c        residues) and the torsional potentials dependent on all 20 types
5952 c        of residues computed from AM1  energy surfaces of terminally-blocked
5953 c        amino-acid residues.
5954       implicit real*8 (a-h,o-z)
5955       include 'DIMENSIONS'
5956       include 'COMMON.VAR'
5957       include 'COMMON.GEO'
5958       include 'COMMON.LOCAL'
5959       include 'COMMON.TORSION'
5960       include 'COMMON.SCCOR'
5961       include 'COMMON.INTERACT'
5962       include 'COMMON.DERIV'
5963       include 'COMMON.CHAIN'
5964       include 'COMMON.NAMES'
5965       include 'COMMON.IOUNITS'
5966       include 'COMMON.FFIELD'
5967       include 'COMMON.CONTROL'
5968       logical lprn
5969 C Set lprn=.true. for debugging
5970       lprn=.false.
5971 c      lprn=.true.
5972 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5973       esccor=0.0D0
5974       do i=itau_start,itau_end
5975         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5976         esccor_ii=0.0D0
5977         isccori=isccortyp(itype(i-2))
5978         isccori1=isccortyp(itype(i-1))
5979 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5980         phii=phi(i)
5981         do intertyp=1,3 !intertyp
5982 cc Added 09 May 2012 (Adasko)
5983 cc  Intertyp means interaction type of backbone mainchain correlation:
5984 c   1 = SC...Ca...Ca...Ca
5985 c   2 = Ca...Ca...Ca...SC
5986 c   3 = SC...Ca...Ca...SCi
5987         gloci=0.0D0
5988         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5989      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5990      &      (itype(i-1).eq.ntyp1)))
5991      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5992      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5993      &     .or.(itype(i).eq.ntyp1)))
5994      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5995      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5996      &      (itype(i-3).eq.ntyp1)))) cycle
5997         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5998         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5999      & cycle
6000        do j=1,nterm_sccor(isccori,isccori1)
6001           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6002           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6003           cosphi=dcos(j*tauangle(intertyp,i))
6004           sinphi=dsin(j*tauangle(intertyp,i))
6005           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6006           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6007         enddo
6008 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6009         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6010         if (lprn)
6011      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6012      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6013      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6014      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6015         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6016        enddo !intertyp
6017       enddo
6018
6019       return
6020       end
6021 c----------------------------------------------------------------------------
6022       subroutine multibody(ecorr)
6023 C This subroutine calculates multi-body contributions to energy following
6024 C the idea of Skolnick et al. If side chains I and J make a contact and
6025 C at the same time side chains I+1 and J+1 make a contact, an extra
6026 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6027       implicit real*8 (a-h,o-z)
6028       include 'DIMENSIONS'
6029       include 'COMMON.IOUNITS'
6030       include 'COMMON.DERIV'
6031       include 'COMMON.INTERACT'
6032       include 'COMMON.CONTACTS'
6033       double precision gx(3),gx1(3)
6034       logical lprn
6035
6036 C Set lprn=.true. for debugging
6037       lprn=.false.
6038
6039       if (lprn) then
6040         write (iout,'(a)') 'Contact function values:'
6041         do i=nnt,nct-2
6042           write (iout,'(i2,20(1x,i2,f10.5))')
6043      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6044         enddo
6045       endif
6046       ecorr=0.0D0
6047       do i=nnt,nct
6048         do j=1,3
6049           gradcorr(j,i)=0.0D0
6050           gradxorr(j,i)=0.0D0
6051         enddo
6052       enddo
6053       do i=nnt,nct-2
6054
6055         DO ISHIFT = 3,4
6056
6057         i1=i+ishift
6058         num_conti=num_cont(i)
6059         num_conti1=num_cont(i1)
6060         do jj=1,num_conti
6061           j=jcont(jj,i)
6062           do kk=1,num_conti1
6063             j1=jcont(kk,i1)
6064             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6065 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6066 cd   &                   ' ishift=',ishift
6067 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6068 C The system gains extra energy.
6069               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6070             endif   ! j1==j+-ishift
6071           enddo     ! kk
6072         enddo       ! jj
6073
6074         ENDDO ! ISHIFT
6075
6076       enddo         ! i
6077       return
6078       end
6079 c------------------------------------------------------------------------------
6080       double precision function esccorr(i,j,k,l,jj,kk)
6081       implicit real*8 (a-h,o-z)
6082       include 'DIMENSIONS'
6083       include 'COMMON.IOUNITS'
6084       include 'COMMON.DERIV'
6085       include 'COMMON.INTERACT'
6086       include 'COMMON.CONTACTS'
6087       double precision gx(3),gx1(3)
6088       logical lprn
6089       lprn=.false.
6090       eij=facont(jj,i)
6091       ekl=facont(kk,k)
6092 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6093 C Calculate the multi-body contribution to energy.
6094 C Calculate multi-body contributions to the gradient.
6095 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6096 cd   & k,l,(gacont(m,kk,k),m=1,3)
6097       do m=1,3
6098         gx(m) =ekl*gacont(m,jj,i)
6099         gx1(m)=eij*gacont(m,kk,k)
6100         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6101         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6102         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6103         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6104       enddo
6105       do m=i,j-1
6106         do ll=1,3
6107           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6108         enddo
6109       enddo
6110       do m=k,l-1
6111         do ll=1,3
6112           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6113         enddo
6114       enddo
6115       esccorr=-eij*ekl
6116       return
6117       end
6118 c------------------------------------------------------------------------------
6119       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6120 C This subroutine calculates multi-body contributions to hydrogen-bonding
6121       implicit real*8 (a-h,o-z)
6122       include 'DIMENSIONS'
6123       include 'COMMON.IOUNITS'
6124 #ifdef MPI
6125       include "mpif.h"
6126       parameter (max_cont=maxconts)
6127       parameter (max_dim=26)
6128       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6129       double precision zapas(max_dim,maxconts,max_fg_procs),
6130      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6131       common /przechowalnia/ zapas
6132       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6133      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6134 #endif
6135       include 'COMMON.SETUP'
6136       include 'COMMON.FFIELD'
6137       include 'COMMON.DERIV'
6138       include 'COMMON.INTERACT'
6139       include 'COMMON.CONTACTS'
6140       include 'COMMON.CONTROL'
6141       include 'COMMON.LOCAL'
6142       double precision gx(3),gx1(3),time00
6143       logical lprn,ldone
6144
6145 C Set lprn=.true. for debugging
6146       lprn=.false.
6147 #ifdef MPI
6148       n_corr=0
6149       n_corr1=0
6150       if (nfgtasks.le.1) goto 30
6151       if (lprn) then
6152         write (iout,'(a)') 'Contact function values before RECEIVE:'
6153         do i=nnt,nct-2
6154           write (iout,'(2i3,50(1x,i2,f5.2))')
6155      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6156      &    j=1,num_cont_hb(i))
6157         enddo
6158       endif
6159       call flush(iout)
6160       do i=1,ntask_cont_from
6161         ncont_recv(i)=0
6162       enddo
6163       do i=1,ntask_cont_to
6164         ncont_sent(i)=0
6165       enddo
6166 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6167 c     & ntask_cont_to
6168 C Make the list of contacts to send to send to other procesors
6169 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6170 c      call flush(iout)
6171       do i=iturn3_start,iturn3_end
6172 c        write (iout,*) "make contact list turn3",i," num_cont",
6173 c     &    num_cont_hb(i)
6174         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6175       enddo
6176       do i=iturn4_start,iturn4_end
6177 c        write (iout,*) "make contact list turn4",i," num_cont",
6178 c     &   num_cont_hb(i)
6179         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6180       enddo
6181       do ii=1,nat_sent
6182         i=iat_sent(ii)
6183 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6184 c     &    num_cont_hb(i)
6185         do j=1,num_cont_hb(i)
6186         do k=1,4
6187           jjc=jcont_hb(j,i)
6188           iproc=iint_sent_local(k,jjc,ii)
6189 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6190           if (iproc.gt.0) then
6191             ncont_sent(iproc)=ncont_sent(iproc)+1
6192             nn=ncont_sent(iproc)
6193             zapas(1,nn,iproc)=i
6194             zapas(2,nn,iproc)=jjc
6195             zapas(3,nn,iproc)=facont_hb(j,i)
6196             zapas(4,nn,iproc)=ees0p(j,i)
6197             zapas(5,nn,iproc)=ees0m(j,i)
6198             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6199             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6200             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6201             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6202             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6203             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6204             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6205             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6206             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6207             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6208             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6209             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6210             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6211             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6212             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6213             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6214             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6215             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6216             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6217             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6218             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6219           endif
6220         enddo
6221         enddo
6222       enddo
6223       if (lprn) then
6224       write (iout,*)
6225      &  "Numbers of contacts to be sent to other processors",
6226      &  (ncont_sent(i),i=1,ntask_cont_to)
6227       write (iout,*) "Contacts sent"
6228       do ii=1,ntask_cont_to
6229         nn=ncont_sent(ii)
6230         iproc=itask_cont_to(ii)
6231         write (iout,*) nn," contacts to processor",iproc,
6232      &   " of CONT_TO_COMM group"
6233         do i=1,nn
6234           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6235         enddo
6236       enddo
6237       call flush(iout)
6238       endif
6239       CorrelType=477
6240       CorrelID=fg_rank+1
6241       CorrelType1=478
6242       CorrelID1=nfgtasks+fg_rank+1
6243       ireq=0
6244 C Receive the numbers of needed contacts from other processors
6245       do ii=1,ntask_cont_from
6246         iproc=itask_cont_from(ii)
6247         ireq=ireq+1
6248         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6249      &    FG_COMM,req(ireq),IERR)
6250       enddo
6251 c      write (iout,*) "IRECV ended"
6252 c      call flush(iout)
6253 C Send the number of contacts needed by other processors
6254       do ii=1,ntask_cont_to
6255         iproc=itask_cont_to(ii)
6256         ireq=ireq+1
6257         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6258      &    FG_COMM,req(ireq),IERR)
6259       enddo
6260 c      write (iout,*) "ISEND ended"
6261 c      write (iout,*) "number of requests (nn)",ireq
6262       call flush(iout)
6263       if (ireq.gt.0)
6264      &  call MPI_Waitall(ireq,req,status_array,ierr)
6265 c      write (iout,*)
6266 c     &  "Numbers of contacts to be received from other processors",
6267 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6268 c      call flush(iout)
6269 C Receive contacts
6270       ireq=0
6271       do ii=1,ntask_cont_from
6272         iproc=itask_cont_from(ii)
6273         nn=ncont_recv(ii)
6274 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6275 c     &   " of CONT_TO_COMM group"
6276         call flush(iout)
6277         if (nn.gt.0) then
6278           ireq=ireq+1
6279           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6280      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6281 c          write (iout,*) "ireq,req",ireq,req(ireq)
6282         endif
6283       enddo
6284 C Send the contacts to processors that need them
6285       do ii=1,ntask_cont_to
6286         iproc=itask_cont_to(ii)
6287         nn=ncont_sent(ii)
6288 c        write (iout,*) nn," contacts to processor",iproc,
6289 c     &   " of CONT_TO_COMM group"
6290         if (nn.gt.0) then
6291           ireq=ireq+1
6292           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6293      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6294 c          write (iout,*) "ireq,req",ireq,req(ireq)
6295 c          do i=1,nn
6296 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6297 c          enddo
6298         endif
6299       enddo
6300 c      write (iout,*) "number of requests (contacts)",ireq
6301 c      write (iout,*) "req",(req(i),i=1,4)
6302 c      call flush(iout)
6303       if (ireq.gt.0)
6304      & call MPI_Waitall(ireq,req,status_array,ierr)
6305       do iii=1,ntask_cont_from
6306         iproc=itask_cont_from(iii)
6307         nn=ncont_recv(iii)
6308         if (lprn) then
6309         write (iout,*) "Received",nn," contacts from processor",iproc,
6310      &   " of CONT_FROM_COMM group"
6311         call flush(iout)
6312         do i=1,nn
6313           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6314         enddo
6315         call flush(iout)
6316         endif
6317         do i=1,nn
6318           ii=zapas_recv(1,i,iii)
6319 c Flag the received contacts to prevent double-counting
6320           jj=-zapas_recv(2,i,iii)
6321 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6322 c          call flush(iout)
6323           nnn=num_cont_hb(ii)+1
6324           num_cont_hb(ii)=nnn
6325           jcont_hb(nnn,ii)=jj
6326           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6327           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6328           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6329           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6330           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6331           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6332           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6333           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6334           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6335           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6336           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6337           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6338           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6339           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6340           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6341           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6342           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6343           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6344           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6345           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6346           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6347           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6348           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6349           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6350         enddo
6351       enddo
6352       call flush(iout)
6353       if (lprn) then
6354         write (iout,'(a)') 'Contact function values after receive:'
6355         do i=nnt,nct-2
6356           write (iout,'(2i3,50(1x,i3,f5.2))')
6357      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6358      &    j=1,num_cont_hb(i))
6359         enddo
6360         call flush(iout)
6361       endif
6362    30 continue
6363 #endif
6364       if (lprn) then
6365         write (iout,'(a)') 'Contact function values:'
6366         do i=nnt,nct-2
6367           write (iout,'(2i3,50(1x,i3,f5.2))')
6368      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6369      &    j=1,num_cont_hb(i))
6370         enddo
6371       endif
6372       ecorr=0.0D0
6373 C Remove the loop below after debugging !!!
6374       do i=nnt,nct
6375         do j=1,3
6376           gradcorr(j,i)=0.0D0
6377           gradxorr(j,i)=0.0D0
6378         enddo
6379       enddo
6380 C Calculate the local-electrostatic correlation terms
6381       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6382         i1=i+1
6383         num_conti=num_cont_hb(i)
6384         num_conti1=num_cont_hb(i+1)
6385         do jj=1,num_conti
6386           j=jcont_hb(jj,i)
6387           jp=iabs(j)
6388           do kk=1,num_conti1
6389             j1=jcont_hb(kk,i1)
6390             jp1=iabs(j1)
6391 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6392 c     &         ' jj=',jj,' kk=',kk
6393             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6394      &          .or. j.lt.0 .and. j1.gt.0) .and.
6395      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6396 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6397 C The system gains extra energy.
6398               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6399               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6400      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6401               n_corr=n_corr+1
6402             else if (j1.eq.j) then
6403 C Contacts I-J and I-(J+1) occur simultaneously.
6404 C The system loses extra energy.
6405 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6406             endif
6407           enddo ! kk
6408           do kk=1,num_conti
6409             j1=jcont_hb(kk,i)
6410 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6411 c    &         ' jj=',jj,' kk=',kk
6412             if (j1.eq.j+1) then
6413 C Contacts I-J and (I+1)-J occur simultaneously.
6414 C The system loses extra energy.
6415 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6416             endif ! j1==j+1
6417           enddo ! kk
6418         enddo ! jj
6419       enddo ! i
6420       return
6421       end
6422 c------------------------------------------------------------------------------
6423       subroutine add_hb_contact(ii,jj,itask)
6424       implicit real*8 (a-h,o-z)
6425       include "DIMENSIONS"
6426       include "COMMON.IOUNITS"
6427       integer max_cont
6428       integer max_dim
6429       parameter (max_cont=maxconts)
6430       parameter (max_dim=26)
6431       include "COMMON.CONTACTS"
6432       double precision zapas(max_dim,maxconts,max_fg_procs),
6433      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6434       common /przechowalnia/ zapas
6435       integer i,j,ii,jj,iproc,itask(4),nn
6436 c      write (iout,*) "itask",itask
6437       do i=1,2
6438         iproc=itask(i)
6439         if (iproc.gt.0) then
6440           do j=1,num_cont_hb(ii)
6441             jjc=jcont_hb(j,ii)
6442 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6443             if (jjc.eq.jj) then
6444               ncont_sent(iproc)=ncont_sent(iproc)+1
6445               nn=ncont_sent(iproc)
6446               zapas(1,nn,iproc)=ii
6447               zapas(2,nn,iproc)=jjc
6448               zapas(3,nn,iproc)=facont_hb(j,ii)
6449               zapas(4,nn,iproc)=ees0p(j,ii)
6450               zapas(5,nn,iproc)=ees0m(j,ii)
6451               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6452               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6453               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6454               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6455               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6456               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6457               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6458               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6459               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6460               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6461               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6462               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6463               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6464               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6465               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6466               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6467               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6468               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6469               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6470               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6471               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6472               exit
6473             endif
6474           enddo
6475         endif
6476       enddo
6477       return
6478       end
6479 c------------------------------------------------------------------------------
6480       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6481      &  n_corr1)
6482 C This subroutine calculates multi-body contributions to hydrogen-bonding
6483       implicit real*8 (a-h,o-z)
6484       include 'DIMENSIONS'
6485       include 'COMMON.IOUNITS'
6486 #ifdef MPI
6487       include "mpif.h"
6488       parameter (max_cont=maxconts)
6489       parameter (max_dim=70)
6490       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6491       double precision zapas(max_dim,maxconts,max_fg_procs),
6492      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6493       common /przechowalnia/ zapas
6494       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6495      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6496 #endif
6497       include 'COMMON.SETUP'
6498       include 'COMMON.FFIELD'
6499       include 'COMMON.DERIV'
6500       include 'COMMON.LOCAL'
6501       include 'COMMON.INTERACT'
6502       include 'COMMON.CONTACTS'
6503       include 'COMMON.CHAIN'
6504       include 'COMMON.CONTROL'
6505       double precision gx(3),gx1(3)
6506       integer num_cont_hb_old(maxres)
6507       logical lprn,ldone
6508       double precision eello4,eello5,eelo6,eello_turn6
6509       external eello4,eello5,eello6,eello_turn6
6510 C Set lprn=.true. for debugging
6511       lprn=.false.
6512       eturn6=0.0d0
6513 #ifdef MPI
6514       do i=1,nres
6515         num_cont_hb_old(i)=num_cont_hb(i)
6516       enddo
6517       n_corr=0
6518       n_corr1=0
6519       if (nfgtasks.le.1) goto 30
6520       if (lprn) then
6521         write (iout,'(a)') 'Contact function values before RECEIVE:'
6522         do i=nnt,nct-2
6523           write (iout,'(2i3,50(1x,i2,f5.2))')
6524      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6525      &    j=1,num_cont_hb(i))
6526         enddo
6527       endif
6528       call flush(iout)
6529       do i=1,ntask_cont_from
6530         ncont_recv(i)=0
6531       enddo
6532       do i=1,ntask_cont_to
6533         ncont_sent(i)=0
6534       enddo
6535 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6536 c     & ntask_cont_to
6537 C Make the list of contacts to send to send to other procesors
6538       do i=iturn3_start,iturn3_end
6539 c        write (iout,*) "make contact list turn3",i," num_cont",
6540 c     &    num_cont_hb(i)
6541         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6542       enddo
6543       do i=iturn4_start,iturn4_end
6544 c        write (iout,*) "make contact list turn4",i," num_cont",
6545 c     &   num_cont_hb(i)
6546         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6547       enddo
6548       do ii=1,nat_sent
6549         i=iat_sent(ii)
6550 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6551 c     &    num_cont_hb(i)
6552         do j=1,num_cont_hb(i)
6553         do k=1,4
6554           jjc=jcont_hb(j,i)
6555           iproc=iint_sent_local(k,jjc,ii)
6556 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6557           if (iproc.ne.0) then
6558             ncont_sent(iproc)=ncont_sent(iproc)+1
6559             nn=ncont_sent(iproc)
6560             zapas(1,nn,iproc)=i
6561             zapas(2,nn,iproc)=jjc
6562             zapas(3,nn,iproc)=d_cont(j,i)
6563             ind=3
6564             do kk=1,3
6565               ind=ind+1
6566               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6567             enddo
6568             do kk=1,2
6569               do ll=1,2
6570                 ind=ind+1
6571                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6572               enddo
6573             enddo
6574             do jj=1,5
6575               do kk=1,3
6576                 do ll=1,2
6577                   do mm=1,2
6578                     ind=ind+1
6579                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6580                   enddo
6581                 enddo
6582               enddo
6583             enddo
6584           endif
6585         enddo
6586         enddo
6587       enddo
6588       if (lprn) then
6589       write (iout,*)
6590      &  "Numbers of contacts to be sent to other processors",
6591      &  (ncont_sent(i),i=1,ntask_cont_to)
6592       write (iout,*) "Contacts sent"
6593       do ii=1,ntask_cont_to
6594         nn=ncont_sent(ii)
6595         iproc=itask_cont_to(ii)
6596         write (iout,*) nn," contacts to processor",iproc,
6597      &   " of CONT_TO_COMM group"
6598         do i=1,nn
6599           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6600         enddo
6601       enddo
6602       call flush(iout)
6603       endif
6604       CorrelType=477
6605       CorrelID=fg_rank+1
6606       CorrelType1=478
6607       CorrelID1=nfgtasks+fg_rank+1
6608       ireq=0
6609 C Receive the numbers of needed contacts from other processors
6610       do ii=1,ntask_cont_from
6611         iproc=itask_cont_from(ii)
6612         ireq=ireq+1
6613         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6614      &    FG_COMM,req(ireq),IERR)
6615       enddo
6616 c      write (iout,*) "IRECV ended"
6617 c      call flush(iout)
6618 C Send the number of contacts needed by other processors
6619       do ii=1,ntask_cont_to
6620         iproc=itask_cont_to(ii)
6621         ireq=ireq+1
6622         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6623      &    FG_COMM,req(ireq),IERR)
6624       enddo
6625 c      write (iout,*) "ISEND ended"
6626 c      write (iout,*) "number of requests (nn)",ireq
6627       call flush(iout)
6628       if (ireq.gt.0)
6629      &  call MPI_Waitall(ireq,req,status_array,ierr)
6630 c      write (iout,*)
6631 c     &  "Numbers of contacts to be received from other processors",
6632 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6633 c      call flush(iout)
6634 C Receive contacts
6635       ireq=0
6636       do ii=1,ntask_cont_from
6637         iproc=itask_cont_from(ii)
6638         nn=ncont_recv(ii)
6639 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6640 c     &   " of CONT_TO_COMM group"
6641         call flush(iout)
6642         if (nn.gt.0) then
6643           ireq=ireq+1
6644           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6645      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6646 c          write (iout,*) "ireq,req",ireq,req(ireq)
6647         endif
6648       enddo
6649 C Send the contacts to processors that need them
6650       do ii=1,ntask_cont_to
6651         iproc=itask_cont_to(ii)
6652         nn=ncont_sent(ii)
6653 c        write (iout,*) nn," contacts to processor",iproc,
6654 c     &   " of CONT_TO_COMM group"
6655         if (nn.gt.0) then
6656           ireq=ireq+1
6657           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6658      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6659 c          write (iout,*) "ireq,req",ireq,req(ireq)
6660 c          do i=1,nn
6661 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6662 c          enddo
6663         endif
6664       enddo
6665 c      write (iout,*) "number of requests (contacts)",ireq
6666 c      write (iout,*) "req",(req(i),i=1,4)
6667 c      call flush(iout)
6668       if (ireq.gt.0)
6669      & call MPI_Waitall(ireq,req,status_array,ierr)
6670       do iii=1,ntask_cont_from
6671         iproc=itask_cont_from(iii)
6672         nn=ncont_recv(iii)
6673         if (lprn) then
6674         write (iout,*) "Received",nn," contacts from processor",iproc,
6675      &   " of CONT_FROM_COMM group"
6676         call flush(iout)
6677         do i=1,nn
6678           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6679         enddo
6680         call flush(iout)
6681         endif
6682         do i=1,nn
6683           ii=zapas_recv(1,i,iii)
6684 c Flag the received contacts to prevent double-counting
6685           jj=-zapas_recv(2,i,iii)
6686 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6687 c          call flush(iout)
6688           nnn=num_cont_hb(ii)+1
6689           num_cont_hb(ii)=nnn
6690           jcont_hb(nnn,ii)=jj
6691           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6692           ind=3
6693           do kk=1,3
6694             ind=ind+1
6695             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6696           enddo
6697           do kk=1,2
6698             do ll=1,2
6699               ind=ind+1
6700               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6701             enddo
6702           enddo
6703           do jj=1,5
6704             do kk=1,3
6705               do ll=1,2
6706                 do mm=1,2
6707                   ind=ind+1
6708                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6709                 enddo
6710               enddo
6711             enddo
6712           enddo
6713         enddo
6714       enddo
6715       call flush(iout)
6716       if (lprn) then
6717         write (iout,'(a)') 'Contact function values after receive:'
6718         do i=nnt,nct-2
6719           write (iout,'(2i3,50(1x,i3,5f6.3))')
6720      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6721      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6722         enddo
6723         call flush(iout)
6724       endif
6725    30 continue
6726 #endif
6727       if (lprn) then
6728         write (iout,'(a)') 'Contact function values:'
6729         do i=nnt,nct-2
6730           write (iout,'(2i3,50(1x,i2,5f6.3))')
6731      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6732      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6733         enddo
6734       endif
6735       ecorr=0.0D0
6736       ecorr5=0.0d0
6737       ecorr6=0.0d0
6738 C Remove the loop below after debugging !!!
6739       do i=nnt,nct
6740         do j=1,3
6741           gradcorr(j,i)=0.0D0
6742           gradxorr(j,i)=0.0D0
6743         enddo
6744       enddo
6745 C Calculate the dipole-dipole interaction energies
6746       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6747       do i=iatel_s,iatel_e+1
6748         num_conti=num_cont_hb(i)
6749         do jj=1,num_conti
6750           j=jcont_hb(jj,i)
6751 #ifdef MOMENT
6752           call dipole(i,j,jj)
6753 #endif
6754         enddo
6755       enddo
6756       endif
6757 C Calculate the local-electrostatic correlation terms
6758 c                write (iout,*) "gradcorr5 in eello5 before loop"
6759 c                do iii=1,nres
6760 c                  write (iout,'(i5,3f10.5)')
6761 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6762 c                enddo
6763       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6764 c        write (iout,*) "corr loop i",i
6765         i1=i+1
6766         num_conti=num_cont_hb(i)
6767         num_conti1=num_cont_hb(i+1)
6768         do jj=1,num_conti
6769           j=jcont_hb(jj,i)
6770           jp=iabs(j)
6771           do kk=1,num_conti1
6772             j1=jcont_hb(kk,i1)
6773             jp1=iabs(j1)
6774 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6775 c     &         ' jj=',jj,' kk=',kk
6776 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6777             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6778      &          .or. j.lt.0 .and. j1.gt.0) .and.
6779      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6780 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6781 C The system gains extra energy.
6782               n_corr=n_corr+1
6783               sqd1=dsqrt(d_cont(jj,i))
6784               sqd2=dsqrt(d_cont(kk,i1))
6785               sred_geom = sqd1*sqd2
6786               IF (sred_geom.lt.cutoff_corr) THEN
6787                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6788      &            ekont,fprimcont)
6789 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6790 cd     &         ' jj=',jj,' kk=',kk
6791                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6792                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6793                 do l=1,3
6794                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6795                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6796                 enddo
6797                 n_corr1=n_corr1+1
6798 cd               write (iout,*) 'sred_geom=',sred_geom,
6799 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6800 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6801 cd               write (iout,*) "g_contij",g_contij
6802 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6803 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6804                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6805                 if (wcorr4.gt.0.0d0)
6806      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6807                   if (energy_dec.and.wcorr4.gt.0.0d0)
6808      1                 write (iout,'(a6,4i5,0pf7.3)')
6809      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6810 c                write (iout,*) "gradcorr5 before eello5"
6811 c                do iii=1,nres
6812 c                  write (iout,'(i5,3f10.5)')
6813 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6814 c                enddo
6815                 if (wcorr5.gt.0.0d0)
6816      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6817 c                write (iout,*) "gradcorr5 after eello5"
6818 c                do iii=1,nres
6819 c                  write (iout,'(i5,3f10.5)')
6820 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6821 c                enddo
6822                   if (energy_dec.and.wcorr5.gt.0.0d0)
6823      1                 write (iout,'(a6,4i5,0pf7.3)')
6824      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6825 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6826 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6827                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6828      &               .or. wturn6.eq.0.0d0))then
6829 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6830                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6831                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6832      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6833 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6834 cd     &            'ecorr6=',ecorr6
6835 cd                write (iout,'(4e15.5)') sred_geom,
6836 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6837 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6838 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6839                 else if (wturn6.gt.0.0d0
6840      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6841 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6842                   eturn6=eturn6+eello_turn6(i,jj,kk)
6843                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6844      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6845 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6846                 endif
6847               ENDIF
6848 1111          continue
6849             endif
6850           enddo ! kk
6851         enddo ! jj
6852       enddo ! i
6853       do i=1,nres
6854         num_cont_hb(i)=num_cont_hb_old(i)
6855       enddo
6856 c                write (iout,*) "gradcorr5 in eello5"
6857 c                do iii=1,nres
6858 c                  write (iout,'(i5,3f10.5)')
6859 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6860 c                enddo
6861       return
6862       end
6863 c------------------------------------------------------------------------------
6864       subroutine add_hb_contact_eello(ii,jj,itask)
6865       implicit real*8 (a-h,o-z)
6866       include "DIMENSIONS"
6867       include "COMMON.IOUNITS"
6868       integer max_cont
6869       integer max_dim
6870       parameter (max_cont=maxconts)
6871       parameter (max_dim=70)
6872       include "COMMON.CONTACTS"
6873       double precision zapas(max_dim,maxconts,max_fg_procs),
6874      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6875       common /przechowalnia/ zapas
6876       integer i,j,ii,jj,iproc,itask(4),nn
6877 c      write (iout,*) "itask",itask
6878       do i=1,2
6879         iproc=itask(i)
6880         if (iproc.gt.0) then
6881           do j=1,num_cont_hb(ii)
6882             jjc=jcont_hb(j,ii)
6883 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6884             if (jjc.eq.jj) then
6885               ncont_sent(iproc)=ncont_sent(iproc)+1
6886               nn=ncont_sent(iproc)
6887               zapas(1,nn,iproc)=ii
6888               zapas(2,nn,iproc)=jjc
6889               zapas(3,nn,iproc)=d_cont(j,ii)
6890               ind=3
6891               do kk=1,3
6892                 ind=ind+1
6893                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6894               enddo
6895               do kk=1,2
6896                 do ll=1,2
6897                   ind=ind+1
6898                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6899                 enddo
6900               enddo
6901               do jj=1,5
6902                 do kk=1,3
6903                   do ll=1,2
6904                     do mm=1,2
6905                       ind=ind+1
6906                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6907                     enddo
6908                   enddo
6909                 enddo
6910               enddo
6911               exit
6912             endif
6913           enddo
6914         endif
6915       enddo
6916       return
6917       end
6918 c------------------------------------------------------------------------------
6919       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6920       implicit real*8 (a-h,o-z)
6921       include 'DIMENSIONS'
6922       include 'COMMON.IOUNITS'
6923       include 'COMMON.DERIV'
6924       include 'COMMON.INTERACT'
6925       include 'COMMON.CONTACTS'
6926       double precision gx(3),gx1(3)
6927       logical lprn
6928       lprn=.false.
6929       eij=facont_hb(jj,i)
6930       ekl=facont_hb(kk,k)
6931       ees0pij=ees0p(jj,i)
6932       ees0pkl=ees0p(kk,k)
6933       ees0mij=ees0m(jj,i)
6934       ees0mkl=ees0m(kk,k)
6935       ekont=eij*ekl
6936       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6937 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6938 C Following 4 lines for diagnostics.
6939 cd    ees0pkl=0.0D0
6940 cd    ees0pij=1.0D0
6941 cd    ees0mkl=0.0D0
6942 cd    ees0mij=1.0D0
6943 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6944 c     & 'Contacts ',i,j,
6945 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6946 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6947 c     & 'gradcorr_long'
6948 C Calculate the multi-body contribution to energy.
6949 c      ecorr=ecorr+ekont*ees
6950 C Calculate multi-body contributions to the gradient.
6951       coeffpees0pij=coeffp*ees0pij
6952       coeffmees0mij=coeffm*ees0mij
6953       coeffpees0pkl=coeffp*ees0pkl
6954       coeffmees0mkl=coeffm*ees0mkl
6955       do ll=1,3
6956 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6957         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6958      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6959      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6960         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6961      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6962      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6963 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6964         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6965      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6966      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6967         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6968      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6969      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6970         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6971      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6972      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6973         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6974         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6975         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6976      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6977      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6978         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6979         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6980 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6981       enddo
6982 c      write (iout,*)
6983 cgrad      do m=i+1,j-1
6984 cgrad        do ll=1,3
6985 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6986 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6987 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6988 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6989 cgrad        enddo
6990 cgrad      enddo
6991 cgrad      do m=k+1,l-1
6992 cgrad        do ll=1,3
6993 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6994 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6995 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6996 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6997 cgrad        enddo
6998 cgrad      enddo
6999 c      write (iout,*) "ehbcorr",ekont*ees
7000       ehbcorr=ekont*ees
7001       return
7002       end
7003 #ifdef MOMENT
7004 C---------------------------------------------------------------------------
7005       subroutine dipole(i,j,jj)
7006       implicit real*8 (a-h,o-z)
7007       include 'DIMENSIONS'
7008       include 'COMMON.IOUNITS'
7009       include 'COMMON.CHAIN'
7010       include 'COMMON.FFIELD'
7011       include 'COMMON.DERIV'
7012       include 'COMMON.INTERACT'
7013       include 'COMMON.CONTACTS'
7014       include 'COMMON.TORSION'
7015       include 'COMMON.VAR'
7016       include 'COMMON.GEO'
7017       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7018      &  auxmat(2,2)
7019       iti1 = itortyp(itype(i+1))
7020       if (j.lt.nres-1) then
7021         itj1 = itortyp(itype(j+1))
7022       else
7023         itj1=ntortyp+1
7024       endif
7025       do iii=1,2
7026         dipi(iii,1)=Ub2(iii,i)
7027         dipderi(iii)=Ub2der(iii,i)
7028         dipi(iii,2)=b1(iii,i+1)
7029         dipj(iii,1)=Ub2(iii,j)
7030         dipderj(iii)=Ub2der(iii,j)
7031         dipj(iii,2)=b1(iii,j+1)
7032       enddo
7033       kkk=0
7034       do iii=1,2
7035         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7036         do jjj=1,2
7037           kkk=kkk+1
7038           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7039         enddo
7040       enddo
7041       do kkk=1,5
7042         do lll=1,3
7043           mmm=0
7044           do iii=1,2
7045             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7046      &        auxvec(1))
7047             do jjj=1,2
7048               mmm=mmm+1
7049               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7050             enddo
7051           enddo
7052         enddo
7053       enddo
7054       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7055       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7056       do iii=1,2
7057         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7058       enddo
7059       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7060       do iii=1,2
7061         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7062       enddo
7063       return
7064       end
7065 #endif
7066 C---------------------------------------------------------------------------
7067       subroutine calc_eello(i,j,k,l,jj,kk)
7068 C
7069 C This subroutine computes matrices and vectors needed to calculate
7070 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7071 C
7072       implicit real*8 (a-h,o-z)
7073       include 'DIMENSIONS'
7074       include 'COMMON.IOUNITS'
7075       include 'COMMON.CHAIN'
7076       include 'COMMON.DERIV'
7077       include 'COMMON.INTERACT'
7078       include 'COMMON.CONTACTS'
7079       include 'COMMON.TORSION'
7080       include 'COMMON.VAR'
7081       include 'COMMON.GEO'
7082       include 'COMMON.FFIELD'
7083       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7084      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7085       logical lprn
7086       common /kutas/ lprn
7087 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7088 cd     & ' jj=',jj,' kk=',kk
7089 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7090 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7091 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7092       do iii=1,2
7093         do jjj=1,2
7094           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7095           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7096         enddo
7097       enddo
7098       call transpose2(aa1(1,1),aa1t(1,1))
7099       call transpose2(aa2(1,1),aa2t(1,1))
7100       do kkk=1,5
7101         do lll=1,3
7102           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7103      &      aa1tder(1,1,lll,kkk))
7104           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7105      &      aa2tder(1,1,lll,kkk))
7106         enddo
7107       enddo
7108       if (l.eq.j+1) then
7109 C parallel orientation of the two CA-CA-CA frames.
7110         if (i.gt.1) then
7111           iti=itortyp(itype(i))
7112         else
7113           iti=ntortyp+1
7114         endif
7115         itk1=itortyp(itype(k+1))
7116         itj=itortyp(itype(j))
7117         if (l.lt.nres-1) then
7118           itl1=itortyp(itype(l+1))
7119         else
7120           itl1=ntortyp+1
7121         endif
7122 C A1 kernel(j+1) A2T
7123 cd        do iii=1,2
7124 cd          write (iout,'(3f10.5,5x,3f10.5)')
7125 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7126 cd        enddo
7127         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7128      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7129      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7130 C Following matrices are needed only for 6-th order cumulants
7131         IF (wcorr6.gt.0.0d0) THEN
7132         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7133      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7134      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7135         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7136      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7137      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7138      &   ADtEAderx(1,1,1,1,1,1))
7139         lprn=.false.
7140         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7141      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7142      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7143      &   ADtEA1derx(1,1,1,1,1,1))
7144         ENDIF
7145 C End 6-th order cumulants
7146 cd        lprn=.false.
7147 cd        if (lprn) then
7148 cd        write (2,*) 'In calc_eello6'
7149 cd        do iii=1,2
7150 cd          write (2,*) 'iii=',iii
7151 cd          do kkk=1,5
7152 cd            write (2,*) 'kkk=',kkk
7153 cd            do jjj=1,2
7154 cd              write (2,'(3(2f10.5),5x)')
7155 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7156 cd            enddo
7157 cd          enddo
7158 cd        enddo
7159 cd        endif
7160         call transpose2(EUgder(1,1,k),auxmat(1,1))
7161         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7162         call transpose2(EUg(1,1,k),auxmat(1,1))
7163         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7164         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7165         do iii=1,2
7166           do kkk=1,5
7167             do lll=1,3
7168               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7169      &          EAEAderx(1,1,lll,kkk,iii,1))
7170             enddo
7171           enddo
7172         enddo
7173 C A1T kernel(i+1) A2
7174         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7175      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7176      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7177 C Following matrices are needed only for 6-th order cumulants
7178         IF (wcorr6.gt.0.0d0) THEN
7179         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7180      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7181      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7182         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7183      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7184      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7185      &   ADtEAderx(1,1,1,1,1,2))
7186         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7187      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7188      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7189      &   ADtEA1derx(1,1,1,1,1,2))
7190         ENDIF
7191 C End 6-th order cumulants
7192         call transpose2(EUgder(1,1,l),auxmat(1,1))
7193         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7194         call transpose2(EUg(1,1,l),auxmat(1,1))
7195         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7196         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7197         do iii=1,2
7198           do kkk=1,5
7199             do lll=1,3
7200               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7201      &          EAEAderx(1,1,lll,kkk,iii,2))
7202             enddo
7203           enddo
7204         enddo
7205 C AEAb1 and AEAb2
7206 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7207 C They are needed only when the fifth- or the sixth-order cumulants are
7208 C indluded.
7209         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7210         call transpose2(AEA(1,1,1),auxmat(1,1))
7211         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7212         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7213         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7214         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7215         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7216         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7217         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7218         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7219         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7220         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7221         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7222         call transpose2(AEA(1,1,2),auxmat(1,1))
7223         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7224         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7225         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7226         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7227         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7228         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7229         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7230         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7231         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7232         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7233         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7234 C Calculate the Cartesian derivatives of the vectors.
7235         do iii=1,2
7236           do kkk=1,5
7237             do lll=1,3
7238               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7239               call matvec2(auxmat(1,1),b1(1,i),
7240      &          AEAb1derx(1,lll,kkk,iii,1,1))
7241               call matvec2(auxmat(1,1),Ub2(1,i),
7242      &          AEAb2derx(1,lll,kkk,iii,1,1))
7243               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7244      &          AEAb1derx(1,lll,kkk,iii,2,1))
7245               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7246      &          AEAb2derx(1,lll,kkk,iii,2,1))
7247               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7248               call matvec2(auxmat(1,1),b1(1,j),
7249      &          AEAb1derx(1,lll,kkk,iii,1,2))
7250               call matvec2(auxmat(1,1),Ub2(1,j),
7251      &          AEAb2derx(1,lll,kkk,iii,1,2))
7252               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7253      &          AEAb1derx(1,lll,kkk,iii,2,2))
7254               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7255      &          AEAb2derx(1,lll,kkk,iii,2,2))
7256             enddo
7257           enddo
7258         enddo
7259         ENDIF
7260 C End vectors
7261       else
7262 C Antiparallel orientation of the two CA-CA-CA frames.
7263         if (i.gt.1) then
7264           iti=itortyp(itype(i))
7265         else
7266           iti=ntortyp+1
7267         endif
7268         itk1=itortyp(itype(k+1))
7269         itl=itortyp(itype(l))
7270         itj=itortyp(itype(j))
7271         if (j.lt.nres-1) then
7272           itj1=itortyp(itype(j+1))
7273         else
7274           itj1=ntortyp+1
7275         endif
7276 C A2 kernel(j-1)T A1T
7277         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7278      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7279      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7280 C Following matrices are needed only for 6-th order cumulants
7281         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7282      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7283         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7284      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7285      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7286         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7287      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7288      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7289      &   ADtEAderx(1,1,1,1,1,1))
7290         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7291      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7292      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7293      &   ADtEA1derx(1,1,1,1,1,1))
7294         ENDIF
7295 C End 6-th order cumulants
7296         call transpose2(EUgder(1,1,k),auxmat(1,1))
7297         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7298         call transpose2(EUg(1,1,k),auxmat(1,1))
7299         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7300         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7301         do iii=1,2
7302           do kkk=1,5
7303             do lll=1,3
7304               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7305      &          EAEAderx(1,1,lll,kkk,iii,1))
7306             enddo
7307           enddo
7308         enddo
7309 C A2T kernel(i+1)T A1
7310         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7311      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7312      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7313 C Following matrices are needed only for 6-th order cumulants
7314         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7315      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7316         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7317      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7318      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7319         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7320      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7321      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7322      &   ADtEAderx(1,1,1,1,1,2))
7323         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7324      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7325      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7326      &   ADtEA1derx(1,1,1,1,1,2))
7327         ENDIF
7328 C End 6-th order cumulants
7329         call transpose2(EUgder(1,1,j),auxmat(1,1))
7330         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7331         call transpose2(EUg(1,1,j),auxmat(1,1))
7332         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7333         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7334         do iii=1,2
7335           do kkk=1,5
7336             do lll=1,3
7337               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7338      &          EAEAderx(1,1,lll,kkk,iii,2))
7339             enddo
7340           enddo
7341         enddo
7342 C AEAb1 and AEAb2
7343 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7344 C They are needed only when the fifth- or the sixth-order cumulants are
7345 C indluded.
7346         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7347      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7348         call transpose2(AEA(1,1,1),auxmat(1,1))
7349         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7350         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7351         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7352         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7353         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7354         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7355         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7356         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7357         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7358         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7359         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7360         call transpose2(AEA(1,1,2),auxmat(1,1))
7361         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7362         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7363         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7364         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7365         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7366         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7367         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7368         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7369         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7370         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7371         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7372 C Calculate the Cartesian derivatives of the vectors.
7373         do iii=1,2
7374           do kkk=1,5
7375             do lll=1,3
7376               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7377               call matvec2(auxmat(1,1),b1(1,i),
7378      &          AEAb1derx(1,lll,kkk,iii,1,1))
7379               call matvec2(auxmat(1,1),Ub2(1,i),
7380      &          AEAb2derx(1,lll,kkk,iii,1,1))
7381               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7382      &          AEAb1derx(1,lll,kkk,iii,2,1))
7383               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7384      &          AEAb2derx(1,lll,kkk,iii,2,1))
7385               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7386               call matvec2(auxmat(1,1),b1(1,l),
7387      &          AEAb1derx(1,lll,kkk,iii,1,2))
7388               call matvec2(auxmat(1,1),Ub2(1,l),
7389      &          AEAb2derx(1,lll,kkk,iii,1,2))
7390               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7391      &          AEAb1derx(1,lll,kkk,iii,2,2))
7392               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7393      &          AEAb2derx(1,lll,kkk,iii,2,2))
7394             enddo
7395           enddo
7396         enddo
7397         ENDIF
7398 C End vectors
7399       endif
7400       return
7401       end
7402 C---------------------------------------------------------------------------
7403       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7404      &  KK,KKderg,AKA,AKAderg,AKAderx)
7405       implicit none
7406       integer nderg
7407       logical transp
7408       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7409      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7410      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7411       integer iii,kkk,lll
7412       integer jjj,mmm
7413       logical lprn
7414       common /kutas/ lprn
7415       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7416       do iii=1,nderg
7417         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7418      &    AKAderg(1,1,iii))
7419       enddo
7420 cd      if (lprn) write (2,*) 'In kernel'
7421       do kkk=1,5
7422 cd        if (lprn) write (2,*) 'kkk=',kkk
7423         do lll=1,3
7424           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7425      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7426 cd          if (lprn) then
7427 cd            write (2,*) 'lll=',lll
7428 cd            write (2,*) 'iii=1'
7429 cd            do jjj=1,2
7430 cd              write (2,'(3(2f10.5),5x)')
7431 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7432 cd            enddo
7433 cd          endif
7434           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7435      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7436 cd          if (lprn) then
7437 cd            write (2,*) 'lll=',lll
7438 cd            write (2,*) 'iii=2'
7439 cd            do jjj=1,2
7440 cd              write (2,'(3(2f10.5),5x)')
7441 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7442 cd            enddo
7443 cd          endif
7444         enddo
7445       enddo
7446       return
7447       end
7448 C---------------------------------------------------------------------------
7449       double precision function eello4(i,j,k,l,jj,kk)
7450       implicit real*8 (a-h,o-z)
7451       include 'DIMENSIONS'
7452       include 'COMMON.IOUNITS'
7453       include 'COMMON.CHAIN'
7454       include 'COMMON.DERIV'
7455       include 'COMMON.INTERACT'
7456       include 'COMMON.CONTACTS'
7457       include 'COMMON.TORSION'
7458       include 'COMMON.VAR'
7459       include 'COMMON.GEO'
7460       double precision pizda(2,2),ggg1(3),ggg2(3)
7461 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7462 cd        eello4=0.0d0
7463 cd        return
7464 cd      endif
7465 cd      print *,'eello4:',i,j,k,l,jj,kk
7466 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7467 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7468 cold      eij=facont_hb(jj,i)
7469 cold      ekl=facont_hb(kk,k)
7470 cold      ekont=eij*ekl
7471       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7472 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7473       gcorr_loc(k-1)=gcorr_loc(k-1)
7474      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7475       if (l.eq.j+1) then
7476         gcorr_loc(l-1)=gcorr_loc(l-1)
7477      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7478       else
7479         gcorr_loc(j-1)=gcorr_loc(j-1)
7480      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7481       endif
7482       do iii=1,2
7483         do kkk=1,5
7484           do lll=1,3
7485             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7486      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7487 cd            derx(lll,kkk,iii)=0.0d0
7488           enddo
7489         enddo
7490       enddo
7491 cd      gcorr_loc(l-1)=0.0d0
7492 cd      gcorr_loc(j-1)=0.0d0
7493 cd      gcorr_loc(k-1)=0.0d0
7494 cd      eel4=1.0d0
7495 cd      write (iout,*)'Contacts have occurred for peptide groups',
7496 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7497 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7498       if (j.lt.nres-1) then
7499         j1=j+1
7500         j2=j-1
7501       else
7502         j1=j-1
7503         j2=j-2
7504       endif
7505       if (l.lt.nres-1) then
7506         l1=l+1
7507         l2=l-1
7508       else
7509         l1=l-1
7510         l2=l-2
7511       endif
7512       do ll=1,3
7513 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7514 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7515         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7516         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7517 cgrad        ghalf=0.5d0*ggg1(ll)
7518         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7519         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7520         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7521         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7522         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7523         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7524 cgrad        ghalf=0.5d0*ggg2(ll)
7525         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7526         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7527         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7528         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7529         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7530         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7531       enddo
7532 cgrad      do m=i+1,j-1
7533 cgrad        do ll=1,3
7534 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7535 cgrad        enddo
7536 cgrad      enddo
7537 cgrad      do m=k+1,l-1
7538 cgrad        do ll=1,3
7539 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7540 cgrad        enddo
7541 cgrad      enddo
7542 cgrad      do m=i+2,j2
7543 cgrad        do ll=1,3
7544 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7545 cgrad        enddo
7546 cgrad      enddo
7547 cgrad      do m=k+2,l2
7548 cgrad        do ll=1,3
7549 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7550 cgrad        enddo
7551 cgrad      enddo
7552 cd      do iii=1,nres-3
7553 cd        write (2,*) iii,gcorr_loc(iii)
7554 cd      enddo
7555       eello4=ekont*eel4
7556 cd      write (2,*) 'ekont',ekont
7557 cd      write (iout,*) 'eello4',ekont*eel4
7558       return
7559       end
7560 C---------------------------------------------------------------------------
7561       double precision function eello5(i,j,k,l,jj,kk)
7562       implicit real*8 (a-h,o-z)
7563       include 'DIMENSIONS'
7564       include 'COMMON.IOUNITS'
7565       include 'COMMON.CHAIN'
7566       include 'COMMON.DERIV'
7567       include 'COMMON.INTERACT'
7568       include 'COMMON.CONTACTS'
7569       include 'COMMON.TORSION'
7570       include 'COMMON.VAR'
7571       include 'COMMON.GEO'
7572       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7573       double precision ggg1(3),ggg2(3)
7574 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7575 C                                                                              C
7576 C                            Parallel chains                                   C
7577 C                                                                              C
7578 C          o             o                   o             o                   C
7579 C         /l\           / \             \   / \           / \   /              C
7580 C        /   \         /   \             \ /   \         /   \ /               C
7581 C       j| o |l1       | o |              o| o |         | o |o                C
7582 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7583 C      \i/   \         /   \ /             /   \         /   \                 C
7584 C       o    k1             o                                                  C
7585 C         (I)          (II)                (III)          (IV)                 C
7586 C                                                                              C
7587 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7588 C                                                                              C
7589 C                            Antiparallel chains                               C
7590 C                                                                              C
7591 C          o             o                   o             o                   C
7592 C         /j\           / \             \   / \           / \   /              C
7593 C        /   \         /   \             \ /   \         /   \ /               C
7594 C      j1| o |l        | o |              o| o |         | o |o                C
7595 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7596 C      \i/   \         /   \ /             /   \         /   \                 C
7597 C       o     k1            o                                                  C
7598 C         (I)          (II)                (III)          (IV)                 C
7599 C                                                                              C
7600 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7601 C                                                                              C
7602 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7603 C                                                                              C
7604 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7605 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7606 cd        eello5=0.0d0
7607 cd        return
7608 cd      endif
7609 cd      write (iout,*)
7610 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7611 cd     &   ' and',k,l
7612       itk=itortyp(itype(k))
7613       itl=itortyp(itype(l))
7614       itj=itortyp(itype(j))
7615       eello5_1=0.0d0
7616       eello5_2=0.0d0
7617       eello5_3=0.0d0
7618       eello5_4=0.0d0
7619 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7620 cd     &   eel5_3_num,eel5_4_num)
7621       do iii=1,2
7622         do kkk=1,5
7623           do lll=1,3
7624             derx(lll,kkk,iii)=0.0d0
7625           enddo
7626         enddo
7627       enddo
7628 cd      eij=facont_hb(jj,i)
7629 cd      ekl=facont_hb(kk,k)
7630 cd      ekont=eij*ekl
7631 cd      write (iout,*)'Contacts have occurred for peptide groups',
7632 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7633 cd      goto 1111
7634 C Contribution from the graph I.
7635 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7636 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7637       call transpose2(EUg(1,1,k),auxmat(1,1))
7638       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7639       vv(1)=pizda(1,1)-pizda(2,2)
7640       vv(2)=pizda(1,2)+pizda(2,1)
7641       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7642      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7643 C Explicit gradient in virtual-dihedral angles.
7644       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7645      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7646      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7647       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7648       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7649       vv(1)=pizda(1,1)-pizda(2,2)
7650       vv(2)=pizda(1,2)+pizda(2,1)
7651       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7652      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7653      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7654       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7655       vv(1)=pizda(1,1)-pizda(2,2)
7656       vv(2)=pizda(1,2)+pizda(2,1)
7657       if (l.eq.j+1) then
7658         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7659      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7660      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7661       else
7662         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7663      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7664      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7665       endif
7666 C Cartesian gradient
7667       do iii=1,2
7668         do kkk=1,5
7669           do lll=1,3
7670             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7671      &        pizda(1,1))
7672             vv(1)=pizda(1,1)-pizda(2,2)
7673             vv(2)=pizda(1,2)+pizda(2,1)
7674             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7675      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7676      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7677           enddo
7678         enddo
7679       enddo
7680 c      goto 1112
7681 c1111  continue
7682 C Contribution from graph II
7683       call transpose2(EE(1,1,itk),auxmat(1,1))
7684       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7685       vv(1)=pizda(1,1)+pizda(2,2)
7686       vv(2)=pizda(2,1)-pizda(1,2)
7687       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7688      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7689 C Explicit gradient in virtual-dihedral angles.
7690       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7691      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7692       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7693       vv(1)=pizda(1,1)+pizda(2,2)
7694       vv(2)=pizda(2,1)-pizda(1,2)
7695       if (l.eq.j+1) then
7696         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7697      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7698      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7699       else
7700         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7701      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7702      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7703       endif
7704 C Cartesian gradient
7705       do iii=1,2
7706         do kkk=1,5
7707           do lll=1,3
7708             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7709      &        pizda(1,1))
7710             vv(1)=pizda(1,1)+pizda(2,2)
7711             vv(2)=pizda(2,1)-pizda(1,2)
7712             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7713      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7714      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7715           enddo
7716         enddo
7717       enddo
7718 cd      goto 1112
7719 cd1111  continue
7720       if (l.eq.j+1) then
7721 cd        goto 1110
7722 C Parallel orientation
7723 C Contribution from graph III
7724         call transpose2(EUg(1,1,l),auxmat(1,1))
7725         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7726         vv(1)=pizda(1,1)-pizda(2,2)
7727         vv(2)=pizda(1,2)+pizda(2,1)
7728         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7729      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7730 C Explicit gradient in virtual-dihedral angles.
7731         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7732      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7733      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7734         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7735         vv(1)=pizda(1,1)-pizda(2,2)
7736         vv(2)=pizda(1,2)+pizda(2,1)
7737         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7738      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7739      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7740         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7741         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7742         vv(1)=pizda(1,1)-pizda(2,2)
7743         vv(2)=pizda(1,2)+pizda(2,1)
7744         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7745      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7746      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7747 C Cartesian gradient
7748         do iii=1,2
7749           do kkk=1,5
7750             do lll=1,3
7751               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7752      &          pizda(1,1))
7753               vv(1)=pizda(1,1)-pizda(2,2)
7754               vv(2)=pizda(1,2)+pizda(2,1)
7755               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7756      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7757      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7758             enddo
7759           enddo
7760         enddo
7761 cd        goto 1112
7762 C Contribution from graph IV
7763 cd1110    continue
7764         call transpose2(EE(1,1,itl),auxmat(1,1))
7765         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7766         vv(1)=pizda(1,1)+pizda(2,2)
7767         vv(2)=pizda(2,1)-pizda(1,2)
7768         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7769      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7770 C Explicit gradient in virtual-dihedral angles.
7771         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7772      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7773         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7774         vv(1)=pizda(1,1)+pizda(2,2)
7775         vv(2)=pizda(2,1)-pizda(1,2)
7776         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7777      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7778      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7779 C Cartesian gradient
7780         do iii=1,2
7781           do kkk=1,5
7782             do lll=1,3
7783               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7784      &          pizda(1,1))
7785               vv(1)=pizda(1,1)+pizda(2,2)
7786               vv(2)=pizda(2,1)-pizda(1,2)
7787               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7788      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7789      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7790             enddo
7791           enddo
7792         enddo
7793       else
7794 C Antiparallel orientation
7795 C Contribution from graph III
7796 c        goto 1110
7797         call transpose2(EUg(1,1,j),auxmat(1,1))
7798         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7799         vv(1)=pizda(1,1)-pizda(2,2)
7800         vv(2)=pizda(1,2)+pizda(2,1)
7801         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7802      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7803 C Explicit gradient in virtual-dihedral angles.
7804         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7805      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7806      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7807         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7808         vv(1)=pizda(1,1)-pizda(2,2)
7809         vv(2)=pizda(1,2)+pizda(2,1)
7810         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7811      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7812      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7813         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7814         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7815         vv(1)=pizda(1,1)-pizda(2,2)
7816         vv(2)=pizda(1,2)+pizda(2,1)
7817         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7818      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7819      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7820 C Cartesian gradient
7821         do iii=1,2
7822           do kkk=1,5
7823             do lll=1,3
7824               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7825      &          pizda(1,1))
7826               vv(1)=pizda(1,1)-pizda(2,2)
7827               vv(2)=pizda(1,2)+pizda(2,1)
7828               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7829      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7830      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7831             enddo
7832           enddo
7833         enddo
7834 cd        goto 1112
7835 C Contribution from graph IV
7836 1110    continue
7837         call transpose2(EE(1,1,itj),auxmat(1,1))
7838         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7839         vv(1)=pizda(1,1)+pizda(2,2)
7840         vv(2)=pizda(2,1)-pizda(1,2)
7841         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7842      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7843 C Explicit gradient in virtual-dihedral angles.
7844         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7845      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7846         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7847         vv(1)=pizda(1,1)+pizda(2,2)
7848         vv(2)=pizda(2,1)-pizda(1,2)
7849         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7850      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7851      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7852 C Cartesian gradient
7853         do iii=1,2
7854           do kkk=1,5
7855             do lll=1,3
7856               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7857      &          pizda(1,1))
7858               vv(1)=pizda(1,1)+pizda(2,2)
7859               vv(2)=pizda(2,1)-pizda(1,2)
7860               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7861      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7862      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7863             enddo
7864           enddo
7865         enddo
7866       endif
7867 1112  continue
7868       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7869 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7870 cd        write (2,*) 'ijkl',i,j,k,l
7871 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7872 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7873 cd      endif
7874 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7875 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7876 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7877 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7878       if (j.lt.nres-1) then
7879         j1=j+1
7880         j2=j-1
7881       else
7882         j1=j-1
7883         j2=j-2
7884       endif
7885       if (l.lt.nres-1) then
7886         l1=l+1
7887         l2=l-1
7888       else
7889         l1=l-1
7890         l2=l-2
7891       endif
7892 cd      eij=1.0d0
7893 cd      ekl=1.0d0
7894 cd      ekont=1.0d0
7895 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7896 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7897 C        summed up outside the subrouine as for the other subroutines
7898 C        handling long-range interactions. The old code is commented out
7899 C        with "cgrad" to keep track of changes.
7900       do ll=1,3
7901 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7902 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7903         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7904         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7905 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7906 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7907 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7908 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7909 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7910 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7911 c     &   gradcorr5ij,
7912 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7913 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7914 cgrad        ghalf=0.5d0*ggg1(ll)
7915 cd        ghalf=0.0d0
7916         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7917         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7918         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7919         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7920         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7921         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7922 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7923 cgrad        ghalf=0.5d0*ggg2(ll)
7924 cd        ghalf=0.0d0
7925         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7926         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7927         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7928         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7929         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7930         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7931       enddo
7932 cd      goto 1112
7933 cgrad      do m=i+1,j-1
7934 cgrad        do ll=1,3
7935 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7936 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7937 cgrad        enddo
7938 cgrad      enddo
7939 cgrad      do m=k+1,l-1
7940 cgrad        do ll=1,3
7941 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7942 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7943 cgrad        enddo
7944 cgrad      enddo
7945 c1112  continue
7946 cgrad      do m=i+2,j2
7947 cgrad        do ll=1,3
7948 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7949 cgrad        enddo
7950 cgrad      enddo
7951 cgrad      do m=k+2,l2
7952 cgrad        do ll=1,3
7953 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7954 cgrad        enddo
7955 cgrad      enddo
7956 cd      do iii=1,nres-3
7957 cd        write (2,*) iii,g_corr5_loc(iii)
7958 cd      enddo
7959       eello5=ekont*eel5
7960 cd      write (2,*) 'ekont',ekont
7961 cd      write (iout,*) 'eello5',ekont*eel5
7962       return
7963       end
7964 c--------------------------------------------------------------------------
7965       double precision function eello6(i,j,k,l,jj,kk)
7966       implicit real*8 (a-h,o-z)
7967       include 'DIMENSIONS'
7968       include 'COMMON.IOUNITS'
7969       include 'COMMON.CHAIN'
7970       include 'COMMON.DERIV'
7971       include 'COMMON.INTERACT'
7972       include 'COMMON.CONTACTS'
7973       include 'COMMON.TORSION'
7974       include 'COMMON.VAR'
7975       include 'COMMON.GEO'
7976       include 'COMMON.FFIELD'
7977       double precision ggg1(3),ggg2(3)
7978 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7979 cd        eello6=0.0d0
7980 cd        return
7981 cd      endif
7982 cd      write (iout,*)
7983 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7984 cd     &   ' and',k,l
7985       eello6_1=0.0d0
7986       eello6_2=0.0d0
7987       eello6_3=0.0d0
7988       eello6_4=0.0d0
7989       eello6_5=0.0d0
7990       eello6_6=0.0d0
7991 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7992 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7993       do iii=1,2
7994         do kkk=1,5
7995           do lll=1,3
7996             derx(lll,kkk,iii)=0.0d0
7997           enddo
7998         enddo
7999       enddo
8000 cd      eij=facont_hb(jj,i)
8001 cd      ekl=facont_hb(kk,k)
8002 cd      ekont=eij*ekl
8003 cd      eij=1.0d0
8004 cd      ekl=1.0d0
8005 cd      ekont=1.0d0
8006       if (l.eq.j+1) then
8007         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8008         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8009         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8010         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8011         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8012         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8013       else
8014         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8015         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8016         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8017         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8018         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8019           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8020         else
8021           eello6_5=0.0d0
8022         endif
8023         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8024       endif
8025 C If turn contributions are considered, they will be handled separately.
8026       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8027 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8028 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8029 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8030 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8031 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8032 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8033 cd      goto 1112
8034       if (j.lt.nres-1) then
8035         j1=j+1
8036         j2=j-1
8037       else
8038         j1=j-1
8039         j2=j-2
8040       endif
8041       if (l.lt.nres-1) then
8042         l1=l+1
8043         l2=l-1
8044       else
8045         l1=l-1
8046         l2=l-2
8047       endif
8048       do ll=1,3
8049 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8050 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8051 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8052 cgrad        ghalf=0.5d0*ggg1(ll)
8053 cd        ghalf=0.0d0
8054         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8055         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8056         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8057         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8058         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8059         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8060         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8061         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8062 cgrad        ghalf=0.5d0*ggg2(ll)
8063 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8064 cd        ghalf=0.0d0
8065         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8066         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8067         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8068         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8069         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8070         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8071       enddo
8072 cd      goto 1112
8073 cgrad      do m=i+1,j-1
8074 cgrad        do ll=1,3
8075 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8076 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8077 cgrad        enddo
8078 cgrad      enddo
8079 cgrad      do m=k+1,l-1
8080 cgrad        do ll=1,3
8081 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8082 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8083 cgrad        enddo
8084 cgrad      enddo
8085 cgrad1112  continue
8086 cgrad      do m=i+2,j2
8087 cgrad        do ll=1,3
8088 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8089 cgrad        enddo
8090 cgrad      enddo
8091 cgrad      do m=k+2,l2
8092 cgrad        do ll=1,3
8093 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8094 cgrad        enddo
8095 cgrad      enddo
8096 cd      do iii=1,nres-3
8097 cd        write (2,*) iii,g_corr6_loc(iii)
8098 cd      enddo
8099       eello6=ekont*eel6
8100 cd      write (2,*) 'ekont',ekont
8101 cd      write (iout,*) 'eello6',ekont*eel6
8102       return
8103       end
8104 c--------------------------------------------------------------------------
8105       double precision function eello6_graph1(i,j,k,l,imat,swap)
8106       implicit real*8 (a-h,o-z)
8107       include 'DIMENSIONS'
8108       include 'COMMON.IOUNITS'
8109       include 'COMMON.CHAIN'
8110       include 'COMMON.DERIV'
8111       include 'COMMON.INTERACT'
8112       include 'COMMON.CONTACTS'
8113       include 'COMMON.TORSION'
8114       include 'COMMON.VAR'
8115       include 'COMMON.GEO'
8116       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8117       logical swap
8118       logical lprn
8119       common /kutas/ lprn
8120 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8121 C                                                                              C
8122 C      Parallel       Antiparallel                                             C
8123 C                                                                              C
8124 C          o             o                                                     C
8125 C         /l\           /j\                                                    C
8126 C        /   \         /   \                                                   C
8127 C       /| o |         | o |\                                                  C
8128 C     \ j|/k\|  /   \  |/k\|l /                                                C
8129 C      \ /   \ /     \ /   \ /                                                 C
8130 C       o     o       o     o                                                  C
8131 C       i             i                                                        C
8132 C                                                                              C
8133 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8134       itk=itortyp(itype(k))
8135       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8136       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8137       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8138       call transpose2(EUgC(1,1,k),auxmat(1,1))
8139       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8140       vv1(1)=pizda1(1,1)-pizda1(2,2)
8141       vv1(2)=pizda1(1,2)+pizda1(2,1)
8142       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8143       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8144       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8145       s5=scalar2(vv(1),Dtobr2(1,i))
8146 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8147       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8148       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8149      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8150      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8151      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8152      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8153      & +scalar2(vv(1),Dtobr2der(1,i)))
8154       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8155       vv1(1)=pizda1(1,1)-pizda1(2,2)
8156       vv1(2)=pizda1(1,2)+pizda1(2,1)
8157       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8158       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8159       if (l.eq.j+1) then
8160         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8161      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8162      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8163      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8164      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8165       else
8166         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8167      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8168      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8169      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8170      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8171       endif
8172       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8173       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8174       vv1(1)=pizda1(1,1)-pizda1(2,2)
8175       vv1(2)=pizda1(1,2)+pizda1(2,1)
8176       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8177      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8178      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8179      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8180       do iii=1,2
8181         if (swap) then
8182           ind=3-iii
8183         else
8184           ind=iii
8185         endif
8186         do kkk=1,5
8187           do lll=1,3
8188             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8189             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8190             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8191             call transpose2(EUgC(1,1,k),auxmat(1,1))
8192             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8193      &        pizda1(1,1))
8194             vv1(1)=pizda1(1,1)-pizda1(2,2)
8195             vv1(2)=pizda1(1,2)+pizda1(2,1)
8196             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8197             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8198      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8199             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8200      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8201             s5=scalar2(vv(1),Dtobr2(1,i))
8202             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8203           enddo
8204         enddo
8205       enddo
8206       return
8207       end
8208 c----------------------------------------------------------------------------
8209       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8210       implicit real*8 (a-h,o-z)
8211       include 'DIMENSIONS'
8212       include 'COMMON.IOUNITS'
8213       include 'COMMON.CHAIN'
8214       include 'COMMON.DERIV'
8215       include 'COMMON.INTERACT'
8216       include 'COMMON.CONTACTS'
8217       include 'COMMON.TORSION'
8218       include 'COMMON.VAR'
8219       include 'COMMON.GEO'
8220       logical swap
8221       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8222      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8223       logical lprn
8224       common /kutas/ lprn
8225 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8226 C                                                                              C
8227 C      Parallel       Antiparallel                                             C
8228 C                                                                              C
8229 C          o             o                                                     C
8230 C     \   /l\           /j\   /                                                C
8231 C      \ /   \         /   \ /                                                 C
8232 C       o| o |         | o |o                                                  C
8233 C     \ j|/k\|      \  |/k\|l                                                  C
8234 C      \ /   \       \ /   \                                                   C
8235 C       o             o                                                        C
8236 C       i             i                                                        C
8237 C                                                                              C
8238 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8239 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8240 C AL 7/4/01 s1 would occur in the sixth-order moment,
8241 C           but not in a cluster cumulant
8242 #ifdef MOMENT
8243       s1=dip(1,jj,i)*dip(1,kk,k)
8244 #endif
8245       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8246       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8247       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8248       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8249       call transpose2(EUg(1,1,k),auxmat(1,1))
8250       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8251       vv(1)=pizda(1,1)-pizda(2,2)
8252       vv(2)=pizda(1,2)+pizda(2,1)
8253       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8254 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8255 #ifdef MOMENT
8256       eello6_graph2=-(s1+s2+s3+s4)
8257 #else
8258       eello6_graph2=-(s2+s3+s4)
8259 #endif
8260 c      eello6_graph2=-s3
8261 C Derivatives in gamma(i-1)
8262       if (i.gt.1) then
8263 #ifdef MOMENT
8264         s1=dipderg(1,jj,i)*dip(1,kk,k)
8265 #endif
8266         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8267         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8268         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8269         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8270 #ifdef MOMENT
8271         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8272 #else
8273         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8274 #endif
8275 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8276       endif
8277 C Derivatives in gamma(k-1)
8278 #ifdef MOMENT
8279       s1=dip(1,jj,i)*dipderg(1,kk,k)
8280 #endif
8281       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8282       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8283       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8284       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8285       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8286       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8287       vv(1)=pizda(1,1)-pizda(2,2)
8288       vv(2)=pizda(1,2)+pizda(2,1)
8289       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8290 #ifdef MOMENT
8291       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8292 #else
8293       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8294 #endif
8295 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8296 C Derivatives in gamma(j-1) or gamma(l-1)
8297       if (j.gt.1) then
8298 #ifdef MOMENT
8299         s1=dipderg(3,jj,i)*dip(1,kk,k)
8300 #endif
8301         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8302         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8303         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8304         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8305         vv(1)=pizda(1,1)-pizda(2,2)
8306         vv(2)=pizda(1,2)+pizda(2,1)
8307         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8308 #ifdef MOMENT
8309         if (swap) then
8310           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8311         else
8312           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8313         endif
8314 #endif
8315         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8316 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8317       endif
8318 C Derivatives in gamma(l-1) or gamma(j-1)
8319       if (l.gt.1) then
8320 #ifdef MOMENT
8321         s1=dip(1,jj,i)*dipderg(3,kk,k)
8322 #endif
8323         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8324         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8325         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8326         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8327         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8328         vv(1)=pizda(1,1)-pizda(2,2)
8329         vv(2)=pizda(1,2)+pizda(2,1)
8330         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8331 #ifdef MOMENT
8332         if (swap) then
8333           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8334         else
8335           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8336         endif
8337 #endif
8338         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8339 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8340       endif
8341 C Cartesian derivatives.
8342       if (lprn) then
8343         write (2,*) 'In eello6_graph2'
8344         do iii=1,2
8345           write (2,*) 'iii=',iii
8346           do kkk=1,5
8347             write (2,*) 'kkk=',kkk
8348             do jjj=1,2
8349               write (2,'(3(2f10.5),5x)')
8350      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8351             enddo
8352           enddo
8353         enddo
8354       endif
8355       do iii=1,2
8356         do kkk=1,5
8357           do lll=1,3
8358 #ifdef MOMENT
8359             if (iii.eq.1) then
8360               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8361             else
8362               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8363             endif
8364 #endif
8365             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8366      &        auxvec(1))
8367             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8368             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8369      &        auxvec(1))
8370             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8371             call transpose2(EUg(1,1,k),auxmat(1,1))
8372             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8373      &        pizda(1,1))
8374             vv(1)=pizda(1,1)-pizda(2,2)
8375             vv(2)=pizda(1,2)+pizda(2,1)
8376             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8377 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8378 #ifdef MOMENT
8379             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8380 #else
8381             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8382 #endif
8383             if (swap) then
8384               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8385             else
8386               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8387             endif
8388           enddo
8389         enddo
8390       enddo
8391       return
8392       end
8393 c----------------------------------------------------------------------------
8394       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8395       implicit real*8 (a-h,o-z)
8396       include 'DIMENSIONS'
8397       include 'COMMON.IOUNITS'
8398       include 'COMMON.CHAIN'
8399       include 'COMMON.DERIV'
8400       include 'COMMON.INTERACT'
8401       include 'COMMON.CONTACTS'
8402       include 'COMMON.TORSION'
8403       include 'COMMON.VAR'
8404       include 'COMMON.GEO'
8405       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8406       logical swap
8407 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8408 C                                                                              C
8409 C      Parallel       Antiparallel                                             C
8410 C                                                                              C
8411 C          o             o                                                     C
8412 C         /l\   /   \   /j\                                                    C
8413 C        /   \ /     \ /   \                                                   C
8414 C       /| o |o       o| o |\                                                  C
8415 C       j|/k\|  /      |/k\|l /                                                C
8416 C        /   \ /       /   \ /                                                 C
8417 C       /     o       /     o                                                  C
8418 C       i             i                                                        C
8419 C                                                                              C
8420 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8421 C
8422 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8423 C           energy moment and not to the cluster cumulant.
8424       iti=itortyp(itype(i))
8425       if (j.lt.nres-1) then
8426         itj1=itortyp(itype(j+1))
8427       else
8428         itj1=ntortyp+1
8429       endif
8430       itk=itortyp(itype(k))
8431       itk1=itortyp(itype(k+1))
8432       if (l.lt.nres-1) then
8433         itl1=itortyp(itype(l+1))
8434       else
8435         itl1=ntortyp+1
8436       endif
8437 #ifdef MOMENT
8438       s1=dip(4,jj,i)*dip(4,kk,k)
8439 #endif
8440       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8441       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8442       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8443       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8444       call transpose2(EE(1,1,itk),auxmat(1,1))
8445       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8446       vv(1)=pizda(1,1)+pizda(2,2)
8447       vv(2)=pizda(2,1)-pizda(1,2)
8448       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8449 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8450 cd     & "sum",-(s2+s3+s4)
8451 #ifdef MOMENT
8452       eello6_graph3=-(s1+s2+s3+s4)
8453 #else
8454       eello6_graph3=-(s2+s3+s4)
8455 #endif
8456 c      eello6_graph3=-s4
8457 C Derivatives in gamma(k-1)
8458       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8459       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8460       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8461       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8462 C Derivatives in gamma(l-1)
8463       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8464       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8465       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8466       vv(1)=pizda(1,1)+pizda(2,2)
8467       vv(2)=pizda(2,1)-pizda(1,2)
8468       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8469       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8470 C Cartesian derivatives.
8471       do iii=1,2
8472         do kkk=1,5
8473           do lll=1,3
8474 #ifdef MOMENT
8475             if (iii.eq.1) then
8476               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8477             else
8478               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8479             endif
8480 #endif
8481             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8482      &        auxvec(1))
8483             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8484             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8485      &        auxvec(1))
8486             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8487             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8488      &        pizda(1,1))
8489             vv(1)=pizda(1,1)+pizda(2,2)
8490             vv(2)=pizda(2,1)-pizda(1,2)
8491             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8492 #ifdef MOMENT
8493             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8494 #else
8495             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8496 #endif
8497             if (swap) then
8498               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8499             else
8500               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8501             endif
8502 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8503           enddo
8504         enddo
8505       enddo
8506       return
8507       end
8508 c----------------------------------------------------------------------------
8509       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8510       implicit real*8 (a-h,o-z)
8511       include 'DIMENSIONS'
8512       include 'COMMON.IOUNITS'
8513       include 'COMMON.CHAIN'
8514       include 'COMMON.DERIV'
8515       include 'COMMON.INTERACT'
8516       include 'COMMON.CONTACTS'
8517       include 'COMMON.TORSION'
8518       include 'COMMON.VAR'
8519       include 'COMMON.GEO'
8520       include 'COMMON.FFIELD'
8521       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8522      & auxvec1(2),auxmat1(2,2)
8523       logical swap
8524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8525 C                                                                              C
8526 C      Parallel       Antiparallel                                             C
8527 C                                                                              C
8528 C          o             o                                                     C
8529 C         /l\   /   \   /j\                                                    C
8530 C        /   \ /     \ /   \                                                   C
8531 C       /| o |o       o| o |\                                                  C
8532 C     \ j|/k\|      \  |/k\|l                                                  C
8533 C      \ /   \       \ /   \                                                   C
8534 C       o     \       o     \                                                  C
8535 C       i             i                                                        C
8536 C                                                                              C
8537 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8538 C
8539 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8540 C           energy moment and not to the cluster cumulant.
8541 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8542       iti=itortyp(itype(i))
8543       itj=itortyp(itype(j))
8544       if (j.lt.nres-1) then
8545         itj1=itortyp(itype(j+1))
8546       else
8547         itj1=ntortyp+1
8548       endif
8549       itk=itortyp(itype(k))
8550       if (k.lt.nres-1) then
8551         itk1=itortyp(itype(k+1))
8552       else
8553         itk1=ntortyp+1
8554       endif
8555       itl=itortyp(itype(l))
8556       if (l.lt.nres-1) then
8557         itl1=itortyp(itype(l+1))
8558       else
8559         itl1=ntortyp+1
8560       endif
8561 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8562 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8563 cd     & ' itl',itl,' itl1',itl1
8564 #ifdef MOMENT
8565       if (imat.eq.1) then
8566         s1=dip(3,jj,i)*dip(3,kk,k)
8567       else
8568         s1=dip(2,jj,j)*dip(2,kk,l)
8569       endif
8570 #endif
8571       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8572       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8573       if (j.eq.l+1) then
8574         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8575         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8576       else
8577         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8578         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8579       endif
8580       call transpose2(EUg(1,1,k),auxmat(1,1))
8581       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8582       vv(1)=pizda(1,1)-pizda(2,2)
8583       vv(2)=pizda(2,1)+pizda(1,2)
8584       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8585 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8586 #ifdef MOMENT
8587       eello6_graph4=-(s1+s2+s3+s4)
8588 #else
8589       eello6_graph4=-(s2+s3+s4)
8590 #endif
8591 C Derivatives in gamma(i-1)
8592       if (i.gt.1) then
8593 #ifdef MOMENT
8594         if (imat.eq.1) then
8595           s1=dipderg(2,jj,i)*dip(3,kk,k)
8596         else
8597           s1=dipderg(4,jj,j)*dip(2,kk,l)
8598         endif
8599 #endif
8600         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8601         if (j.eq.l+1) then
8602           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8603           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8604         else
8605           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8606           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8607         endif
8608         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8609         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8610 cd          write (2,*) 'turn6 derivatives'
8611 #ifdef MOMENT
8612           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8613 #else
8614           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8615 #endif
8616         else
8617 #ifdef MOMENT
8618           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8619 #else
8620           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8621 #endif
8622         endif
8623       endif
8624 C Derivatives in gamma(k-1)
8625 #ifdef MOMENT
8626       if (imat.eq.1) then
8627         s1=dip(3,jj,i)*dipderg(2,kk,k)
8628       else
8629         s1=dip(2,jj,j)*dipderg(4,kk,l)
8630       endif
8631 #endif
8632       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8633       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8634       if (j.eq.l+1) then
8635         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8636         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8637       else
8638         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8639         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8640       endif
8641       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8642       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8643       vv(1)=pizda(1,1)-pizda(2,2)
8644       vv(2)=pizda(2,1)+pizda(1,2)
8645       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8646       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8647 #ifdef MOMENT
8648         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8649 #else
8650         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8651 #endif
8652       else
8653 #ifdef MOMENT
8654         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8655 #else
8656         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8657 #endif
8658       endif
8659 C Derivatives in gamma(j-1) or gamma(l-1)
8660       if (l.eq.j+1 .and. l.gt.1) then
8661         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8662         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8663         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8664         vv(1)=pizda(1,1)-pizda(2,2)
8665         vv(2)=pizda(2,1)+pizda(1,2)
8666         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8667         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8668       else if (j.gt.1) then
8669         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8670         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8671         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8672         vv(1)=pizda(1,1)-pizda(2,2)
8673         vv(2)=pizda(2,1)+pizda(1,2)
8674         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8675         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8676           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8677         else
8678           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8679         endif
8680       endif
8681 C Cartesian derivatives.
8682       do iii=1,2
8683         do kkk=1,5
8684           do lll=1,3
8685 #ifdef MOMENT
8686             if (iii.eq.1) then
8687               if (imat.eq.1) then
8688                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8689               else
8690                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8691               endif
8692             else
8693               if (imat.eq.1) then
8694                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8695               else
8696                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8697               endif
8698             endif
8699 #endif
8700             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8701      &        auxvec(1))
8702             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8703             if (j.eq.l+1) then
8704               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8705      &          b1(1,j+1),auxvec(1))
8706               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8707             else
8708               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8709      &          b1(1,l+1),auxvec(1))
8710               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8711             endif
8712             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8713      &        pizda(1,1))
8714             vv(1)=pizda(1,1)-pizda(2,2)
8715             vv(2)=pizda(2,1)+pizda(1,2)
8716             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8717             if (swap) then
8718               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8719 #ifdef MOMENT
8720                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8721      &             -(s1+s2+s4)
8722 #else
8723                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8724      &             -(s2+s4)
8725 #endif
8726                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8727               else
8728 #ifdef MOMENT
8729                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8730 #else
8731                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8732 #endif
8733                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8734               endif
8735             else
8736 #ifdef MOMENT
8737               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8738 #else
8739               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8740 #endif
8741               if (l.eq.j+1) then
8742                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8743               else
8744                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8745               endif
8746             endif
8747           enddo
8748         enddo
8749       enddo
8750       return
8751       end
8752 c----------------------------------------------------------------------------
8753       double precision function eello_turn6(i,jj,kk)
8754       implicit real*8 (a-h,o-z)
8755       include 'DIMENSIONS'
8756       include 'COMMON.IOUNITS'
8757       include 'COMMON.CHAIN'
8758       include 'COMMON.DERIV'
8759       include 'COMMON.INTERACT'
8760       include 'COMMON.CONTACTS'
8761       include 'COMMON.TORSION'
8762       include 'COMMON.VAR'
8763       include 'COMMON.GEO'
8764       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8765      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8766      &  ggg1(3),ggg2(3)
8767       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8768      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8769 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8770 C           the respective energy moment and not to the cluster cumulant.
8771       s1=0.0d0
8772       s8=0.0d0
8773       s13=0.0d0
8774 c
8775       eello_turn6=0.0d0
8776       j=i+4
8777       k=i+1
8778       l=i+3
8779       iti=itortyp(itype(i))
8780       itk=itortyp(itype(k))
8781       itk1=itortyp(itype(k+1))
8782       itl=itortyp(itype(l))
8783       itj=itortyp(itype(j))
8784 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8785 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8786 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8787 cd        eello6=0.0d0
8788 cd        return
8789 cd      endif
8790 cd      write (iout,*)
8791 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8792 cd     &   ' and',k,l
8793 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8794       do iii=1,2
8795         do kkk=1,5
8796           do lll=1,3
8797             derx_turn(lll,kkk,iii)=0.0d0
8798           enddo
8799         enddo
8800       enddo
8801 cd      eij=1.0d0
8802 cd      ekl=1.0d0
8803 cd      ekont=1.0d0
8804       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8805 cd      eello6_5=0.0d0
8806 cd      write (2,*) 'eello6_5',eello6_5
8807 #ifdef MOMENT
8808       call transpose2(AEA(1,1,1),auxmat(1,1))
8809       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8810       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8811       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8812 #endif
8813       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8814       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8815       s2 = scalar2(b1(1,k),vtemp1(1))
8816 #ifdef MOMENT
8817       call transpose2(AEA(1,1,2),atemp(1,1))
8818       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8819       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8820       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8821 #endif
8822       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8823       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8824       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8825 #ifdef MOMENT
8826       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8827       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8828       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8829       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8830       ss13 = scalar2(b1(1,k),vtemp4(1))
8831       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8832 #endif
8833 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8834 c      s1=0.0d0
8835 c      s2=0.0d0
8836 c      s8=0.0d0
8837 c      s12=0.0d0
8838 c      s13=0.0d0
8839       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8840 C Derivatives in gamma(i+2)
8841       s1d =0.0d0
8842       s8d =0.0d0
8843 #ifdef MOMENT
8844       call transpose2(AEA(1,1,1),auxmatd(1,1))
8845       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8846       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8847       call transpose2(AEAderg(1,1,2),atempd(1,1))
8848       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8849       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8850 #endif
8851       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8852       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8853       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8854 c      s1d=0.0d0
8855 c      s2d=0.0d0
8856 c      s8d=0.0d0
8857 c      s12d=0.0d0
8858 c      s13d=0.0d0
8859       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8860 C Derivatives in gamma(i+3)
8861 #ifdef MOMENT
8862       call transpose2(AEA(1,1,1),auxmatd(1,1))
8863       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8864       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8865       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8866 #endif
8867       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8868       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8869       s2d = scalar2(b1(1,k),vtemp1d(1))
8870 #ifdef MOMENT
8871       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8872       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8873 #endif
8874       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8875 #ifdef MOMENT
8876       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8877       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8878       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8879 #endif
8880 c      s1d=0.0d0
8881 c      s2d=0.0d0
8882 c      s8d=0.0d0
8883 c      s12d=0.0d0
8884 c      s13d=0.0d0
8885 #ifdef MOMENT
8886       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8887      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8888 #else
8889       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8890      &               -0.5d0*ekont*(s2d+s12d)
8891 #endif
8892 C Derivatives in gamma(i+4)
8893       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8894       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8895       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8896 #ifdef MOMENT
8897       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8898       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8899       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8900 #endif
8901 c      s1d=0.0d0
8902 c      s2d=0.0d0
8903 c      s8d=0.0d0
8904 C      s12d=0.0d0
8905 c      s13d=0.0d0
8906 #ifdef MOMENT
8907       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8908 #else
8909       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8910 #endif
8911 C Derivatives in gamma(i+5)
8912 #ifdef MOMENT
8913       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8914       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8915       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8916 #endif
8917       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8918       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8919       s2d = scalar2(b1(1,k),vtemp1d(1))
8920 #ifdef MOMENT
8921       call transpose2(AEA(1,1,2),atempd(1,1))
8922       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8923       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8924 #endif
8925       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8926       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8927 #ifdef MOMENT
8928       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8929       ss13d = scalar2(b1(1,k),vtemp4d(1))
8930       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8931 #endif
8932 c      s1d=0.0d0
8933 c      s2d=0.0d0
8934 c      s8d=0.0d0
8935 c      s12d=0.0d0
8936 c      s13d=0.0d0
8937 #ifdef MOMENT
8938       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8939      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8940 #else
8941       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8942      &               -0.5d0*ekont*(s2d+s12d)
8943 #endif
8944 C Cartesian derivatives
8945       do iii=1,2
8946         do kkk=1,5
8947           do lll=1,3
8948 #ifdef MOMENT
8949             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8950             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8951             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8952 #endif
8953             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8954             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8955      &          vtemp1d(1))
8956             s2d = scalar2(b1(1,k),vtemp1d(1))
8957 #ifdef MOMENT
8958             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8959             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8960             s8d = -(atempd(1,1)+atempd(2,2))*
8961      &           scalar2(cc(1,1,itl),vtemp2(1))
8962 #endif
8963             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8964      &           auxmatd(1,1))
8965             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8966             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8967 c      s1d=0.0d0
8968 c      s2d=0.0d0
8969 c      s8d=0.0d0
8970 c      s12d=0.0d0
8971 c      s13d=0.0d0
8972 #ifdef MOMENT
8973             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8974      &        - 0.5d0*(s1d+s2d)
8975 #else
8976             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8977      &        - 0.5d0*s2d
8978 #endif
8979 #ifdef MOMENT
8980             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8981      &        - 0.5d0*(s8d+s12d)
8982 #else
8983             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8984      &        - 0.5d0*s12d
8985 #endif
8986           enddo
8987         enddo
8988       enddo
8989 #ifdef MOMENT
8990       do kkk=1,5
8991         do lll=1,3
8992           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8993      &      achuj_tempd(1,1))
8994           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8995           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8996           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8997           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8998           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8999      &      vtemp4d(1))
9000           ss13d = scalar2(b1(1,k),vtemp4d(1))
9001           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9002           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9003         enddo
9004       enddo
9005 #endif
9006 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9007 cd     &  16*eel_turn6_num
9008 cd      goto 1112
9009       if (j.lt.nres-1) then
9010         j1=j+1
9011         j2=j-1
9012       else
9013         j1=j-1
9014         j2=j-2
9015       endif
9016       if (l.lt.nres-1) then
9017         l1=l+1
9018         l2=l-1
9019       else
9020         l1=l-1
9021         l2=l-2
9022       endif
9023       do ll=1,3
9024 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9025 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9026 cgrad        ghalf=0.5d0*ggg1(ll)
9027 cd        ghalf=0.0d0
9028         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9029         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9030         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9031      &    +ekont*derx_turn(ll,2,1)
9032         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9033         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9034      &    +ekont*derx_turn(ll,4,1)
9035         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9036         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9037         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9038 cgrad        ghalf=0.5d0*ggg2(ll)
9039 cd        ghalf=0.0d0
9040         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9041      &    +ekont*derx_turn(ll,2,2)
9042         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9043         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9044      &    +ekont*derx_turn(ll,4,2)
9045         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9046         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9047         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9048       enddo
9049 cd      goto 1112
9050 cgrad      do m=i+1,j-1
9051 cgrad        do ll=1,3
9052 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9053 cgrad        enddo
9054 cgrad      enddo
9055 cgrad      do m=k+1,l-1
9056 cgrad        do ll=1,3
9057 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9058 cgrad        enddo
9059 cgrad      enddo
9060 cgrad1112  continue
9061 cgrad      do m=i+2,j2
9062 cgrad        do ll=1,3
9063 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9064 cgrad        enddo
9065 cgrad      enddo
9066 cgrad      do m=k+2,l2
9067 cgrad        do ll=1,3
9068 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9069 cgrad        enddo
9070 cgrad      enddo
9071 cd      do iii=1,nres-3
9072 cd        write (2,*) iii,g_corr6_loc(iii)
9073 cd      enddo
9074       eello_turn6=ekont*eel_turn6
9075 cd      write (2,*) 'ekont',ekont
9076 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9077       return
9078       end
9079
9080 C-----------------------------------------------------------------------------
9081       double precision function scalar(u,v)
9082 !DIR$ INLINEALWAYS scalar
9083 #ifndef OSF
9084 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9085 #endif
9086       implicit none
9087       double precision u(3),v(3)
9088 cd      double precision sc
9089 cd      integer i
9090 cd      sc=0.0d0
9091 cd      do i=1,3
9092 cd        sc=sc+u(i)*v(i)
9093 cd      enddo
9094 cd      scalar=sc
9095
9096       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9097       return
9098       end
9099 crc-------------------------------------------------
9100       SUBROUTINE MATVEC2(A1,V1,V2)
9101 !DIR$ INLINEALWAYS MATVEC2
9102 #ifndef OSF
9103 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9104 #endif
9105       implicit real*8 (a-h,o-z)
9106       include 'DIMENSIONS'
9107       DIMENSION A1(2,2),V1(2),V2(2)
9108 c      DO 1 I=1,2
9109 c        VI=0.0
9110 c        DO 3 K=1,2
9111 c    3     VI=VI+A1(I,K)*V1(K)
9112 c        Vaux(I)=VI
9113 c    1 CONTINUE
9114
9115       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9116       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9117
9118       v2(1)=vaux1
9119       v2(2)=vaux2
9120       END
9121 C---------------------------------------
9122       SUBROUTINE MATMAT2(A1,A2,A3)
9123 #ifndef OSF
9124 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9125 #endif
9126       implicit real*8 (a-h,o-z)
9127       include 'DIMENSIONS'
9128       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9129 c      DIMENSION AI3(2,2)
9130 c        DO  J=1,2
9131 c          A3IJ=0.0
9132 c          DO K=1,2
9133 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9134 c          enddo
9135 c          A3(I,J)=A3IJ
9136 c       enddo
9137 c      enddo
9138
9139       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9140       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9141       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9142       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9143
9144       A3(1,1)=AI3_11
9145       A3(2,1)=AI3_21
9146       A3(1,2)=AI3_12
9147       A3(2,2)=AI3_22
9148       END
9149
9150 c-------------------------------------------------------------------------
9151       double precision function scalar2(u,v)
9152 !DIR$ INLINEALWAYS scalar2
9153       implicit none
9154       double precision u(2),v(2)
9155       double precision sc
9156       integer i
9157       scalar2=u(1)*v(1)+u(2)*v(2)
9158       return
9159       end
9160
9161 C-----------------------------------------------------------------------------
9162
9163       subroutine transpose2(a,at)
9164 !DIR$ INLINEALWAYS transpose2
9165 #ifndef OSF
9166 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9167 #endif
9168       implicit none
9169       double precision a(2,2),at(2,2)
9170       at(1,1)=a(1,1)
9171       at(1,2)=a(2,1)
9172       at(2,1)=a(1,2)
9173       at(2,2)=a(2,2)
9174       return
9175       end
9176 c--------------------------------------------------------------------------
9177       subroutine transpose(n,a,at)
9178       implicit none
9179       integer n,i,j
9180       double precision a(n,n),at(n,n)
9181       do i=1,n
9182         do j=1,n
9183           at(j,i)=a(i,j)
9184         enddo
9185       enddo
9186       return
9187       end
9188 C---------------------------------------------------------------------------
9189       subroutine prodmat3(a1,a2,kk,transp,prod)
9190 !DIR$ INLINEALWAYS prodmat3
9191 #ifndef OSF
9192 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9193 #endif
9194       implicit none
9195       integer i,j
9196       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9197       logical transp
9198 crc      double precision auxmat(2,2),prod_(2,2)
9199
9200       if (transp) then
9201 crc        call transpose2(kk(1,1),auxmat(1,1))
9202 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9203 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9204
9205            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9206      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9207            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9208      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9209            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9210      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9211            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9212      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9213
9214       else
9215 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9216 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9217
9218            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9219      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9220            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9221      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9222            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9223      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9224            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9225      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9226
9227       endif
9228 c      call transpose2(a2(1,1),a2t(1,1))
9229
9230 crc      print *,transp
9231 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9232 crc      print *,((prod(i,j),i=1,2),j=1,2)
9233
9234       return
9235       end
9236