source/unres/src_MD/src/energy_p_new_barrier.F.org

   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      print *," Processor",myrank," calls SUM_ENERGY"
 300       call sum_energy(energia,.true.)
 301 c      print *," Processor",myrank," left SUM_ENERGY"
 302 #ifdef TIMING
 303       time_sumene=time_sumene+MPI_Wtime()-time00
 304 #endif
 305       return
 306       end
 307 c-------------------------------------------------------------------------------
 308       subroutine sum_energy(energia,reduce)
 309       implicit real*8 (a-h,o-z)
 310       include 'DIMENSIONS'
 311 #ifndef ISNAN
 312       external proc_proc
 313 #ifdef WINPGI
 314 cMS$ATTRIBUTES C ::  proc_proc
 315 #endif
 316 #endif
 317 #ifdef MPI
 318       include "mpif.h"
 319 #endif
 320       include 'COMMON.SETUP'
 321       include 'COMMON.IOUNITS'
 322       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 323       include 'COMMON.FFIELD'
 324       include 'COMMON.DERIV'
 325       include 'COMMON.INTERACT'
 326       include 'COMMON.SBRIDGE'
 327       include 'COMMON.CHAIN'
 328       include 'COMMON.VAR'
 329       include 'COMMON.CONTROL'
 330       include 'COMMON.TIME1'
 331       logical reduce
 332 #ifdef MPI
 333       if (nfgtasks.gt.1 .and. reduce) then
 334 #ifdef DEBUG
 335         write (iout,*) "energies before REDUCE"
 336         call enerprint(energia)
 337         call flush(iout)
 338 #endif
 339         do i=0,n_ene
 340           enebuff(i)=energia(i)
 341         enddo
 342         time00=MPI_Wtime()
 343         call MPI_Barrier(FG_COMM,IERR)
 344         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 345         time00=MPI_Wtime()
 346         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 347      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 348 #ifdef DEBUG
 349         write (iout,*) "energies after REDUCE"
 350         call enerprint(energia)
 351         call flush(iout)
 352 #endif
 353         time_Reduce=time_Reduce+MPI_Wtime()-time00
 354       endif
 355       if (fg_rank.eq.0) then
 356 #endif
 357       evdw=energia(1)
 358 #ifdef SCP14
 359       evdw2=energia(2)+energia(18)
 360       evdw2_14=energia(18)
 361 #else
 362       evdw2=energia(2)
 363 #endif
 364 #ifdef SPLITELE
 365       ees=energia(3)
 366       evdw1=energia(16)
 367 #else
 368       ees=energia(3)
 369       evdw1=0.0d0
 370 #endif
 371       ecorr=energia(4)
 372       ecorr5=energia(5)
 373       ecorr6=energia(6)
 374       eel_loc=energia(7)
 375       eello_turn3=energia(8)
 376       eello_turn4=energia(9)
 377       eturn6=energia(10)
 378       ebe=energia(11)
 379       escloc=energia(12)
 380       etors=energia(13)
 381       etors_d=energia(14)
 382       ehpb=energia(15)
 383       edihcnstr=energia(19)
 384       estr=energia(17)
 385       Uconst=energia(20)
 386       esccor=energia(21)
 387 #ifdef SPLITELE
 388       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 389      & +wang*ebe+wtor*etors+wscloc*escloc
 390      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 391      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 392      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 393      & +wbond*estr+Uconst+wsccor*esccor
 394 #else
 395       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 396      & +wang*ebe+wtor*etors+wscloc*escloc
 397      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 398      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 399      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 400      & +wbond*estr+Uconst+wsccor*esccor
 401 #endif
 402       energia(0)=etot
 403 c detecting NaNQ
 404 #ifdef ISNAN
 405 #ifdef AIX
 406       if (isnan(etot).ne.0) energia(0)=1.0d+99
 407 #else
 408       if (isnan(etot)) energia(0)=1.0d+99
 409 #endif
 410 #else
 411       i=0
 412 #ifdef WINPGI
 413       idumm=proc_proc(etot,i)
 414 #else
 415       call proc_proc(etot,i)
 416 #endif
 417       if(i.eq.1)energia(0)=1.0d+99
 418 #endif
 419 #ifdef MPI
 420       endif
 421 #endif
 422       return
 423       end
 424 c-------------------------------------------------------------------------------
 425       subroutine sum_gradient
 426       implicit real*8 (a-h,o-z)
 427       include 'DIMENSIONS'
 428 #ifndef ISNAN
 429       external proc_proc
 430 #ifdef WINPGI
 431 cMS$ATTRIBUTES C ::  proc_proc
 432 #endif
 433 #endif
 434 #ifdef MPI
 435       include 'mpif.h'
 436       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 437      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 438 #endif
 439       include 'COMMON.SETUP'
 440       include 'COMMON.IOUNITS'
 441       include 'COMMON.FFIELD'
 442       include 'COMMON.DERIV'
 443       include 'COMMON.INTERACT'
 444       include 'COMMON.SBRIDGE'
 445       include 'COMMON.CHAIN'
 446       include 'COMMON.VAR'
 447       include 'COMMON.CONTROL'
 448       include 'COMMON.TIME1'
 449       include 'COMMON.MAXGRAD'
 450 #ifdef TIMING
 451       time01=MPI_Wtime()
 452 #endif
 453 #ifdef DEBUG
 454       write (iout,*) "sum_gradient gvdwc, gvdwx"
 455       do i=1,nres
 456         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 457      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 458       enddo
 459       call flush(iout)
 460 #endif
 461 #ifdef MPI
 462 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 463         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 464      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 465 #endif
 466 C
 467 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 468 C            in virtual-bond-vector coordinates
 469 C
 470 #ifdef DEBUG
 471 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 472 c      do i=1,nres-1
 473 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 474 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 475 c      enddo
 476 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 477 c      do i=1,nres-1
 478 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 479 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 480 c      enddo
 481       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 482       do i=1,nres
 483         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 484      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 485      &   g_corr5_loc(i)
 486       enddo
 487       call flush(iout)
 488 #endif
 489 #ifdef SPLITELE
 490       do i=1,nct
 491         do j=1,3
 492           gradbufc(j,i)=wsc*gvdwc(j,i)+
 493      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 494      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 495      &                wel_loc*gel_loc_long(j,i)+
 496      &                wcorr*gradcorr_long(j,i)+
 497      &                wcorr5*gradcorr5_long(j,i)+
 498      &                wcorr6*gradcorr6_long(j,i)+
 499      &                wturn6*gcorr6_turn_long(j,i)+
 500      &                wstrain*ghpbc(j,i)
 501         enddo
 502       enddo
 503 #else
 504       do i=1,nct
 505         do j=1,3
 506           gradbufc(j,i)=wsc*gvdwc(j,i)+
 507      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 508      &                welec*gelc_long(j,i)+
 509      &                wbond*gradb(j,i)+
 510      &                wel_loc*gel_loc_long(j,i)+
 511      &                wcorr*gradcorr_long(j,i)+
 512      &                wcorr5*gradcorr5_long(j,i)+
 513      &                wcorr6*gradcorr6_long(j,i)+
 514      &                wturn6*gcorr6_turn_long(j,i)+
 515      &                wstrain*ghpbc(j,i)
 516         enddo
 517       enddo
 518 #endif
 519 #ifdef MPI
 520       if (nfgtasks.gt.1) then
 521       time00=MPI_Wtime()
 522 #ifdef DEBUG
 523       write (iout,*) "gradbufc before allreduce"
 524       do i=1,nres
 525         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 526       enddo
 527       call flush(iout)
 528 #endif
 529       call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 530      &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 531       time_reduce=time_reduce+MPI_Wtime()-time00
 532 #ifdef DEBUG
 533       write (iout,*) "gradbufc_sum after allreduce"
 534       do i=1,nres
 535         write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 536       enddo
 537       call flush(iout)
 538 #endif
 539 #ifdef TIMING
 540       time_allreduce=time_allreduce+MPI_Wtime()-time00
 541 #endif
 542       do i=nnt,nres
 543         do k=1,3
 544           gradbufc(k,i)=0.0d0
 545         enddo
 546       enddo
 547       do i=igrad_start,igrad_end
 548         do j=jgrad_start(i),jgrad_end(i)
 549           do k=1,3
 550             gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 551           enddo
 552         enddo
 553       enddo
 554       else
 555 #endif
 556 #ifdef DEBUG
 557       write (iout,*) "gradbufc"
 558       do i=1,nres
 559         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 560       enddo
 561       call flush(iout)
 562 #endif
 563       do i=nnt,nres-1
 564         do k=1,3
 565           gradbufc(k,i)=0.0d0
 566         enddo
 567         do j=i+1,nres
 568           do k=1,3
 569             gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 570           enddo
 571         enddo
 572       enddo
 573 #ifdef MPI
 574       endif
 575 #endif
 576       do k=1,3
 577         gradbufc(k,nres)=0.0d0
 578       enddo
 579       do i=1,nct
 580         do j=1,3
 581 #ifdef SPLITELE
 582           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 583      &                wel_loc*gel_loc(j,i)+
 584      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 585      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 586      &                wel_loc*gel_loc_long(j,i)+
 587      &                wcorr*gradcorr_long(j,i)+
 588      &                wcorr5*gradcorr5_long(j,i)+
 589      &                wcorr6*gradcorr6_long(j,i)+
 590      &                wturn6*gcorr6_turn_long(j,i))+
 591      &                wbond*gradb(j,i)+
 592      &                wcorr*gradcorr(j,i)+
 593      &                wturn3*gcorr3_turn(j,i)+
 594      &                wturn4*gcorr4_turn(j,i)+
 595      &                wcorr5*gradcorr5(j,i)+
 596      &                wcorr6*gradcorr6(j,i)+
 597      &                wturn6*gcorr6_turn(j,i)+
 598      &                wsccor*gsccorc(j,i)
 599      &               +wscloc*gscloc(j,i)
 600 #else
 601           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 602      &                wel_loc*gel_loc(j,i)+
 603      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 604      &                welec*gelc_long(j,i)
 605      &                wel_loc*gel_loc_long(j,i)+
 606      &                wcorr*gcorr_long(j,i)+
 607      &                wcorr5*gradcorr5_long(j,i)+
 608      &                wcorr6*gradcorr6_long(j,i)+
 609      &                wturn6*gcorr6_turn_long(j,i))+
 610      &                wbond*gradb(j,i)+
 611      &                wcorr*gradcorr(j,i)+
 612      &                wturn3*gcorr3_turn(j,i)+
 613      &                wturn4*gcorr4_turn(j,i)+
 614      &                wcorr5*gradcorr5(j,i)+
 615      &                wcorr6*gradcorr6(j,i)+
 616      &                wturn6*gcorr6_turn(j,i)+
 617      &                wsccor*gsccorc(j,i)
 618      &               +wscloc*gscloc(j,i)
 619 #endif
 620           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 621      &                  wbond*gradbx(j,i)+
 622      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 623      &                  wsccor*gsccorx(j,i)
 624      &                 +wscloc*gsclocx(j,i)
 625         enddo
 626       enddo
 627 #ifdef DEBUG
 628       write (iout,*) "gloc before adding corr"
 629       do i=1,4*nres
 630         write (iout,*) i,gloc(i,icg)
 631       enddo
 632 #endif
 633       do i=1,nres-3
 634         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 635      &   +wcorr5*g_corr5_loc(i)
 636      &   +wcorr6*g_corr6_loc(i)
 637      &   +wturn4*gel_loc_turn4(i)
 638      &   +wturn3*gel_loc_turn3(i)
 639      &   +wturn6*gel_loc_turn6(i)
 640      &   +wel_loc*gel_loc_loc(i)
 641      &   +wsccor*gsccor_loc(i)
 642       enddo
 643 #ifdef DEBUG
 644       write (iout,*) "gloc after adding corr"
 645       do i=1,4*nres
 646         write (iout,*) i,gloc(i,icg)
 647       enddo
 648 #endif
 649 #ifdef MPI
 650       if (nfgtasks.gt.1) then
 651         do j=1,3
 652           do i=1,nres
 653             gradbufc(j,i)=gradc(j,i,icg)
 654             gradbufx(j,i)=gradx(j,i,icg)
 655           enddo
 656         enddo
 657         do i=1,4*nres
 658           glocbuf(i)=gloc(i,icg)
 659         enddo
 660         time00=MPI_Wtime()
 661         call MPI_Barrier(FG_COMM,IERR)
 662         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 663         time00=MPI_Wtime()
 664         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 665      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 666         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 667      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 668         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 669      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 670         time_reduce=time_reduce+MPI_Wtime()-time00
 671 #ifdef DEBUG
 672       write (iout,*) "gloc after reduce"
 673       do i=1,4*nres
 674         write (iout,*) i,gloc(i,icg)
 675       enddo
 676 #endif
 677       endif
 678 #endif
 679       if (gnorm_check) then
 680 c
 681 c Compute the maximum elements of the gradient
 682 c
 683       gvdwc_max=0.0d0
 684       gvdwc_scp_max=0.0d0
 685       gelc_max=0.0d0
 686       gvdwpp_max=0.0d0
 687       gradb_max=0.0d0
 688       ghpbc_max=0.0d0
 689       gradcorr_max=0.0d0
 690       gel_loc_max=0.0d0
 691       gcorr3_turn_max=0.0d0
 692       gcorr4_turn_max=0.0d0
 693       gradcorr5_max=0.0d0
 694       gradcorr6_max=0.0d0
 695       gcorr6_turn_max=0.0d0
 696       gsccorc_max=0.0d0
 697       gscloc_max=0.0d0
 698       gvdwx_max=0.0d0
 699       gradx_scp_max=0.0d0
 700       ghpbx_max=0.0d0
 701       gradxorr_max=0.0d0
 702       gsccorx_max=0.0d0
 703       gsclocx_max=0.0d0
 704       do i=1,nct
 705         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 706         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 707         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 708         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 709      &   gvdwc_scp_max=gvdwc_scp_norm
 710         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 711         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 712         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 713         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 714         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 715         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 716         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 717         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 718         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 719         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 720         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 721         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 722         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 723      &    gcorr3_turn(1,i)))
 724         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 725      &    gcorr3_turn_max=gcorr3_turn_norm
 726         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 727      &    gcorr4_turn(1,i)))
 728         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 729      &    gcorr4_turn_max=gcorr4_turn_norm
 730         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 731         if (gradcorr5_norm.gt.gradcorr5_max)
 732      &    gradcorr5_max=gradcorr5_norm
 733         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 734         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 735         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 736      &    gcorr6_turn(1,i)))
 737         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 738      &    gcorr6_turn_max=gcorr6_turn_norm
 739         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 740         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 741         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 742         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 743         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 744         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 745         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 746         if (gradx_scp_norm.gt.gradx_scp_max)
 747      &    gradx_scp_max=gradx_scp_norm
 748         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 749         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 750         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 751         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 752         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 753         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 754         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 755         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 756       enddo
 757       if (gradout) then
 758 #ifdef AIX
 759         open(istat,file=statname,position="append")
 760 #else
 761         open(istat,file=statname,access="append")
 762 #endif
 763         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 764      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 765      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 766      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 767      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 768      &     gsccorx_max,gsclocx_max
 769         close(istat)
 770         if (gvdwc_max.gt.1.0d4) then
 771           write (iout,*) "gvdwc gvdwx gradb gradbx"
 772           do i=nnt,nct
 773             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 774      &        gradb(j,i),gradbx(j,i),j=1,3)
 775           enddo
 776           call pdbout(0.0d0,'cipiszcze',iout)
 777           call flush(iout)
 778         endif
 779       endif
 780       endif
 781 #ifdef DEBUG
 782       write (iout,*) "gradc gradx gloc"
 783       do i=1,nres
 784         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 785      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 786       enddo
 787 #endif
 788 #ifdef TIMING
 789       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 790 #endif
 791       return
 792       end
 793 c-------------------------------------------------------------------------------
 794       subroutine rescale_weights(t_bath)
 795       implicit real*8 (a-h,o-z)
 796       include 'DIMENSIONS'
 797       include 'COMMON.IOUNITS'
 798       include 'COMMON.FFIELD'
 799       include 'COMMON.SBRIDGE'
 800       double precision kfac /2.4d0/
 801       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 802 c      facT=temp0/t_bath
 803 c      facT=2*temp0/(t_bath+temp0)
 804       if (rescale_mode.eq.0) then
 805         facT=1.0d0
 806         facT2=1.0d0
 807         facT3=1.0d0
 808         facT4=1.0d0
 809         facT5=1.0d0
 810       else if (rescale_mode.eq.1) then
 811         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 812         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 813         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 814         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 815         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 816       else if (rescale_mode.eq.2) then
 817         x=t_bath/temp0
 818         x2=x*x
 819         x3=x2*x
 820         x4=x3*x
 821         x5=x4*x
 822         facT=licznik/dlog(dexp(x)+dexp(-x))
 823         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 824         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 825         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 826         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 827       else
 828         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 829         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 830 #ifdef MPI
 831        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 832 #endif
 833        stop 555
 834       endif
 835       welec=weights(3)*fact
 836       wcorr=weights(4)*fact3
 837       wcorr5=weights(5)*fact4
 838       wcorr6=weights(6)*fact5
 839       wel_loc=weights(7)*fact2
 840       wturn3=weights(8)*fact2
 841       wturn4=weights(9)*fact3
 842       wturn6=weights(10)*fact5
 843       wtor=weights(13)*fact
 844       wtor_d=weights(14)*fact2
 845       wsccor=weights(21)*fact
 846
 847       return
 848       end
 849 C------------------------------------------------------------------------
 850       subroutine enerprint(energia)
 851       implicit real*8 (a-h,o-z)
 852       include 'DIMENSIONS'
 853       include 'COMMON.IOUNITS'
 854       include 'COMMON.FFIELD'
 855       include 'COMMON.SBRIDGE'
 856       include 'COMMON.MD'
 857       double precision energia(0:n_ene)
 858       etot=energia(0)
 859       evdw=energia(1)
 860       evdw2=energia(2)
 861 #ifdef SCP14
 862       evdw2=energia(2)+energia(18)
 863 #else
 864       evdw2=energia(2)
 865 #endif
 866       ees=energia(3)
 867 #ifdef SPLITELE
 868       evdw1=energia(16)
 869 #endif
 870       ecorr=energia(4)
 871       ecorr5=energia(5)
 872       ecorr6=energia(6)
 873       eel_loc=energia(7)
 874       eello_turn3=energia(8)
 875       eello_turn4=energia(9)
 876       eello_turn6=energia(10)
 877       ebe=energia(11)
 878       escloc=energia(12)
 879       etors=energia(13)
 880       etors_d=energia(14)
 881       ehpb=energia(15)
 882       edihcnstr=energia(19)
 883       estr=energia(17)
 884       Uconst=energia(20)
 885       esccor=energia(21)
 886 #ifdef SPLITELE
 887       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 888      &  estr,wbond,ebe,wang,
 889      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 890      &  ecorr,wcorr,
 891      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 892      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 893      &  edihcnstr,ebr*nss,
 894      &  Uconst,etot
 895    10 format (/'Virtual-chain energies:'//
 896      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 897      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 898      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 899      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 900      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 901      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 902      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 903      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 904      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 905      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 906      & ' (SS bridges & dist. cnstr.)'/
 907      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 908      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 909      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 910      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 911      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 912      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 913      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 914      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 915      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 916      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 917      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 918      & 'ETOT=  ',1pE16.6,' (total)')
 919 #else
 920       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 921      &  estr,wbond,ebe,wang,
 922      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 923      &  ecorr,wcorr,
 924      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 925      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 926      &  ebr*nss,Uconst,etot
 927    10 format (/'Virtual-chain energies:'//
 928      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 929      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 930      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 931      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 932      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 933      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 934      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 935      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 936      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 937      & ' (SS bridges & dist. cnstr.)'/
 938      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 939      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 940      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 941      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 942      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 943      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 944      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 945      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 946      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 947      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 948      & 'UCONST=',1pE16.6,' (Constraint energy)'/
 949      & 'ETOT=  ',1pE16.6,' (total)')
 950 #endif
 951       return
 952       end
 953 C-----------------------------------------------------------------------
 954       subroutine elj(evdw)
 955 C
 956 C This subroutine calculates the interaction energy of nonbonded side chains
 957 C assuming the LJ potential of interaction.
 958 C
 959       implicit real*8 (a-h,o-z)
 960       include 'DIMENSIONS'
 961       parameter (accur=1.0d-10)
 962       include 'COMMON.GEO'
 963       include 'COMMON.VAR'
 964       include 'COMMON.LOCAL'
 965       include 'COMMON.CHAIN'
 966       include 'COMMON.DERIV'
 967       include 'COMMON.INTERACT'
 968       include 'COMMON.TORSION'
 969       include 'COMMON.SBRIDGE'
 970       include 'COMMON.NAMES'
 971       include 'COMMON.IOUNITS'
 972       include 'COMMON.CONTACTS'
 973       dimension gg(3)
 974 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 975       evdw=0.0D0
 976       do i=iatsc_s,iatsc_e
 977         itypi=itype(i)
 978         itypi1=itype(i+1)
 979         xi=c(1,nres+i)
 980         yi=c(2,nres+i)
 981         zi=c(3,nres+i)
 982 C Change 12/1/95
 983         num_conti=0
 984 C
 985 C Calculate SC interaction energy.
 986 C
 987         do iint=1,nint_gr(i)
 988 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 989 cd   &                  'iend=',iend(i,iint)
 990           do j=istart(i,iint),iend(i,iint)
 991             itypj=itype(j)
 992             xj=c(1,nres+j)-xi
 993             yj=c(2,nres+j)-yi
 994             zj=c(3,nres+j)-zi
 995 C Change 12/1/95 to calculate four-body interactions
 996             rij=xj*xj+yj*yj+zj*zj
 997             rrij=1.0D0/rij
 998 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 999             eps0ij=eps(itypi,itypj)
1000             fac=rrij**expon2
1001             e1=fac*fac*aa(itypi,itypj)
1002             e2=fac*bb(itypi,itypj)
1003             evdwij=e1+e2
1004 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1005 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1006 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1007 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1008 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1009 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1010             evdw=evdw+evdwij
1011 C
1012 C Calculate the components of the gradient in DC and X
1013 C
1014             fac=-rrij*(e1+evdwij)
1015             gg(1)=xj*fac
1016             gg(2)=yj*fac
1017             gg(3)=zj*fac
1018             do k=1,3
1019               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1020               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1021               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1022               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1023             enddo
1024 cgrad            do k=i,j-1
1025 cgrad              do l=1,3
1026 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1027 cgrad              enddo
1028 cgrad            enddo
1029 C
1030 C 12/1/95, revised on 5/20/97
1031 C
1032 C Calculate the contact function. The ith column of the array JCONT will
1033 C contain the numbers of atoms that make contacts with the atom I (of numbers
1034 C greater than I). The arrays FACONT and GACONT will contain the values of
1035 C the contact function and its derivative.
1036 C
1037 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1038 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1039 C Uncomment next line, if the correlation interactions are contact function only
1040             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1041               rij=dsqrt(rij)
1042               sigij=sigma(itypi,itypj)
1043               r0ij=rs0(itypi,itypj)
1044 C
1045 C Check whether the SC's are not too far to make a contact.
1046 C
1047               rcut=1.5d0*r0ij
1048               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1049 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1050 C
1051               if (fcont.gt.0.0D0) then
1052 C If the SC-SC distance if close to sigma, apply spline.
1053 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1054 cAdam &             fcont1,fprimcont1)
1055 cAdam           fcont1=1.0d0-fcont1
1056 cAdam           if (fcont1.gt.0.0d0) then
1057 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1058 cAdam             fcont=fcont*fcont1
1059 cAdam           endif
1060 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1061 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1062 cga             do k=1,3
1063 cga               gg(k)=gg(k)*eps0ij
1064 cga             enddo
1065 cga             eps0ij=-evdwij*eps0ij
1066 C Uncomment for AL's type of SC correlation interactions.
1067 cadam           eps0ij=-evdwij
1068                 num_conti=num_conti+1
1069                 jcont(num_conti,i)=j
1070                 facont(num_conti,i)=fcont*eps0ij
1071                 fprimcont=eps0ij*fprimcont/rij
1072                 fcont=expon*fcont
1073 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1074 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1075 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1076 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1077                 gacont(1,num_conti,i)=-fprimcont*xj
1078                 gacont(2,num_conti,i)=-fprimcont*yj
1079                 gacont(3,num_conti,i)=-fprimcont*zj
1080 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1081 cd              write (iout,'(2i3,3f10.5)')
1082 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1083               endif
1084             endif
1085           enddo      ! j
1086         enddo        ! iint
1087 C Change 12/1/95
1088         num_cont(i)=num_conti
1089       enddo          ! i
1090       do i=1,nct
1091         do j=1,3
1092           gvdwc(j,i)=expon*gvdwc(j,i)
1093           gvdwx(j,i)=expon*gvdwx(j,i)
1094         enddo
1095       enddo
1096 C******************************************************************************
1097 C
1098 C                              N O T E !!!
1099 C
1100 C To save time, the factor of EXPON has been extracted from ALL components
1101 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1102 C use!
1103 C
1104 C******************************************************************************
1105       return
1106       end
1107 C-----------------------------------------------------------------------------
1108       subroutine eljk(evdw)
1109 C
1110 C This subroutine calculates the interaction energy of nonbonded side chains
1111 C assuming the LJK potential of interaction.
1112 C
1113       implicit real*8 (a-h,o-z)
1114       include 'DIMENSIONS'
1115       include 'COMMON.GEO'
1116       include 'COMMON.VAR'
1117       include 'COMMON.LOCAL'
1118       include 'COMMON.CHAIN'
1119       include 'COMMON.DERIV'
1120       include 'COMMON.INTERACT'
1121       include 'COMMON.IOUNITS'
1122       include 'COMMON.NAMES'
1123       dimension gg(3)
1124       logical scheck
1125 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1126       evdw=0.0D0
1127       do i=iatsc_s,iatsc_e
1128         itypi=itype(i)
1129         itypi1=itype(i+1)
1130         xi=c(1,nres+i)
1131         yi=c(2,nres+i)
1132         zi=c(3,nres+i)
1133 C
1134 C Calculate SC interaction energy.
1135 C
1136         do iint=1,nint_gr(i)
1137           do j=istart(i,iint),iend(i,iint)
1138             itypj=itype(j)
1139             xj=c(1,nres+j)-xi
1140             yj=c(2,nres+j)-yi
1141             zj=c(3,nres+j)-zi
1142             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1143             fac_augm=rrij**expon
1144             e_augm=augm(itypi,itypj)*fac_augm
1145             r_inv_ij=dsqrt(rrij)
1146             rij=1.0D0/r_inv_ij
1147             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1148             fac=r_shift_inv**expon
1149             e1=fac*fac*aa(itypi,itypj)
1150             e2=fac*bb(itypi,itypj)
1151             evdwij=e_augm+e1+e2
1152 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1153 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1154 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1155 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1156 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1157 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1158 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1159             evdw=evdw+evdwij
1160 C
1161 C Calculate the components of the gradient in DC and X
1162 C
1163             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1164             gg(1)=xj*fac
1165             gg(2)=yj*fac
1166             gg(3)=zj*fac
1167             do k=1,3
1168               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1169               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1170               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1171               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1172             enddo
1173 cgrad            do k=i,j-1
1174 cgrad              do l=1,3
1175 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1176 cgrad              enddo
1177 cgrad            enddo
1178           enddo      ! j
1179         enddo        ! iint
1180       enddo          ! i
1181       do i=1,nct
1182         do j=1,3
1183           gvdwc(j,i)=expon*gvdwc(j,i)
1184           gvdwx(j,i)=expon*gvdwx(j,i)
1185         enddo
1186       enddo
1187       return
1188       end
1189 C-----------------------------------------------------------------------------
1190       subroutine ebp(evdw)
1191 C
1192 C This subroutine calculates the interaction energy of nonbonded side chains
1193 C assuming the Berne-Pechukas potential of interaction.
1194 C
1195       implicit real*8 (a-h,o-z)
1196       include 'DIMENSIONS'
1197       include 'COMMON.GEO'
1198       include 'COMMON.VAR'
1199       include 'COMMON.LOCAL'
1200       include 'COMMON.CHAIN'
1201       include 'COMMON.DERIV'
1202       include 'COMMON.NAMES'
1203       include 'COMMON.INTERACT'
1204       include 'COMMON.IOUNITS'
1205       include 'COMMON.CALC'
1206       common /srutu/ icall
1207 c     double precision rrsave(maxdim)
1208       logical lprn
1209       evdw=0.0D0
1210 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1211       evdw=0.0D0
1212 c     if (icall.eq.0) then
1213 c       lprn=.true.
1214 c     else
1215         lprn=.false.
1216 c     endif
1217       ind=0
1218       do i=iatsc_s,iatsc_e
1219         itypi=itype(i)
1220         itypi1=itype(i+1)
1221         xi=c(1,nres+i)
1222         yi=c(2,nres+i)
1223         zi=c(3,nres+i)
1224         dxi=dc_norm(1,nres+i)
1225         dyi=dc_norm(2,nres+i)
1226         dzi=dc_norm(3,nres+i)
1227 c        dsci_inv=dsc_inv(itypi)
1228         dsci_inv=vbld_inv(i+nres)
1229 C
1230 C Calculate SC interaction energy.
1231 C
1232         do iint=1,nint_gr(i)
1233           do j=istart(i,iint),iend(i,iint)
1234             ind=ind+1
1235             itypj=itype(j)
1236 c            dscj_inv=dsc_inv(itypj)
1237             dscj_inv=vbld_inv(j+nres)
1238             chi1=chi(itypi,itypj)
1239             chi2=chi(itypj,itypi)
1240             chi12=chi1*chi2
1241             chip1=chip(itypi)
1242             chip2=chip(itypj)
1243             chip12=chip1*chip2
1244             alf1=alp(itypi)
1245             alf2=alp(itypj)
1246             alf12=0.5D0*(alf1+alf2)
1247 C For diagnostics only!!!
1248 c           chi1=0.0D0
1249 c           chi2=0.0D0
1250 c           chi12=0.0D0
1251 c           chip1=0.0D0
1252 c           chip2=0.0D0
1253 c           chip12=0.0D0
1254 c           alf1=0.0D0
1255 c           alf2=0.0D0
1256 c           alf12=0.0D0
1257             xj=c(1,nres+j)-xi
1258             yj=c(2,nres+j)-yi
1259             zj=c(3,nres+j)-zi
1260             dxj=dc_norm(1,nres+j)
1261             dyj=dc_norm(2,nres+j)
1262             dzj=dc_norm(3,nres+j)
1263             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1264 cd          if (icall.eq.0) then
1265 cd            rrsave(ind)=rrij
1266 cd          else
1267 cd            rrij=rrsave(ind)
1268 cd          endif
1269             rij=dsqrt(rrij)
1270 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1271             call sc_angular
1272 C Calculate whole angle-dependent part of epsilon and contributions
1273 C to its derivatives
1274             fac=(rrij*sigsq)**expon2
1275             e1=fac*fac*aa(itypi,itypj)
1276             e2=fac*bb(itypi,itypj)
1277             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1278             eps2der=evdwij*eps3rt
1279             eps3der=evdwij*eps2rt
1280             evdwij=evdwij*eps2rt*eps3rt
1281             evdw=evdw+evdwij
1282             if (lprn) then
1283             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1284             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1285 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1286 cd     &        restyp(itypi),i,restyp(itypj),j,
1287 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1288 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1289 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1290 cd     &        evdwij
1291             endif
1292 C Calculate gradient components.
1293             e1=e1*eps1*eps2rt**2*eps3rt**2
1294             fac=-expon*(e1+evdwij)
1295             sigder=fac/sigsq
1296             fac=rrij*fac
1297 C Calculate radial part of the gradient
1298             gg(1)=xj*fac
1299             gg(2)=yj*fac
1300             gg(3)=zj*fac
1301 C Calculate the angular part of the gradient and sum add the contributions
1302 C to the appropriate components of the Cartesian gradient.
1303             call sc_grad
1304           enddo      ! j
1305         enddo        ! iint
1306       enddo          ! i
1307 c     stop
1308       return
1309       end
1310 C-----------------------------------------------------------------------------
1311       subroutine egb(evdw)
1312 C
1313 C This subroutine calculates the interaction energy of nonbonded side chains
1314 C assuming the Gay-Berne potential of interaction.
1315 C
1316       implicit real*8 (a-h,o-z)
1317       include 'DIMENSIONS'
1318       include 'COMMON.GEO'
1319       include 'COMMON.VAR'
1320       include 'COMMON.LOCAL'
1321       include 'COMMON.CHAIN'
1322       include 'COMMON.DERIV'
1323       include 'COMMON.NAMES'
1324       include 'COMMON.INTERACT'
1325       include 'COMMON.IOUNITS'
1326       include 'COMMON.CALC'
1327       include 'COMMON.CONTROL'
1328       logical lprn
1329       evdw=0.0D0
1330 ccccc      energy_dec=.false.
1331 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1332       evdw=0.0D0
1333       lprn=.false.
1334 c     if (icall.eq.0) lprn=.false.
1335       ind=0
1336       do i=iatsc_s,iatsc_e
1337         itypi=itype(i)
1338         itypi1=itype(i+1)
1339         xi=c(1,nres+i)
1340         yi=c(2,nres+i)
1341         zi=c(3,nres+i)
1342         dxi=dc_norm(1,nres+i)
1343         dyi=dc_norm(2,nres+i)
1344         dzi=dc_norm(3,nres+i)
1345 c        dsci_inv=dsc_inv(itypi)
1346         dsci_inv=vbld_inv(i+nres)
1347 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1348 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1349 C
1350 C Calculate SC interaction energy.
1351 C
1352         do iint=1,nint_gr(i)
1353           do j=istart(i,iint),iend(i,iint)
1354             ind=ind+1
1355             itypj=itype(j)
1356 c            dscj_inv=dsc_inv(itypj)
1357             dscj_inv=vbld_inv(j+nres)
1358 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1359 c     &       1.0d0/vbld(j+nres)
1360 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1361             sig0ij=sigma(itypi,itypj)
1362             chi1=chi(itypi,itypj)
1363             chi2=chi(itypj,itypi)
1364             chi12=chi1*chi2
1365             chip1=chip(itypi)
1366             chip2=chip(itypj)
1367             chip12=chip1*chip2
1368             alf1=alp(itypi)
1369             alf2=alp(itypj)
1370             alf12=0.5D0*(alf1+alf2)
1371 C For diagnostics only!!!
1372 c           chi1=0.0D0
1373 c           chi2=0.0D0
1374 c           chi12=0.0D0
1375 c           chip1=0.0D0
1376 c           chip2=0.0D0
1377 c           chip12=0.0D0
1378 c           alf1=0.0D0
1379 c           alf2=0.0D0
1380 c           alf12=0.0D0
1381             xj=c(1,nres+j)-xi
1382             yj=c(2,nres+j)-yi
1383             zj=c(3,nres+j)-zi
1384             dxj=dc_norm(1,nres+j)
1385             dyj=dc_norm(2,nres+j)
1386             dzj=dc_norm(3,nres+j)
1387 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1388 c            write (iout,*) "j",j," dc_norm",
1389 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1390             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1391             rij=dsqrt(rrij)
1392 C Calculate angle-dependent terms of energy and contributions to their
1393 C derivatives.
1394             call sc_angular
1395             sigsq=1.0D0/sigsq
1396             sig=sig0ij*dsqrt(sigsq)
1397             rij_shift=1.0D0/rij-sig+sig0ij
1398 c for diagnostics; uncomment
1399 c            rij_shift=1.2*sig0ij
1400 C I hate to put IF's in the loops, but here don't have another choice!!!!
1401             if (rij_shift.le.0.0D0) then
1402               evdw=1.0D20
1403 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1404 cd     &        restyp(itypi),i,restyp(itypj),j,
1405 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1406               return
1407             endif
1408             sigder=-sig*sigsq
1409 c---------------------------------------------------------------
1410             rij_shift=1.0D0/rij_shift
1411             fac=rij_shift**expon
1412             e1=fac*fac*aa(itypi,itypj)
1413             e2=fac*bb(itypi,itypj)
1414             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1415             eps2der=evdwij*eps3rt
1416             eps3der=evdwij*eps2rt
1417 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1418 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1419             evdwij=evdwij*eps2rt*eps3rt
1420             evdw=evdw+evdwij
1421             if (lprn) then
1422             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1423             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1424             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1425      &        restyp(itypi),i,restyp(itypj),j,
1426      &        epsi,sigm,chi1,chi2,chip1,chip2,
1427      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1428      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1429      &        evdwij
1430             endif
1431
1432             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1433      &                        'evdw',i,j,evdwij
1434
1435 C Calculate gradient components.
1436             e1=e1*eps1*eps2rt**2*eps3rt**2
1437             fac=-expon*(e1+evdwij)*rij_shift
1438             sigder=fac*sigder
1439             fac=rij*fac
1440 c            fac=0.0d0
1441 C Calculate the radial part of the gradient
1442             gg(1)=xj*fac
1443             gg(2)=yj*fac
1444             gg(3)=zj*fac
1445 C Calculate angular part of the gradient.
1446             call sc_grad
1447           enddo      ! j
1448         enddo        ! iint
1449       enddo          ! i
1450 c      write (iout,*) "Number of loop steps in EGB:",ind
1451 cccc      energy_dec=.false.
1452       return
1453       end
1454 C-----------------------------------------------------------------------------
1455       subroutine egbv(evdw)
1456 C
1457 C This subroutine calculates the interaction energy of nonbonded side chains
1458 C assuming the Gay-Berne-Vorobjev potential of interaction.
1459 C
1460       implicit real*8 (a-h,o-z)
1461       include 'DIMENSIONS'
1462       include 'COMMON.GEO'
1463       include 'COMMON.VAR'
1464       include 'COMMON.LOCAL'
1465       include 'COMMON.CHAIN'
1466       include 'COMMON.DERIV'
1467       include 'COMMON.NAMES'
1468       include 'COMMON.INTERACT'
1469       include 'COMMON.IOUNITS'
1470       include 'COMMON.CALC'
1471       common /srutu/ icall
1472       logical lprn
1473       evdw=0.0D0
1474 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1475       evdw=0.0D0
1476       lprn=.false.
1477 c     if (icall.eq.0) lprn=.true.
1478       ind=0
1479       do i=iatsc_s,iatsc_e
1480         itypi=itype(i)
1481         itypi1=itype(i+1)
1482         xi=c(1,nres+i)
1483         yi=c(2,nres+i)
1484         zi=c(3,nres+i)
1485         dxi=dc_norm(1,nres+i)
1486         dyi=dc_norm(2,nres+i)
1487         dzi=dc_norm(3,nres+i)
1488 c        dsci_inv=dsc_inv(itypi)
1489         dsci_inv=vbld_inv(i+nres)
1490 C
1491 C Calculate SC interaction energy.
1492 C
1493         do iint=1,nint_gr(i)
1494           do j=istart(i,iint),iend(i,iint)
1495             ind=ind+1
1496             itypj=itype(j)
1497 c            dscj_inv=dsc_inv(itypj)
1498             dscj_inv=vbld_inv(j+nres)
1499             sig0ij=sigma(itypi,itypj)
1500             r0ij=r0(itypi,itypj)
1501             chi1=chi(itypi,itypj)
1502             chi2=chi(itypj,itypi)
1503             chi12=chi1*chi2
1504             chip1=chip(itypi)
1505             chip2=chip(itypj)
1506             chip12=chip1*chip2
1507             alf1=alp(itypi)
1508             alf2=alp(itypj)
1509             alf12=0.5D0*(alf1+alf2)
1510 C For diagnostics only!!!
1511 c           chi1=0.0D0
1512 c           chi2=0.0D0
1513 c           chi12=0.0D0
1514 c           chip1=0.0D0
1515 c           chip2=0.0D0
1516 c           chip12=0.0D0
1517 c           alf1=0.0D0
1518 c           alf2=0.0D0
1519 c           alf12=0.0D0
1520             xj=c(1,nres+j)-xi
1521             yj=c(2,nres+j)-yi
1522             zj=c(3,nres+j)-zi
1523             dxj=dc_norm(1,nres+j)
1524             dyj=dc_norm(2,nres+j)
1525             dzj=dc_norm(3,nres+j)
1526             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1527             rij=dsqrt(rrij)
1528 C Calculate angle-dependent terms of energy and contributions to their
1529 C derivatives.
1530             call sc_angular
1531             sigsq=1.0D0/sigsq
1532             sig=sig0ij*dsqrt(sigsq)
1533             rij_shift=1.0D0/rij-sig+r0ij
1534 C I hate to put IF's in the loops, but here don't have another choice!!!!
1535             if (rij_shift.le.0.0D0) then
1536               evdw=1.0D20
1537               return
1538             endif
1539             sigder=-sig*sigsq
1540 c---------------------------------------------------------------
1541             rij_shift=1.0D0/rij_shift
1542             fac=rij_shift**expon
1543             e1=fac*fac*aa(itypi,itypj)
1544             e2=fac*bb(itypi,itypj)
1545             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1546             eps2der=evdwij*eps3rt
1547             eps3der=evdwij*eps2rt
1548             fac_augm=rrij**expon
1549             e_augm=augm(itypi,itypj)*fac_augm
1550             evdwij=evdwij*eps2rt*eps3rt
1551             evdw=evdw+evdwij+e_augm
1552             if (lprn) then
1553             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1554             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1555             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1556      &        restyp(itypi),i,restyp(itypj),j,
1557      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1558      &        chi1,chi2,chip1,chip2,
1559      &        eps1,eps2rt**2,eps3rt**2,
1560      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1561      &        evdwij+e_augm
1562             endif
1563 C Calculate gradient components.
1564             e1=e1*eps1*eps2rt**2*eps3rt**2
1565             fac=-expon*(e1+evdwij)*rij_shift
1566             sigder=fac*sigder
1567             fac=rij*fac-2*expon*rrij*e_augm
1568 C Calculate the radial part of the gradient
1569             gg(1)=xj*fac
1570             gg(2)=yj*fac
1571             gg(3)=zj*fac
1572 C Calculate angular part of the gradient.
1573             call sc_grad
1574           enddo      ! j
1575         enddo        ! iint
1576       enddo          ! i
1577       end
1578 C-----------------------------------------------------------------------------
1579       subroutine sc_angular
1580 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1581 C om12. Called by ebp, egb, and egbv.
1582       implicit none
1583       include 'COMMON.CALC'
1584       include 'COMMON.IOUNITS'
1585       erij(1)=xj*rij
1586       erij(2)=yj*rij
1587       erij(3)=zj*rij
1588       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1589       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1590       om12=dxi*dxj+dyi*dyj+dzi*dzj
1591       chiom12=chi12*om12
1592 C Calculate eps1(om12) and its derivative in om12
1593       faceps1=1.0D0-om12*chiom12
1594       faceps1_inv=1.0D0/faceps1
1595       eps1=dsqrt(faceps1_inv)
1596 C Following variable is eps1*deps1/dom12
1597       eps1_om12=faceps1_inv*chiom12
1598 c diagnostics only
1599 c      faceps1_inv=om12
1600 c      eps1=om12
1601 c      eps1_om12=1.0d0
1602 c      write (iout,*) "om12",om12," eps1",eps1
1603 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1604 C and om12.
1605       om1om2=om1*om2
1606       chiom1=chi1*om1
1607       chiom2=chi2*om2
1608       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1609       sigsq=1.0D0-facsig*faceps1_inv
1610       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1611       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1612       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1613 c diagnostics only
1614 c      sigsq=1.0d0
1615 c      sigsq_om1=0.0d0
1616 c      sigsq_om2=0.0d0
1617 c      sigsq_om12=0.0d0
1618 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1619 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1620 c     &    " eps1",eps1
1621 C Calculate eps2 and its derivatives in om1, om2, and om12.
1622       chipom1=chip1*om1
1623       chipom2=chip2*om2
1624       chipom12=chip12*om12
1625       facp=1.0D0-om12*chipom12
1626       facp_inv=1.0D0/facp
1627       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1628 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1629 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1630 C Following variable is the square root of eps2
1631       eps2rt=1.0D0-facp1*facp_inv
1632 C Following three variables are the derivatives of the square root of eps
1633 C in om1, om2, and om12.
1634       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1635       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1636       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1637 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1638       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1639 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1640 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1641 c     &  " eps2rt_om12",eps2rt_om12
1642 C Calculate whole angle-dependent part of epsilon and contributions
1643 C to its derivatives
1644       return
1645       end
1646 C----------------------------------------------------------------------------
1647       subroutine sc_grad
1648       implicit real*8 (a-h,o-z)
1649       include 'DIMENSIONS'
1650       include 'COMMON.CHAIN'
1651       include 'COMMON.DERIV'
1652       include 'COMMON.CALC'
1653       include 'COMMON.IOUNITS'
1654       double precision dcosom1(3),dcosom2(3)
1655       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1656       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1657       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1658      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1659 c diagnostics only
1660 c      eom1=0.0d0
1661 c      eom2=0.0d0
1662 c      eom12=evdwij*eps1_om12
1663 c end diagnostics
1664 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1665 c     &  " sigder",sigder
1666 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1667 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1668       do k=1,3
1669         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1670         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1671       enddo
1672       do k=1,3
1673         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1674       enddo
1675 c      write (iout,*) "gg",(gg(k),k=1,3)
1676       do k=1,3
1677         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1678      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1679      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1680         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1681      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1682      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1683 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1684 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1685 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1686 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1687       enddo
1688 C
1689 C Calculate the components of the gradient in DC and X
1690 C
1691 cgrad      do k=i,j-1
1692 cgrad        do l=1,3
1693 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1694 cgrad        enddo
1695 cgrad      enddo
1696       do l=1,3
1697         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1698         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1699       enddo
1700       return
1701       end
1702 C-----------------------------------------------------------------------
1703       subroutine e_softsphere(evdw)
1704 C
1705 C This subroutine calculates the interaction energy of nonbonded side chains
1706 C assuming the LJ potential of interaction.
1707 C
1708       implicit real*8 (a-h,o-z)
1709       include 'DIMENSIONS'
1710       parameter (accur=1.0d-10)
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.INTERACT'
1717       include 'COMMON.TORSION'
1718       include 'COMMON.SBRIDGE'
1719       include 'COMMON.NAMES'
1720       include 'COMMON.IOUNITS'
1721       include 'COMMON.CONTACTS'
1722       dimension gg(3)
1723 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1724       evdw=0.0D0
1725       do i=iatsc_s,iatsc_e
1726         itypi=itype(i)
1727         itypi1=itype(i+1)
1728         xi=c(1,nres+i)
1729         yi=c(2,nres+i)
1730         zi=c(3,nres+i)
1731 C
1732 C Calculate SC interaction energy.
1733 C
1734         do iint=1,nint_gr(i)
1735 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1736 cd   &                  'iend=',iend(i,iint)
1737           do j=istart(i,iint),iend(i,iint)
1738             itypj=itype(j)
1739             xj=c(1,nres+j)-xi
1740             yj=c(2,nres+j)-yi
1741             zj=c(3,nres+j)-zi
1742             rij=xj*xj+yj*yj+zj*zj
1743 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1744             r0ij=r0(itypi,itypj)
1745             r0ijsq=r0ij*r0ij
1746 c            print *,i,j,r0ij,dsqrt(rij)
1747             if (rij.lt.r0ijsq) then
1748               evdwij=0.25d0*(rij-r0ijsq)**2
1749               fac=rij-r0ijsq
1750             else
1751               evdwij=0.0d0
1752               fac=0.0d0
1753             endif
1754             evdw=evdw+evdwij
1755 C
1756 C Calculate the components of the gradient in DC and X
1757 C
1758             gg(1)=xj*fac
1759             gg(2)=yj*fac
1760             gg(3)=zj*fac
1761             do k=1,3
1762               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1763               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1764               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1765               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1766             enddo
1767 cgrad            do k=i,j-1
1768 cgrad              do l=1,3
1769 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1770 cgrad              enddo
1771 cgrad            enddo
1772           enddo ! j
1773         enddo ! iint
1774       enddo ! i
1775       return
1776       end
1777 C--------------------------------------------------------------------------
1778       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1779      &              eello_turn4)
1780 C
1781 C Soft-sphere potential of p-p interaction
1782 C
1783       implicit real*8 (a-h,o-z)
1784       include 'DIMENSIONS'
1785       include 'COMMON.CONTROL'
1786       include 'COMMON.IOUNITS'
1787       include 'COMMON.GEO'
1788       include 'COMMON.VAR'
1789       include 'COMMON.LOCAL'
1790       include 'COMMON.CHAIN'
1791       include 'COMMON.DERIV'
1792       include 'COMMON.INTERACT'
1793       include 'COMMON.CONTACTS'
1794       include 'COMMON.TORSION'
1795       include 'COMMON.VECTORS'
1796       include 'COMMON.FFIELD'
1797       dimension ggg(3)
1798 cd      write(iout,*) 'In EELEC_soft_sphere'
1799       ees=0.0D0
1800       evdw1=0.0D0
1801       eel_loc=0.0d0
1802       eello_turn3=0.0d0
1803       eello_turn4=0.0d0
1804       ind=0
1805       do i=iatel_s,iatel_e
1806         dxi=dc(1,i)
1807         dyi=dc(2,i)
1808         dzi=dc(3,i)
1809         xmedi=c(1,i)+0.5d0*dxi
1810         ymedi=c(2,i)+0.5d0*dyi
1811         zmedi=c(3,i)+0.5d0*dzi
1812         num_conti=0
1813 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1814         do j=ielstart(i),ielend(i)
1815           ind=ind+1
1816           iteli=itel(i)
1817           itelj=itel(j)
1818           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1819           r0ij=rpp(iteli,itelj)
1820           r0ijsq=r0ij*r0ij
1821           dxj=dc(1,j)
1822           dyj=dc(2,j)
1823           dzj=dc(3,j)
1824           xj=c(1,j)+0.5D0*dxj-xmedi
1825           yj=c(2,j)+0.5D0*dyj-ymedi
1826           zj=c(3,j)+0.5D0*dzj-zmedi
1827           rij=xj*xj+yj*yj+zj*zj
1828           if (rij.lt.r0ijsq) then
1829             evdw1ij=0.25d0*(rij-r0ijsq)**2
1830             fac=rij-r0ijsq
1831           else
1832             evdw1ij=0.0d0
1833             fac=0.0d0
1834           endif
1835           evdw1=evdw1+evdw1ij
1836 C
1837 C Calculate contributions to the Cartesian gradient.
1838 C
1839           ggg(1)=fac*xj
1840           ggg(2)=fac*yj
1841           ggg(3)=fac*zj
1842           do k=1,3
1843             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1844             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1845           enddo
1846 *
1847 * Loop over residues i+1 thru j-1.
1848 *
1849 cgrad          do k=i+1,j-1
1850 cgrad            do l=1,3
1851 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1852 cgrad            enddo
1853 cgrad          enddo
1854         enddo ! j
1855       enddo   ! i
1856 cgrad      do i=nnt,nct-1
1857 cgrad        do k=1,3
1858 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1859 cgrad        enddo
1860 cgrad        do j=i+1,nct-1
1861 cgrad          do k=1,3
1862 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1863 cgrad          enddo
1864 cgrad        enddo
1865 cgrad      enddo
1866       return
1867       end
1868 c------------------------------------------------------------------------------
1869       subroutine vec_and_deriv
1870       implicit real*8 (a-h,o-z)
1871       include 'DIMENSIONS'
1872 #ifdef MPI
1873       include 'mpif.h'
1874 #endif
1875       include 'COMMON.IOUNITS'
1876       include 'COMMON.GEO'
1877       include 'COMMON.VAR'
1878       include 'COMMON.LOCAL'
1879       include 'COMMON.CHAIN'
1880       include 'COMMON.VECTORS'
1881       include 'COMMON.SETUP'
1882       include 'COMMON.TIME1'
1883       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1884 C Compute the local reference systems. For reference system (i), the
1885 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1886 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1887 #ifdef PARVEC
1888       do i=ivec_start,ivec_end
1889 #else
1890       do i=1,nres-1
1891 #endif
1892           if (i.eq.nres-1) then
1893 C Case of the last full residue
1894 C Compute the Z-axis
1895             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1896             costh=dcos(pi-theta(nres))
1897             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1898             do k=1,3
1899               uz(k,i)=fac*uz(k,i)
1900             enddo
1901 C Compute the derivatives of uz
1902             uzder(1,1,1)= 0.0d0
1903             uzder(2,1,1)=-dc_norm(3,i-1)
1904             uzder(3,1,1)= dc_norm(2,i-1)
1905             uzder(1,2,1)= dc_norm(3,i-1)
1906             uzder(2,2,1)= 0.0d0
1907             uzder(3,2,1)=-dc_norm(1,i-1)
1908             uzder(1,3,1)=-dc_norm(2,i-1)
1909             uzder(2,3,1)= dc_norm(1,i-1)
1910             uzder(3,3,1)= 0.0d0
1911             uzder(1,1,2)= 0.0d0
1912             uzder(2,1,2)= dc_norm(3,i)
1913             uzder(3,1,2)=-dc_norm(2,i)
1914             uzder(1,2,2)=-dc_norm(3,i)
1915             uzder(2,2,2)= 0.0d0
1916             uzder(3,2,2)= dc_norm(1,i)
1917             uzder(1,3,2)= dc_norm(2,i)
1918             uzder(2,3,2)=-dc_norm(1,i)
1919             uzder(3,3,2)= 0.0d0
1920 C Compute the Y-axis
1921             facy=fac
1922             do k=1,3
1923               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1924             enddo
1925 C Compute the derivatives of uy
1926             do j=1,3
1927               do k=1,3
1928                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1929      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1930                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1931               enddo
1932               uyder(j,j,1)=uyder(j,j,1)-costh
1933               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1934             enddo
1935             do j=1,2
1936               do k=1,3
1937                 do l=1,3
1938                   uygrad(l,k,j,i)=uyder(l,k,j)
1939                   uzgrad(l,k,j,i)=uzder(l,k,j)
1940                 enddo
1941               enddo
1942             enddo
1943             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1944             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1945             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1946             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1947           else
1948 C Other residues
1949 C Compute the Z-axis
1950             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1951             costh=dcos(pi-theta(i+2))
1952             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1953             do k=1,3
1954               uz(k,i)=fac*uz(k,i)
1955             enddo
1956 C Compute the derivatives of uz
1957             uzder(1,1,1)= 0.0d0
1958             uzder(2,1,1)=-dc_norm(3,i+1)
1959             uzder(3,1,1)= dc_norm(2,i+1)
1960             uzder(1,2,1)= dc_norm(3,i+1)
1961             uzder(2,2,1)= 0.0d0
1962             uzder(3,2,1)=-dc_norm(1,i+1)
1963             uzder(1,3,1)=-dc_norm(2,i+1)
1964             uzder(2,3,1)= dc_norm(1,i+1)
1965             uzder(3,3,1)= 0.0d0
1966             uzder(1,1,2)= 0.0d0
1967             uzder(2,1,2)= dc_norm(3,i)
1968             uzder(3,1,2)=-dc_norm(2,i)
1969             uzder(1,2,2)=-dc_norm(3,i)
1970             uzder(2,2,2)= 0.0d0
1971             uzder(3,2,2)= dc_norm(1,i)
1972             uzder(1,3,2)= dc_norm(2,i)
1973             uzder(2,3,2)=-dc_norm(1,i)
1974             uzder(3,3,2)= 0.0d0
1975 C Compute the Y-axis
1976             facy=fac
1977             do k=1,3
1978               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1979             enddo
1980 C Compute the derivatives of uy
1981             do j=1,3
1982               do k=1,3
1983                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1984      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1985                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1986               enddo
1987               uyder(j,j,1)=uyder(j,j,1)-costh
1988               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1989             enddo
1990             do j=1,2
1991               do k=1,3
1992                 do l=1,3
1993                   uygrad(l,k,j,i)=uyder(l,k,j)
1994                   uzgrad(l,k,j,i)=uzder(l,k,j)
1995                 enddo
1996               enddo
1997             enddo
1998             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1999             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2000             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2001             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2002           endif
2003       enddo
2004       do i=1,nres-1
2005         vbld_inv_temp(1)=vbld_inv(i+1)
2006         if (i.lt.nres-1) then
2007           vbld_inv_temp(2)=vbld_inv(i+2)
2008           else
2009           vbld_inv_temp(2)=vbld_inv(i)
2010           endif
2011         do j=1,2
2012           do k=1,3
2013             do l=1,3
2014               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2015               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2016             enddo
2017           enddo
2018         enddo
2019       enddo
2020 #if defined(PARVEC) && defined(MPI)
2021       if (nfgtasks1.gt.1) then
2022         time00=MPI_Wtime()
2023 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2024 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2025 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2026         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2027      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2028      &   FG_COMM1,IERR)
2029         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2030      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2031      &   FG_COMM1,IERR)
2032         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2033      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2034      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2035         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2036      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2037      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2038         time_gather=time_gather+MPI_Wtime()-time00
2039       endif
2040 c      if (fg_rank.eq.0) then
2041 c        write (iout,*) "Arrays UY and UZ"
2042 c        do i=1,nres-1
2043 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2044 c     &     (uz(k,i),k=1,3)
2045 c        enddo
2046 c      endif
2047 #endif
2048       return
2049       end
2050 C-----------------------------------------------------------------------------
2051       subroutine check_vecgrad
2052       implicit real*8 (a-h,o-z)
2053       include 'DIMENSIONS'
2054       include 'COMMON.IOUNITS'
2055       include 'COMMON.GEO'
2056       include 'COMMON.VAR'
2057       include 'COMMON.LOCAL'
2058       include 'COMMON.CHAIN'
2059       include 'COMMON.VECTORS'
2060       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2061       dimension uyt(3,maxres),uzt(3,maxres)
2062       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2063       double precision delta /1.0d-7/
2064       call vec_and_deriv
2065 cd      do i=1,nres
2066 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2067 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2068 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2069 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2070 cd     &     (dc_norm(if90,i),if90=1,3)
2071 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2072 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2073 cd          write(iout,'(a)')
2074 cd      enddo
2075       do i=1,nres
2076         do j=1,2
2077           do k=1,3
2078             do l=1,3
2079               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2080               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2081             enddo
2082           enddo
2083         enddo
2084       enddo
2085       call vec_and_deriv
2086       do i=1,nres
2087         do j=1,3
2088           uyt(j,i)=uy(j,i)
2089           uzt(j,i)=uz(j,i)
2090         enddo
2091       enddo
2092       do i=1,nres
2093 cd        write (iout,*) 'i=',i
2094         do k=1,3
2095           erij(k)=dc_norm(k,i)
2096         enddo
2097         do j=1,3
2098           do k=1,3
2099             dc_norm(k,i)=erij(k)
2100           enddo
2101           dc_norm(j,i)=dc_norm(j,i)+delta
2102 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2103 c          do k=1,3
2104 c            dc_norm(k,i)=dc_norm(k,i)/fac
2105 c          enddo
2106 c          write (iout,*) (dc_norm(k,i),k=1,3)
2107 c          write (iout,*) (erij(k),k=1,3)
2108           call vec_and_deriv
2109           do k=1,3
2110             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2111             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2112             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2113             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2114           enddo
2115 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2116 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2117 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2118         enddo
2119         do k=1,3
2120           dc_norm(k,i)=erij(k)
2121         enddo
2122 cd        do k=1,3
2123 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2124 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2125 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2126 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2127 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2128 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2129 cd          write (iout,'(a)')
2130 cd        enddo
2131       enddo
2132       return
2133       end
2134 C--------------------------------------------------------------------------
2135       subroutine set_matrices
2136       implicit real*8 (a-h,o-z)
2137       include 'DIMENSIONS'
2138 #ifdef MPI
2139       include "mpif.h"
2140       include "COMMON.SETUP"
2141       integer IERR
2142       integer status(MPI_STATUS_SIZE)
2143 #endif
2144       include 'COMMON.IOUNITS'
2145       include 'COMMON.GEO'
2146       include 'COMMON.VAR'
2147       include 'COMMON.LOCAL'
2148       include 'COMMON.CHAIN'
2149       include 'COMMON.DERIV'
2150       include 'COMMON.INTERACT'
2151       include 'COMMON.CONTACTS'
2152       include 'COMMON.TORSION'
2153       include 'COMMON.VECTORS'
2154       include 'COMMON.FFIELD'
2155       double precision auxvec(2),auxmat(2,2)
2156 C
2157 C Compute the virtual-bond-torsional-angle dependent quantities needed
2158 C to calculate the el-loc multibody terms of various order.
2159 C
2160 #ifdef PARMAT
2161       do i=ivec_start+2,ivec_end+2
2162 #else
2163       do i=3,nres+1
2164 #endif
2165         if (i .lt. nres+1) then
2166           sin1=dsin(phi(i))
2167           cos1=dcos(phi(i))
2168           sintab(i-2)=sin1
2169           costab(i-2)=cos1
2170           obrot(1,i-2)=cos1
2171           obrot(2,i-2)=sin1
2172           sin2=dsin(2*phi(i))
2173           cos2=dcos(2*phi(i))
2174           sintab2(i-2)=sin2
2175           costab2(i-2)=cos2
2176           obrot2(1,i-2)=cos2
2177           obrot2(2,i-2)=sin2
2178           Ug(1,1,i-2)=-cos1
2179           Ug(1,2,i-2)=-sin1
2180           Ug(2,1,i-2)=-sin1
2181           Ug(2,2,i-2)= cos1
2182           Ug2(1,1,i-2)=-cos2
2183           Ug2(1,2,i-2)=-sin2
2184           Ug2(2,1,i-2)=-sin2
2185           Ug2(2,2,i-2)= cos2
2186         else
2187           costab(i-2)=1.0d0
2188           sintab(i-2)=0.0d0
2189           obrot(1,i-2)=1.0d0
2190           obrot(2,i-2)=0.0d0
2191           obrot2(1,i-2)=0.0d0
2192           obrot2(2,i-2)=0.0d0
2193           Ug(1,1,i-2)=1.0d0
2194           Ug(1,2,i-2)=0.0d0
2195           Ug(2,1,i-2)=0.0d0
2196           Ug(2,2,i-2)=1.0d0
2197           Ug2(1,1,i-2)=0.0d0
2198           Ug2(1,2,i-2)=0.0d0
2199           Ug2(2,1,i-2)=0.0d0
2200           Ug2(2,2,i-2)=0.0d0
2201         endif
2202         if (i .gt. 3 .and. i .lt. nres+1) then
2203           obrot_der(1,i-2)=-sin1
2204           obrot_der(2,i-2)= cos1
2205           Ugder(1,1,i-2)= sin1
2206           Ugder(1,2,i-2)=-cos1
2207           Ugder(2,1,i-2)=-cos1
2208           Ugder(2,2,i-2)=-sin1
2209           dwacos2=cos2+cos2
2210           dwasin2=sin2+sin2
2211           obrot2_der(1,i-2)=-dwasin2
2212           obrot2_der(2,i-2)= dwacos2
2213           Ug2der(1,1,i-2)= dwasin2
2214           Ug2der(1,2,i-2)=-dwacos2
2215           Ug2der(2,1,i-2)=-dwacos2
2216           Ug2der(2,2,i-2)=-dwasin2
2217         else
2218           obrot_der(1,i-2)=0.0d0
2219           obrot_der(2,i-2)=0.0d0
2220           Ugder(1,1,i-2)=0.0d0
2221           Ugder(1,2,i-2)=0.0d0
2222           Ugder(2,1,i-2)=0.0d0
2223           Ugder(2,2,i-2)=0.0d0
2224           obrot2_der(1,i-2)=0.0d0
2225           obrot2_der(2,i-2)=0.0d0
2226           Ug2der(1,1,i-2)=0.0d0
2227           Ug2der(1,2,i-2)=0.0d0
2228           Ug2der(2,1,i-2)=0.0d0
2229           Ug2der(2,2,i-2)=0.0d0
2230         endif
2231 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2232         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2233           iti = itortyp(itype(i-2))
2234         else
2235           iti=ntortyp+1
2236         endif
2237 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2238         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2239           iti1 = itortyp(itype(i-1))
2240         else
2241           iti1=ntortyp+1
2242         endif
2243 cd        write (iout,*) '*******i',i,' iti1',iti
2244 cd        write (iout,*) 'b1',b1(:,iti)
2245 cd        write (iout,*) 'b2',b2(:,iti)
2246 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2247 c        if (i .gt. iatel_s+2) then
2248         if (i .gt. nnt+2) then
2249           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2250           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2251           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2252      &    then
2253           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2254           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2255           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2256           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2257           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2258           endif
2259         else
2260           do k=1,2
2261             Ub2(k,i-2)=0.0d0
2262             Ctobr(k,i-2)=0.0d0
2263             Dtobr2(k,i-2)=0.0d0
2264             do l=1,2
2265               EUg(l,k,i-2)=0.0d0
2266               CUg(l,k,i-2)=0.0d0
2267               DUg(l,k,i-2)=0.0d0
2268               DtUg2(l,k,i-2)=0.0d0
2269             enddo
2270           enddo
2271         endif
2272         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2273         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2274         do k=1,2
2275           muder(k,i-2)=Ub2der(k,i-2)
2276         enddo
2277 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2278         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2279           iti1 = itortyp(itype(i-1))
2280         else
2281           iti1=ntortyp+1
2282         endif
2283         do k=1,2
2284           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2285         enddo
2286 cd        write (iout,*) 'mu ',mu(:,i-2)
2287 cd        write (iout,*) 'mu1',mu1(:,i-2)
2288 cd        write (iout,*) 'mu2',mu2(:,i-2)
2289         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2290      &  then
2291         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2292         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2293         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2294         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2295         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2296 C Vectors and matrices dependent on a single virtual-bond dihedral.
2297         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2298         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2299         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2300         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2301         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2302         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2303         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2304         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2305         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2306         endif
2307       enddo
2308 C Matrices dependent on two consecutive virtual-bond dihedrals.
2309 C The order of matrices is from left to right.
2310       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2311      &then
2312 c      do i=max0(ivec_start,2),ivec_end
2313       do i=2,nres-1
2314         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2315         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2316         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2317         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2318         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2319         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2320         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2321         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2322       enddo
2323       endif
2324 #if defined(MPI) && defined(PARMAT)
2325 #ifdef DEBUG
2326 c      if (fg_rank.eq.0) then
2327         write (iout,*) "Arrays UG and UGDER before GATHER"
2328         do i=1,nres-1
2329           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2330      &     ((ug(l,k,i),l=1,2),k=1,2),
2331      &     ((ugder(l,k,i),l=1,2),k=1,2)
2332         enddo
2333         write (iout,*) "Arrays UG2 and UG2DER"
2334         do i=1,nres-1
2335           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2336      &     ((ug2(l,k,i),l=1,2),k=1,2),
2337      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2338         enddo
2339         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2340         do i=1,nres-1
2341           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2342      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2343      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2344         enddo
2345         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2346         do i=1,nres-1
2347           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2348      &     costab(i),sintab(i),costab2(i),sintab2(i)
2349         enddo
2350         write (iout,*) "Array MUDER"
2351         do i=1,nres-1
2352           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2353         enddo
2354 c      endif
2355 #endif
2356       if (nfgtasks.gt.1) then
2357         time00=MPI_Wtime()
2358 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2359 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2360 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2361 #ifdef MATGATHER
2362         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2363      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2364      &   FG_COMM1,IERR)
2365         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2366      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2367      &   FG_COMM1,IERR)
2368         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2369      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2370      &   FG_COMM1,IERR)
2371         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2372      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2373      &   FG_COMM1,IERR)
2374         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2375      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2376      &   FG_COMM1,IERR)
2377         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2378      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2379      &   FG_COMM1,IERR)
2380         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2381      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2382      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2383         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2384      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2385      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2386         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2387      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2388      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2389         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2390      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2391      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2392         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2393      &  then
2394         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2395      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2396      &   FG_COMM1,IERR)
2397         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2398      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2399      &   FG_COMM1,IERR)
2400         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2401      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2402      &   FG_COMM1,IERR)
2403        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2404      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2405      &   FG_COMM1,IERR)
2406         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2407      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2408      &   FG_COMM1,IERR)
2409         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2410      &   ivec_count(fg_rank1),
2411      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2412      &   FG_COMM1,IERR)
2413         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2414      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2415      &   FG_COMM1,IERR)
2416         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2417      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2418      &   FG_COMM1,IERR)
2419         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2420      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2421      &   FG_COMM1,IERR)
2422         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2423      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2424      &   FG_COMM1,IERR)
2425         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2426      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2427      &   FG_COMM1,IERR)
2428         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2429      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2430      &   FG_COMM1,IERR)
2431         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2432      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2433      &   FG_COMM1,IERR)
2434         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2435      &   ivec_count(fg_rank1),
2436      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2437      &   FG_COMM1,IERR)
2438         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2439      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2440      &   FG_COMM1,IERR)
2441        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2442      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2443      &   FG_COMM1,IERR)
2444         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2445      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2446      &   FG_COMM1,IERR)
2447        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2448      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2449      &   FG_COMM1,IERR)
2450         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2451      &   ivec_count(fg_rank1),
2452      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2453      &   FG_COMM1,IERR)
2454         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2455      &   ivec_count(fg_rank1),
2456      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2457      &   FG_COMM1,IERR)
2458         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2459      &   ivec_count(fg_rank1),
2460      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2461      &   MPI_MAT2,FG_COMM1,IERR)
2462         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2463      &   ivec_count(fg_rank1),
2464      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2465      &   MPI_MAT2,FG_COMM1,IERR)
2466         endif
2467 #else
2468 c Passes matrix info through the ring
2469       isend=fg_rank1
2470       irecv=fg_rank1-1
2471       if (irecv.lt.0) irecv=nfgtasks1-1
2472       iprev=irecv
2473       inext=fg_rank1+1
2474       if (inext.ge.nfgtasks1) inext=0
2475       do i=1,nfgtasks1-1
2476 c        write (iout,*) "isend",isend," irecv",irecv
2477 c        call flush(iout)
2478         lensend=lentyp(isend)
2479         lenrecv=lentyp(irecv)
2480 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2481 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2482 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2483 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2484 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2485 c        write (iout,*) "Gather ROTAT1"
2486 c        call flush(iout)
2487 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2488 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2489 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2490 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2491 c        write (iout,*) "Gather ROTAT2"
2492 c        call flush(iout)
2493         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2494      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2495      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2496      &   iprev,4400+irecv,FG_COMM,status,IERR)
2497 c        write (iout,*) "Gather ROTAT_OLD"
2498 c        call flush(iout)
2499         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2500      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2501      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2502      &   iprev,5500+irecv,FG_COMM,status,IERR)
2503 c        write (iout,*) "Gather PRECOMP11"
2504 c        call flush(iout)
2505         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2506      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2507      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2508      &   iprev,6600+irecv,FG_COMM,status,IERR)
2509 c        write (iout,*) "Gather PRECOMP12"
2510 c        call flush(iout)
2511         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2512      &  then
2513         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2514      &   MPI_ROTAT2(lensend),inext,7700+isend,
2515      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2516      &   iprev,7700+irecv,FG_COMM,status,IERR)
2517 c        write (iout,*) "Gather PRECOMP21"
2518 c        call flush(iout)
2519         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2520      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2521      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2522      &   iprev,8800+irecv,FG_COMM,status,IERR)
2523 c        write (iout,*) "Gather PRECOMP22"
2524 c        call flush(iout)
2525         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2526      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2527      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2528      &   MPI_PRECOMP23(lenrecv),
2529      &   iprev,9900+irecv,FG_COMM,status,IERR)
2530 c        write (iout,*) "Gather PRECOMP23"
2531 c        call flush(iout)
2532         endif
2533         isend=irecv
2534         irecv=irecv-1
2535         if (irecv.lt.0) irecv=nfgtasks1-1
2536       enddo
2537 #endif
2538         time_gather=time_gather+MPI_Wtime()-time00
2539       endif
2540 #ifdef DEBUG
2541 c      if (fg_rank.eq.0) then
2542         write (iout,*) "Arrays UG and UGDER"
2543         do i=1,nres-1
2544           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2545      &     ((ug(l,k,i),l=1,2),k=1,2),
2546      &     ((ugder(l,k,i),l=1,2),k=1,2)
2547         enddo
2548         write (iout,*) "Arrays UG2 and UG2DER"
2549         do i=1,nres-1
2550           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2551      &     ((ug2(l,k,i),l=1,2),k=1,2),
2552      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2553         enddo
2554         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2555         do i=1,nres-1
2556           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2557      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2558      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2559         enddo
2560         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2561         do i=1,nres-1
2562           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2563      &     costab(i),sintab(i),costab2(i),sintab2(i)
2564         enddo
2565         write (iout,*) "Array MUDER"
2566         do i=1,nres-1
2567           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2568         enddo
2569 c      endif
2570 #endif
2571 #endif
2572 cd      do i=1,nres
2573 cd        iti = itortyp(itype(i))
2574 cd        write (iout,*) i
2575 cd        do j=1,2
2576 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2577 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2578 cd        enddo
2579 cd      enddo
2580       return
2581       end
2582 C--------------------------------------------------------------------------
2583       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2584 C
2585 C This subroutine calculates the average interaction energy and its gradient
2586 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2587 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2588 C The potential depends both on the distance of peptide-group centers and on
2589 C the orientation of the CA-CA virtual bonds.
2590 C
2591       implicit real*8 (a-h,o-z)
2592 #ifdef MPI
2593       include 'mpif.h'
2594 #endif
2595       include 'DIMENSIONS'
2596       include 'COMMON.CONTROL'
2597       include 'COMMON.SETUP'
2598       include 'COMMON.IOUNITS'
2599       include 'COMMON.GEO'
2600       include 'COMMON.VAR'
2601       include 'COMMON.LOCAL'
2602       include 'COMMON.CHAIN'
2603       include 'COMMON.DERIV'
2604       include 'COMMON.INTERACT'
2605       include 'COMMON.CONTACTS'
2606       include 'COMMON.TORSION'
2607       include 'COMMON.VECTORS'
2608       include 'COMMON.FFIELD'
2609       include 'COMMON.TIME1'
2610       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2611      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2612       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2613      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2614       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2615      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2616      &    num_conti,j1,j2
2617 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2618 #ifdef MOMENT
2619       double precision scal_el /1.0d0/
2620 #else
2621       double precision scal_el /0.5d0/
2622 #endif
2623 C 12/13/98
2624 C 13-go grudnia roku pamietnego...
2625       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2626      &                   0.0d0,1.0d0,0.0d0,
2627      &                   0.0d0,0.0d0,1.0d0/
2628 cd      write(iout,*) 'In EELEC'
2629 cd      do i=1,nloctyp
2630 cd        write(iout,*) 'Type',i
2631 cd        write(iout,*) 'B1',B1(:,i)
2632 cd        write(iout,*) 'B2',B2(:,i)
2633 cd        write(iout,*) 'CC',CC(:,:,i)
2634 cd        write(iout,*) 'DD',DD(:,:,i)
2635 cd        write(iout,*) 'EE',EE(:,:,i)
2636 cd      enddo
2637 cd      call check_vecgrad
2638 cd      stop
2639       if (icheckgrad.eq.1) then
2640         do i=1,nres-1
2641           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2642           do k=1,3
2643             dc_norm(k,i)=dc(k,i)*fac
2644           enddo
2645 c          write (iout,*) 'i',i,' fac',fac
2646         enddo
2647       endif
2648       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2649      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2650      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2651 c        call vec_and_deriv
2652 #ifdef TIMING
2653         time01=MPI_Wtime()
2654 #endif
2655         call set_matrices
2656 #ifdef TIMING
2657         time_mat=time_mat+MPI_Wtime()-time01
2658 #endif
2659       endif
2660 cd      do i=1,nres-1
2661 cd        write (iout,*) 'i=',i
2662 cd        do k=1,3
2663 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2664 cd        enddo
2665 cd        do k=1,3
2666 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2667 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2668 cd        enddo
2669 cd      enddo
2670       t_eelecij=0.0d0
2671       ees=0.0D0
2672       evdw1=0.0D0
2673       eel_loc=0.0d0
2674       eello_turn3=0.0d0
2675       eello_turn4=0.0d0
2676       ind=0
2677       do i=1,nres
2678         num_cont_hb(i)=0
2679       enddo
2680 cd      print '(a)','Enter EELEC'
2681 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2682       do i=1,nres
2683         gel_loc_loc(i)=0.0d0
2684         gcorr_loc(i)=0.0d0
2685       enddo
2686 c
2687 c
2688 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2689 C
2690 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2691 C
2692       do i=iturn3_start,iturn3_end
2693         dxi=dc(1,i)
2694         dyi=dc(2,i)
2695         dzi=dc(3,i)
2696         dx_normi=dc_norm(1,i)
2697         dy_normi=dc_norm(2,i)
2698         dz_normi=dc_norm(3,i)
2699         xmedi=c(1,i)+0.5d0*dxi
2700         ymedi=c(2,i)+0.5d0*dyi
2701         zmedi=c(3,i)+0.5d0*dzi
2702         num_conti=0
2703         call eelecij(i,i+2,ees,evdw1,eel_loc)
2704         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2705         num_cont_hb(i)=num_conti
2706       enddo
2707       do i=iturn4_start,iturn4_end
2708         dxi=dc(1,i)
2709         dyi=dc(2,i)
2710         dzi=dc(3,i)
2711         dx_normi=dc_norm(1,i)
2712         dy_normi=dc_norm(2,i)
2713         dz_normi=dc_norm(3,i)
2714         xmedi=c(1,i)+0.5d0*dxi
2715         ymedi=c(2,i)+0.5d0*dyi
2716         zmedi=c(3,i)+0.5d0*dzi
2717         num_conti=num_cont_hb(i)
2718         call eelecij(i,i+3,ees,evdw1,eel_loc)
2719         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
2720         num_cont_hb(i)=num_conti
2721       enddo   ! i
2722 c
2723 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2724 c
2725       do i=iatel_s,iatel_e
2726         dxi=dc(1,i)
2727         dyi=dc(2,i)
2728         dzi=dc(3,i)
2729         dx_normi=dc_norm(1,i)
2730         dy_normi=dc_norm(2,i)
2731         dz_normi=dc_norm(3,i)
2732         xmedi=c(1,i)+0.5d0*dxi
2733         ymedi=c(2,i)+0.5d0*dyi
2734         zmedi=c(3,i)+0.5d0*dzi
2735 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2736         num_conti=num_cont_hb(i)
2737         do j=ielstart(i),ielend(i)
2738           call eelecij(i,j,ees,evdw1,eel_loc)
2739         enddo ! j
2740         num_cont_hb(i)=num_conti
2741       enddo   ! i
2742 c      write (iout,*) "Number of loop steps in EELEC:",ind
2743 cd      do i=1,nres
2744 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2745 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2746 cd      enddo
2747 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2748 ccc      eel_loc=eel_loc+eello_turn3
2749 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2750       return
2751       end
2752 C-------------------------------------------------------------------------------
2753       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2754       implicit real*8 (a-h,o-z)
2755       include 'DIMENSIONS'
2756 #ifdef MPI
2757       include "mpif.h"
2758 #endif
2759       include 'COMMON.CONTROL'
2760       include 'COMMON.IOUNITS'
2761       include 'COMMON.GEO'
2762       include 'COMMON.VAR'
2763       include 'COMMON.LOCAL'
2764       include 'COMMON.CHAIN'
2765       include 'COMMON.DERIV'
2766       include 'COMMON.INTERACT'
2767       include 'COMMON.CONTACTS'
2768       include 'COMMON.TORSION'
2769       include 'COMMON.VECTORS'
2770       include 'COMMON.FFIELD'
2771       include 'COMMON.TIME1'
2772       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2773      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2774       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2775      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2776       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2777      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2778      &    num_conti,j1,j2
2779 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2780 #ifdef MOMENT
2781       double precision scal_el /1.0d0/
2782 #else
2783       double precision scal_el /0.5d0/
2784 #endif
2785 C 12/13/98
2786 C 13-go grudnia roku pamietnego...
2787       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2788      &                   0.0d0,1.0d0,0.0d0,
2789      &                   0.0d0,0.0d0,1.0d0/
2790 c          time00=MPI_Wtime()
2791 cd      write (iout,*) "eelecij",i,j
2792           ind=ind+1
2793           iteli=itel(i)
2794           itelj=itel(j)
2795           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2796           aaa=app(iteli,itelj)
2797           bbb=bpp(iteli,itelj)
2798           ael6i=ael6(iteli,itelj)
2799           ael3i=ael3(iteli,itelj)
2800           dxj=dc(1,j)
2801           dyj=dc(2,j)
2802           dzj=dc(3,j)
2803           dx_normj=dc_norm(1,j)
2804           dy_normj=dc_norm(2,j)
2805           dz_normj=dc_norm(3,j)
2806           xj=c(1,j)+0.5D0*dxj-xmedi
2807           yj=c(2,j)+0.5D0*dyj-ymedi
2808           zj=c(3,j)+0.5D0*dzj-zmedi
2809           rij=xj*xj+yj*yj+zj*zj
2810           rrmij=1.0D0/rij
2811           rij=dsqrt(rij)
2812           rmij=1.0D0/rij
2813           r3ij=rrmij*rmij
2814           r6ij=r3ij*r3ij
2815           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2816           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2817           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2818           fac=cosa-3.0D0*cosb*cosg
2819           ev1=aaa*r6ij*r6ij
2820 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2821           if (j.eq.i+2) ev1=scal_el*ev1
2822           ev2=bbb*r6ij
2823           fac3=ael6i*r6ij
2824           fac4=ael3i*r3ij
2825           evdwij=ev1+ev2
2826           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2827           el2=fac4*fac
2828           eesij=el1+el2
2829 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2830           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2831           ees=ees+eesij
2832           evdw1=evdw1+evdwij
2833 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2834 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2835 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2836 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2837
2838           if (energy_dec) then
2839               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2840               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2841           endif
2842
2843 C
2844 C Calculate contributions to the Cartesian gradient.
2845 C
2846 #ifdef SPLITELE
2847           facvdw=-6*rrmij*(ev1+evdwij)
2848           facel=-3*rrmij*(el1+eesij)
2849           fac1=fac
2850           erij(1)=xj*rmij
2851           erij(2)=yj*rmij
2852           erij(3)=zj*rmij
2853 *
2854 * Radial derivatives. First process both termini of the fragment (i,j)
2855 *
2856           ggg(1)=facel*xj
2857           ggg(2)=facel*yj
2858           ggg(3)=facel*zj
2859 c          do k=1,3
2860 c            ghalf=0.5D0*ggg(k)
2861 c            gelc(k,i)=gelc(k,i)+ghalf
2862 c            gelc(k,j)=gelc(k,j)+ghalf
2863 c          enddo
2864 c 9/28/08 AL Gradient compotents will be summed only at the end
2865           do k=1,3
2866             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2867             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2868           enddo
2869 *
2870 * Loop over residues i+1 thru j-1.
2871 *
2872 cgrad          do k=i+1,j-1
2873 cgrad            do l=1,3
2874 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2875 cgrad            enddo
2876 cgrad          enddo
2877           ggg(1)=facvdw*xj
2878           ggg(2)=facvdw*yj
2879           ggg(3)=facvdw*zj
2880 c          do k=1,3
2881 c            ghalf=0.5D0*ggg(k)
2882 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2883 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2884 c          enddo
2885 c 9/28/08 AL Gradient compotents will be summed only at the end
2886           do k=1,3
2887             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2888             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2889           enddo
2890 *
2891 * Loop over residues i+1 thru j-1.
2892 *
2893 cgrad          do k=i+1,j-1
2894 cgrad            do l=1,3
2895 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2896 cgrad            enddo
2897 cgrad          enddo
2898 #else
2899           facvdw=ev1+evdwij
2900           facel=el1+eesij
2901           fac1=fac
2902           fac=-3*rrmij*(facvdw+facvdw+facel)
2903           erij(1)=xj*rmij
2904           erij(2)=yj*rmij
2905           erij(3)=zj*rmij
2906 *
2907 * Radial derivatives. First process both termini of the fragment (i,j)
2908 *
2909           ggg(1)=fac*xj
2910           ggg(2)=fac*yj
2911           ggg(3)=fac*zj
2912 c          do k=1,3
2913 c            ghalf=0.5D0*ggg(k)
2914 c            gelc(k,i)=gelc(k,i)+ghalf
2915 c            gelc(k,j)=gelc(k,j)+ghalf
2916 c          enddo
2917 c 9/28/08 AL Gradient compotents will be summed only at the end
2918           do k=1,3
2919             gelc_long(k,j)=gelc(k,j)+ggg(k)
2920             gelc_long(k,i)=gelc(k,i)-ggg(k)
2921           enddo
2922 *
2923 * Loop over residues i+1 thru j-1.
2924 *
2925 cgrad          do k=i+1,j-1
2926 cgrad            do l=1,3
2927 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2928 cgrad            enddo
2929 cgrad          enddo
2930 c 9/28/08 AL Gradient compotents will be summed only at the end
2931           ggg(1)=facvdw*xj
2932           ggg(2)=facvdw*yj
2933           ggg(3)=facvdw*zj
2934           do k=1,3
2935             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2936             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2937           enddo
2938 #endif
2939 *
2940 * Angular part
2941 *
2942           ecosa=2.0D0*fac3*fac1+fac4
2943           fac4=-3.0D0*fac4
2944           fac3=-6.0D0*fac3
2945           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2946           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2947           do k=1,3
2948             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2949             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2950           enddo
2951 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2952 cd   &          (dcosg(k),k=1,3)
2953           do k=1,3
2954             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2955           enddo
2956 c          do k=1,3
2957 c            ghalf=0.5D0*ggg(k)
2958 c            gelc(k,i)=gelc(k,i)+ghalf
2959 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2960 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2961 c            gelc(k,j)=gelc(k,j)+ghalf
2962 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2963 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2964 c          enddo
2965 cgrad          do k=i+1,j-1
2966 cgrad            do l=1,3
2967 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2968 cgrad            enddo
2969 cgrad          enddo
2970           do k=1,3
2971             gelc(k,i)=gelc(k,i)
2972      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2973      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2974             gelc(k,j)=gelc(k,j)
2975      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2976      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2977             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2978             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2979           enddo
2980           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2981      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2982      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2983 C
2984 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2985 C   energy of a peptide unit is assumed in the form of a second-order
2986 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2987 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2988 C   are computed for EVERY pair of non-contiguous peptide groups.
2989 C
2990           if (j.lt.nres-1) then
2991             j1=j+1
2992             j2=j-1
2993           else
2994             j1=j-1
2995             j2=j-2
2996           endif
2997           kkk=0
2998           do k=1,2
2999             do l=1,2
3000               kkk=kkk+1
3001               muij(kkk)=mu(k,i)*mu(l,j)
3002             enddo
3003           enddo
3004 cd         write (iout,*) 'EELEC: i',i,' j',j
3005 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3006 cd          write(iout,*) 'muij',muij
3007           ury=scalar(uy(1,i),erij)
3008           urz=scalar(uz(1,i),erij)
3009           vry=scalar(uy(1,j),erij)
3010           vrz=scalar(uz(1,j),erij)
3011           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3012           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3013           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3014           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3015           fac=dsqrt(-ael6i)*r3ij
3016           a22=a22*fac
3017           a23=a23*fac
3018           a32=a32*fac
3019           a33=a33*fac
3020 cd          write (iout,'(4i5,4f10.5)')
3021 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3022 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3023 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3024 cd     &      uy(:,j),uz(:,j)
3025 cd          write (iout,'(4f10.5)')
3026 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3027 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3028 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3029 cd           write (iout,'(9f10.5/)')
3030 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3031 C Derivatives of the elements of A in virtual-bond vectors
3032           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3033           do k=1,3
3034             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3035             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3036             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3037             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3038             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3039             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3040             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3041             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3042             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3043             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3044             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3045             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3046           enddo
3047 C Compute radial contributions to the gradient
3048           facr=-3.0d0*rrmij
3049           a22der=a22*facr
3050           a23der=a23*facr
3051           a32der=a32*facr
3052           a33der=a33*facr
3053           agg(1,1)=a22der*xj
3054           agg(2,1)=a22der*yj
3055           agg(3,1)=a22der*zj
3056           agg(1,2)=a23der*xj
3057           agg(2,2)=a23der*yj
3058           agg(3,2)=a23der*zj
3059           agg(1,3)=a32der*xj
3060           agg(2,3)=a32der*yj
3061           agg(3,3)=a32der*zj
3062           agg(1,4)=a33der*xj
3063           agg(2,4)=a33der*yj
3064           agg(3,4)=a33der*zj
3065 C Add the contributions coming from er
3066           fac3=-3.0d0*fac
3067           do k=1,3
3068             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3069             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3070             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3071             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3072           enddo
3073           do k=1,3
3074 C Derivatives in DC(i)
3075 cgrad            ghalf1=0.5d0*agg(k,1)
3076 cgrad            ghalf2=0.5d0*agg(k,2)
3077 cgrad            ghalf3=0.5d0*agg(k,3)
3078 cgrad            ghalf4=0.5d0*agg(k,4)
3079             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3080      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3081             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3082      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3083             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3084      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3085             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3086      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3087 C Derivatives in DC(i+1)
3088             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3089      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3090             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3091      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3092             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3093      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3094             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3095      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3096 C Derivatives in DC(j)
3097             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3098      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3099             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3100      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3101             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3102      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3103             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3104      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3105 C Derivatives in DC(j+1) or DC(nres-1)
3106             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3107      &      -3.0d0*vryg(k,3)*ury)
3108             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3109      &      -3.0d0*vrzg(k,3)*ury)
3110             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3111      &      -3.0d0*vryg(k,3)*urz)
3112             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3113      &      -3.0d0*vrzg(k,3)*urz)
3114 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3115 cgrad              do l=1,4
3116 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3117 cgrad              enddo
3118 cgrad            endif
3119           enddo
3120           acipa(1,1)=a22
3121           acipa(1,2)=a23
3122           acipa(2,1)=a32
3123           acipa(2,2)=a33
3124           a22=-a22
3125           a23=-a23
3126           do l=1,2
3127             do k=1,3
3128               agg(k,l)=-agg(k,l)
3129               aggi(k,l)=-aggi(k,l)
3130               aggi1(k,l)=-aggi1(k,l)
3131               aggj(k,l)=-aggj(k,l)
3132               aggj1(k,l)=-aggj1(k,l)
3133             enddo
3134           enddo
3135           if (j.lt.nres-1) then
3136             a22=-a22
3137             a32=-a32
3138             do l=1,3,2
3139               do k=1,3
3140                 agg(k,l)=-agg(k,l)
3141                 aggi(k,l)=-aggi(k,l)
3142                 aggi1(k,l)=-aggi1(k,l)
3143                 aggj(k,l)=-aggj(k,l)
3144                 aggj1(k,l)=-aggj1(k,l)
3145               enddo
3146             enddo
3147           else
3148             a22=-a22
3149             a23=-a23
3150             a32=-a32
3151             a33=-a33
3152             do l=1,4
3153               do k=1,3
3154                 agg(k,l)=-agg(k,l)
3155                 aggi(k,l)=-aggi(k,l)
3156                 aggi1(k,l)=-aggi1(k,l)
3157                 aggj(k,l)=-aggj(k,l)
3158                 aggj1(k,l)=-aggj1(k,l)
3159               enddo
3160             enddo
3161           endif
3162           ENDIF ! WCORR
3163           IF (wel_loc.gt.0.0d0) THEN
3164 C Contribution to the local-electrostatic energy coming from the i-j pair
3165           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3166      &     +a33*muij(4)
3167 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3168
3169           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3170      &            'eelloc',i,j,eel_loc_ij
3171
3172           eel_loc=eel_loc+eel_loc_ij
3173 C Partial derivatives in virtual-bond dihedral angles gamma
3174           if (i.gt.1)
3175      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3176      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3177      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3178           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3179      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3180      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3181 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3182           do l=1,3
3183             ggg(l)=agg(l,1)*muij(1)+
3184      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3185             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3186             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3187 cgrad            ghalf=0.5d0*ggg(l)
3188 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3189 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3190           enddo
3191 cgrad          do k=i+1,j2
3192 cgrad            do l=1,3
3193 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3194 cgrad            enddo
3195 cgrad          enddo
3196 C Remaining derivatives of eello
3197           do l=1,3
3198             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3199      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3200             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3201      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3202             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3203      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3204             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3205      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3206           enddo
3207           ENDIF
3208 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3209 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3210           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3211      &       .and. num_conti.le.maxconts) then
3212 c            write (iout,*) i,j," entered corr"
3213 C
3214 C Calculate the contact function. The ith column of the array JCONT will
3215 C contain the numbers of atoms that make contacts with the atom I (of numbers
3216 C greater than I). The arrays FACONT and GACONT will contain the values of
3217 C the contact function and its derivative.
3218 c           r0ij=1.02D0*rpp(iteli,itelj)
3219 c           r0ij=1.11D0*rpp(iteli,itelj)
3220             r0ij=2.20D0*rpp(iteli,itelj)
3221 c           r0ij=1.55D0*rpp(iteli,itelj)
3222             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3223             if (fcont.gt.0.0D0) then
3224               num_conti=num_conti+1
3225               if (num_conti.gt.maxconts) then
3226                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3227      &                         ' will skip next contacts for this conf.'
3228               else
3229                 jcont_hb(num_conti,i)=j
3230 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3231 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3232                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3233      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3234 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3235 C  terms.
3236                 d_cont(num_conti,i)=rij
3237 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3238 C     --- Electrostatic-interaction matrix ---
3239                 a_chuj(1,1,num_conti,i)=a22
3240                 a_chuj(1,2,num_conti,i)=a23
3241                 a_chuj(2,1,num_conti,i)=a32
3242                 a_chuj(2,2,num_conti,i)=a33
3243 C     --- Gradient of rij
3244                 do kkk=1,3
3245                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3246                 enddo
3247                 kkll=0
3248                 do k=1,2
3249                   do l=1,2
3250                     kkll=kkll+1
3251                     do m=1,3
3252                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3253                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3254                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3255                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3256                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3257                     enddo
3258                   enddo
3259                 enddo
3260                 ENDIF
3261                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3262 C Calculate contact energies
3263                 cosa4=4.0D0*cosa
3264                 wij=cosa-3.0D0*cosb*cosg
3265                 cosbg1=cosb+cosg
3266                 cosbg2=cosb-cosg
3267 c               fac3=dsqrt(-ael6i)/r0ij**3
3268                 fac3=dsqrt(-ael6i)*r3ij
3269 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3270                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3271                 if (ees0tmp.gt.0) then
3272                   ees0pij=dsqrt(ees0tmp)
3273                 else
3274                   ees0pij=0
3275                 endif
3276 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3277                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3278                 if (ees0tmp.gt.0) then
3279                   ees0mij=dsqrt(ees0tmp)
3280                 else
3281                   ees0mij=0
3282                 endif
3283 c               ees0mij=0.0D0
3284                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3285                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3286 C Diagnostics. Comment out or remove after debugging!
3287 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3288 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3289 c               ees0m(num_conti,i)=0.0D0
3290 C End diagnostics.
3291 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3292 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3293 C Angular derivatives of the contact function
3294                 ees0pij1=fac3/ees0pij
3295                 ees0mij1=fac3/ees0mij
3296                 fac3p=-3.0D0*fac3*rrmij
3297                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3298                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3299 c               ees0mij1=0.0D0
3300                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3301                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3302                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3303                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3304                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3305                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3306                 ecosap=ecosa1+ecosa2
3307                 ecosbp=ecosb1+ecosb2
3308                 ecosgp=ecosg1+ecosg2
3309                 ecosam=ecosa1-ecosa2
3310                 ecosbm=ecosb1-ecosb2
3311                 ecosgm=ecosg1-ecosg2
3312 C Diagnostics
3313 c               ecosap=ecosa1
3314 c               ecosbp=ecosb1
3315 c               ecosgp=ecosg1
3316 c               ecosam=0.0D0
3317 c               ecosbm=0.0D0
3318 c               ecosgm=0.0D0
3319 C End diagnostics
3320                 facont_hb(num_conti,i)=fcont
3321                 fprimcont=fprimcont/rij
3322 cd              facont_hb(num_conti,i)=1.0D0
3323 C Following line is for diagnostics.
3324 cd              fprimcont=0.0D0
3325                 do k=1,3
3326                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3327                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3328                 enddo
3329                 do k=1,3
3330                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3331                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3332                 enddo
3333                 gggp(1)=gggp(1)+ees0pijp*xj
3334                 gggp(2)=gggp(2)+ees0pijp*yj
3335                 gggp(3)=gggp(3)+ees0pijp*zj
3336                 gggm(1)=gggm(1)+ees0mijp*xj
3337                 gggm(2)=gggm(2)+ees0mijp*yj
3338                 gggm(3)=gggm(3)+ees0mijp*zj
3339 C Derivatives due to the contact function
3340                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3341                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3342                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3343                 do k=1,3
3344 c
3345 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3346 c          following the change of gradient-summation algorithm.
3347 c
3348 cgrad                  ghalfp=0.5D0*gggp(k)
3349 cgrad                  ghalfm=0.5D0*gggm(k)
3350                   gacontp_hb1(k,num_conti,i)=!ghalfp
3351      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3352      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3353                   gacontp_hb2(k,num_conti,i)=!ghalfp
3354      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3355      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3356                   gacontp_hb3(k,num_conti,i)=gggp(k)
3357                   gacontm_hb1(k,num_conti,i)=!ghalfm
3358      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3359      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3360                   gacontm_hb2(k,num_conti,i)=!ghalfm
3361      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3362      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3363                   gacontm_hb3(k,num_conti,i)=gggm(k)
3364                 enddo
3365 C Diagnostics. Comment out or remove after debugging!
3366 cdiag           do k=1,3
3367 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3368 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3369 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3370 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3371 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3372 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3373 cdiag           enddo
3374               ENDIF ! wcorr
3375               endif  ! num_conti.le.maxconts
3376             endif  ! fcont.gt.0
3377           endif    ! j.gt.i+1
3378           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3379             do k=1,4
3380               do l=1,3
3381                 ghalf=0.5d0*agg(l,k)
3382                 aggi(l,k)=aggi(l,k)+ghalf
3383                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3384                 aggj(l,k)=aggj(l,k)+ghalf
3385               enddo
3386             enddo
3387             if (j.eq.nres-1 .and. i.lt.j-2) then
3388               do k=1,4
3389                 do l=1,3
3390                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3391                 enddo
3392               enddo
3393             endif
3394           endif
3395 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3396       return
3397       end
3398 C-----------------------------------------------------------------------------
3399       subroutine eturn3(i,eello_turn3)
3400 C Third- and fourth-order contributions from turns
3401       implicit real*8 (a-h,o-z)
3402       include 'DIMENSIONS'
3403       include 'COMMON.IOUNITS'
3404       include 'COMMON.GEO'
3405       include 'COMMON.VAR'
3406       include 'COMMON.LOCAL'
3407       include 'COMMON.CHAIN'
3408       include 'COMMON.DERIV'
3409       include 'COMMON.INTERACT'
3410       include 'COMMON.CONTACTS'
3411       include 'COMMON.TORSION'
3412       include 'COMMON.VECTORS'
3413       include 'COMMON.FFIELD'
3414       include 'COMMON.CONTROL'
3415       dimension ggg(3)
3416       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3417      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3418      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3419       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3420      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3421       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3422      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3423      &    num_conti,j1,j2
3424       j=i+2
3425 c      write (iout,*) "eturn3",i,j,j1,j2
3426       a_temp(1,1)=a22
3427       a_temp(1,2)=a23
3428       a_temp(2,1)=a32
3429       a_temp(2,2)=a33
3430 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3431 C
3432 C               Third-order contributions
3433 C
3434 C                 (i+2)o----(i+3)
3435 C                      | |
3436 C                      | |
3437 C                 (i+1)o----i
3438 C
3439 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3440 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3441         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3442         call transpose2(auxmat(1,1),auxmat1(1,1))
3443         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3444         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3445         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3446      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3447 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3448 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3449 cd     &    ' eello_turn3_num',4*eello_turn3_num
3450 C Derivatives in gamma(i)
3451         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3452         call transpose2(auxmat2(1,1),auxmat3(1,1))
3453         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3454         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3455 C Derivatives in gamma(i+1)
3456         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3457         call transpose2(auxmat2(1,1),auxmat3(1,1))
3458         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3459         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3460      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3461 C Cartesian derivatives
3462         do l=1,3
3463 c            ghalf1=0.5d0*agg(l,1)
3464 c            ghalf2=0.5d0*agg(l,2)
3465 c            ghalf3=0.5d0*agg(l,3)
3466 c            ghalf4=0.5d0*agg(l,4)
3467           a_temp(1,1)=aggi(l,1)!+ghalf1
3468           a_temp(1,2)=aggi(l,2)!+ghalf2
3469           a_temp(2,1)=aggi(l,3)!+ghalf3
3470           a_temp(2,2)=aggi(l,4)!+ghalf4
3471           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3472           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3473      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3474           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3475           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3476           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3477           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3478           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3479           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3480      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3481           a_temp(1,1)=aggj(l,1)!+ghalf1
3482           a_temp(1,2)=aggj(l,2)!+ghalf2
3483           a_temp(2,1)=aggj(l,3)!+ghalf3
3484           a_temp(2,2)=aggj(l,4)!+ghalf4
3485           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3486           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3487      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3488           a_temp(1,1)=aggj1(l,1)
3489           a_temp(1,2)=aggj1(l,2)
3490           a_temp(2,1)=aggj1(l,3)
3491           a_temp(2,2)=aggj1(l,4)
3492           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3493           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3494      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3495         enddo
3496       return
3497       end
3498 C-------------------------------------------------------------------------------
3499       subroutine eturn4(i,eello_turn4)
3500 C Third- and fourth-order contributions from turns
3501       implicit real*8 (a-h,o-z)
3502       include 'DIMENSIONS'
3503       include 'COMMON.IOUNITS'
3504       include 'COMMON.GEO'
3505       include 'COMMON.VAR'
3506       include 'COMMON.LOCAL'
3507       include 'COMMON.CHAIN'
3508       include 'COMMON.DERIV'
3509       include 'COMMON.INTERACT'
3510       include 'COMMON.CONTACTS'
3511       include 'COMMON.TORSION'
3512       include 'COMMON.VECTORS'
3513       include 'COMMON.FFIELD'
3514       include 'COMMON.CONTROL'
3515       dimension ggg(3)
3516       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3517      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3518      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3519       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3520      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3521       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3522      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3523      &    num_conti,j1,j2
3524       j=i+3
3525 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3526 C
3527 C               Fourth-order contributions
3528 C
3529 C                 (i+3)o----(i+4)
3530 C                     /  |
3531 C               (i+2)o   |
3532 C                     \  |
3533 C                 (i+1)o----i
3534 C
3535 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3536 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3537 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3538         a_temp(1,1)=a22
3539         a_temp(1,2)=a23
3540         a_temp(2,1)=a32
3541         a_temp(2,2)=a33
3542         iti1=itortyp(itype(i+1))
3543         iti2=itortyp(itype(i+2))
3544         iti3=itortyp(itype(i+3))
3545 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3546         call transpose2(EUg(1,1,i+1),e1t(1,1))
3547         call transpose2(Eug(1,1,i+2),e2t(1,1))
3548         call transpose2(Eug(1,1,i+3),e3t(1,1))
3549         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3550         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3551         s1=scalar2(b1(1,iti2),auxvec(1))
3552         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3553         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3554         s2=scalar2(b1(1,iti1),auxvec(1))
3555         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3556         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3557         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3558         eello_turn4=eello_turn4-(s1+s2+s3)
3559         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3560      &      'eturn4',i,j,-(s1+s2+s3)
3561 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3562 cd     &    ' eello_turn4_num',8*eello_turn4_num
3563 C Derivatives in gamma(i)
3564         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3565         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3566         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3567         s1=scalar2(b1(1,iti2),auxvec(1))
3568         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3569         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3570         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3571 C Derivatives in gamma(i+1)
3572         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3573         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3574         s2=scalar2(b1(1,iti1),auxvec(1))
3575         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3576         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3577         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3578         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3579 C Derivatives in gamma(i+2)
3580         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3581         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3582         s1=scalar2(b1(1,iti2),auxvec(1))
3583         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3584         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3585         s2=scalar2(b1(1,iti1),auxvec(1))
3586         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3587         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3588         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3589         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3590 C Cartesian derivatives
3591 C Derivatives of this turn contributions in DC(i+2)
3592         if (j.lt.nres-1) then
3593           do l=1,3
3594             a_temp(1,1)=agg(l,1)
3595             a_temp(1,2)=agg(l,2)
3596             a_temp(2,1)=agg(l,3)
3597             a_temp(2,2)=agg(l,4)
3598             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3599             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3600             s1=scalar2(b1(1,iti2),auxvec(1))
3601             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3602             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3603             s2=scalar2(b1(1,iti1),auxvec(1))
3604             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3605             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3606             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3607             ggg(l)=-(s1+s2+s3)
3608             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3609           enddo
3610         endif
3611 C Remaining derivatives of this turn contribution
3612         do l=1,3
3613           a_temp(1,1)=aggi(l,1)
3614           a_temp(1,2)=aggi(l,2)
3615           a_temp(2,1)=aggi(l,3)
3616           a_temp(2,2)=aggi(l,4)
3617           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3618           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3619           s1=scalar2(b1(1,iti2),auxvec(1))
3620           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3621           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3622           s2=scalar2(b1(1,iti1),auxvec(1))
3623           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3624           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3625           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3626           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3627           a_temp(1,1)=aggi1(l,1)
3628           a_temp(1,2)=aggi1(l,2)
3629           a_temp(2,1)=aggi1(l,3)
3630           a_temp(2,2)=aggi1(l,4)
3631           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3632           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3633           s1=scalar2(b1(1,iti2),auxvec(1))
3634           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3635           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3636           s2=scalar2(b1(1,iti1),auxvec(1))
3637           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3638           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3639           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3640           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3641           a_temp(1,1)=aggj(l,1)
3642           a_temp(1,2)=aggj(l,2)
3643           a_temp(2,1)=aggj(l,3)
3644           a_temp(2,2)=aggj(l,4)
3645           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3646           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3647           s1=scalar2(b1(1,iti2),auxvec(1))
3648           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3649           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3650           s2=scalar2(b1(1,iti1),auxvec(1))
3651           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3652           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3653           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3654           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3655           a_temp(1,1)=aggj1(l,1)
3656           a_temp(1,2)=aggj1(l,2)
3657           a_temp(2,1)=aggj1(l,3)
3658           a_temp(2,2)=aggj1(l,4)
3659           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3660           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3661           s1=scalar2(b1(1,iti2),auxvec(1))
3662           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3663           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3664           s2=scalar2(b1(1,iti1),auxvec(1))
3665           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3666           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3667           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3668 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3669           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3670         enddo
3671       return
3672       end
3673 C-----------------------------------------------------------------------------
3674       subroutine vecpr(u,v,w)
3675       implicit real*8(a-h,o-z)
3676       dimension u(3),v(3),w(3)
3677       w(1)=u(2)*v(3)-u(3)*v(2)
3678       w(2)=-u(1)*v(3)+u(3)*v(1)
3679       w(3)=u(1)*v(2)-u(2)*v(1)
3680       return
3681       end
3682 C-----------------------------------------------------------------------------
3683       subroutine unormderiv(u,ugrad,unorm,ungrad)
3684 C This subroutine computes the derivatives of a normalized vector u, given
3685 C the derivatives computed without normalization conditions, ugrad. Returns
3686 C ungrad.
3687       implicit none
3688       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3689       double precision vec(3)
3690       double precision scalar
3691       integer i,j
3692 c      write (2,*) 'ugrad',ugrad
3693 c      write (2,*) 'u',u
3694       do i=1,3
3695         vec(i)=scalar(ugrad(1,i),u(1))
3696       enddo
3697 c      write (2,*) 'vec',vec
3698       do i=1,3
3699         do j=1,3
3700           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3701         enddo
3702       enddo
3703 c      write (2,*) 'ungrad',ungrad
3704       return
3705       end
3706 C-----------------------------------------------------------------------------
3707       subroutine escp_soft_sphere(evdw2,evdw2_14)
3708 C
3709 C This subroutine calculates the excluded-volume interaction energy between
3710 C peptide-group centers and side chains and its gradient in virtual-bond and
3711 C side-chain vectors.
3712 C
3713       implicit real*8 (a-h,o-z)
3714       include 'DIMENSIONS'
3715       include 'COMMON.GEO'
3716       include 'COMMON.VAR'
3717       include 'COMMON.LOCAL'
3718       include 'COMMON.CHAIN'
3719       include 'COMMON.DERIV'
3720       include 'COMMON.INTERACT'
3721       include 'COMMON.FFIELD'
3722       include 'COMMON.IOUNITS'
3723       include 'COMMON.CONTROL'
3724       dimension ggg(3)
3725       evdw2=0.0D0
3726       evdw2_14=0.0d0
3727       r0_scp=4.5d0
3728 cd    print '(a)','Enter ESCP'
3729 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3730       do i=iatscp_s,iatscp_e
3731         iteli=itel(i)
3732         xi=0.5D0*(c(1,i)+c(1,i+1))
3733         yi=0.5D0*(c(2,i)+c(2,i+1))
3734         zi=0.5D0*(c(3,i)+c(3,i+1))
3735
3736         do iint=1,nscp_gr(i)
3737
3738         do j=iscpstart(i,iint),iscpend(i,iint)
3739           itypj=itype(j)
3740 C Uncomment following three lines for SC-p interactions
3741 c         xj=c(1,nres+j)-xi
3742 c         yj=c(2,nres+j)-yi
3743 c         zj=c(3,nres+j)-zi
3744 C Uncomment following three lines for Ca-p interactions
3745           xj=c(1,j)-xi
3746           yj=c(2,j)-yi
3747           zj=c(3,j)-zi
3748           rij=xj*xj+yj*yj+zj*zj
3749           r0ij=r0_scp
3750           r0ijsq=r0ij*r0ij
3751           if (rij.lt.r0ijsq) then
3752             evdwij=0.25d0*(rij-r0ijsq)**2
3753             fac=rij-r0ijsq
3754           else
3755             evdwij=0.0d0
3756             fac=0.0d0
3757           endif
3758           evdw2=evdw2+evdwij
3759 C
3760 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3761 C
3762           ggg(1)=xj*fac
3763           ggg(2)=yj*fac
3764           ggg(3)=zj*fac
3765 cgrad          if (j.lt.i) then
3766 cd          write (iout,*) 'j<i'
3767 C Uncomment following three lines for SC-p interactions
3768 c           do k=1,3
3769 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3770 c           enddo
3771 cgrad          else
3772 cd          write (iout,*) 'j>i'
3773 cgrad            do k=1,3
3774 cgrad              ggg(k)=-ggg(k)
3775 C Uncomment following line for SC-p interactions
3776 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3777 cgrad            enddo
3778 cgrad          endif
3779 cgrad          do k=1,3
3780 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3781 cgrad          enddo
3782 cgrad          kstart=min0(i+1,j)
3783 cgrad          kend=max0(i-1,j-1)
3784 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3785 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3786 cgrad          do k=kstart,kend
3787 cgrad            do l=1,3
3788 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3789 cgrad            enddo
3790 cgrad          enddo
3791           do k=1,3
3792             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3793             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3794           enddo
3795         enddo
3796
3797         enddo ! iint
3798       enddo ! i
3799       return
3800       end
3801 C-----------------------------------------------------------------------------
3802       subroutine escp(evdw2,evdw2_14)
3803 C
3804 C This subroutine calculates the excluded-volume interaction energy between
3805 C peptide-group centers and side chains and its gradient in virtual-bond and
3806 C side-chain vectors.
3807 C
3808       implicit real*8 (a-h,o-z)
3809       include 'DIMENSIONS'
3810       include 'COMMON.GEO'
3811       include 'COMMON.VAR'
3812       include 'COMMON.LOCAL'
3813       include 'COMMON.CHAIN'
3814       include 'COMMON.DERIV'
3815       include 'COMMON.INTERACT'
3816       include 'COMMON.FFIELD'
3817       include 'COMMON.IOUNITS'
3818       include 'COMMON.CONTROL'
3819       dimension ggg(3)
3820       evdw2=0.0D0
3821       evdw2_14=0.0d0
3822 cd    print '(a)','Enter ESCP'
3823 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3824       do i=iatscp_s,iatscp_e
3825         iteli=itel(i)
3826         xi=0.5D0*(c(1,i)+c(1,i+1))
3827         yi=0.5D0*(c(2,i)+c(2,i+1))
3828         zi=0.5D0*(c(3,i)+c(3,i+1))
3829
3830         do iint=1,nscp_gr(i)
3831
3832         do j=iscpstart(i,iint),iscpend(i,iint)
3833           itypj=itype(j)
3834 C Uncomment following three lines for SC-p interactions
3835 c         xj=c(1,nres+j)-xi
3836 c         yj=c(2,nres+j)-yi
3837 c         zj=c(3,nres+j)-zi
3838 C Uncomment following three lines for Ca-p interactions
3839           xj=c(1,j)-xi
3840           yj=c(2,j)-yi
3841           zj=c(3,j)-zi
3842           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3843           fac=rrij**expon2
3844           e1=fac*fac*aad(itypj,iteli)
3845           e2=fac*bad(itypj,iteli)
3846           if (iabs(j-i) .le. 2) then
3847             e1=scal14*e1
3848             e2=scal14*e2
3849             evdw2_14=evdw2_14+e1+e2
3850           endif
3851           evdwij=e1+e2
3852           evdw2=evdw2+evdwij
3853           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3854      &        'evdw2',i,j,evdwij
3855 C
3856 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3857 C
3858           fac=-(evdwij+e1)*rrij
3859           ggg(1)=xj*fac
3860           ggg(2)=yj*fac
3861           ggg(3)=zj*fac
3862 cgrad          if (j.lt.i) then
3863 cd          write (iout,*) 'j<i'
3864 C Uncomment following three lines for SC-p interactions
3865 c           do k=1,3
3866 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3867 c           enddo
3868 cgrad          else
3869 cd          write (iout,*) 'j>i'
3870 cgrad            do k=1,3
3871 cgrad              ggg(k)=-ggg(k)
3872 C Uncomment following line for SC-p interactions
3873 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3874 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3875 cgrad            enddo
3876 cgrad          endif
3877 cgrad          do k=1,3
3878 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3879 cgrad          enddo
3880 cgrad          kstart=min0(i+1,j)
3881 cgrad          kend=max0(i-1,j-1)
3882 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3883 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3884 cgrad          do k=kstart,kend
3885 cgrad            do l=1,3
3886 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3887 cgrad            enddo
3888 cgrad          enddo
3889           do k=1,3
3890             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3891             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3892           enddo
3893         enddo
3894
3895         enddo ! iint
3896       enddo ! i
3897       do i=1,nct
3898         do j=1,3
3899           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3900           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3901           gradx_scp(j,i)=expon*gradx_scp(j,i)
3902         enddo
3903       enddo
3904 C******************************************************************************
3905 C
3906 C                              N O T E !!!
3907 C
3908 C To save time the factor EXPON has been extracted from ALL components
3909 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3910 C use!
3911 C
3912 C******************************************************************************
3913       return
3914       end
3915 C--------------------------------------------------------------------------
3916       subroutine edis(ehpb)
3917 C
3918 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3919 C
3920       implicit real*8 (a-h,o-z)
3921       include 'DIMENSIONS'
3922       include 'COMMON.SBRIDGE'
3923       include 'COMMON.CHAIN'
3924       include 'COMMON.DERIV'
3925       include 'COMMON.VAR'
3926       include 'COMMON.INTERACT'
3927       include 'COMMON.IOUNITS'
3928       dimension ggg(3)
3929       ehpb=0.0D0
3930 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3931 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
3932       if (link_end.eq.0) return
3933       do i=link_start,link_end
3934 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3935 C CA-CA distance used in regularization of structure.
3936         ii=ihpb(i)
3937         jj=jhpb(i)
3938 C iii and jjj point to the residues for which the distance is assigned.
3939         if (ii.gt.nres) then
3940           iii=ii-nres
3941           jjj=jj-nres
3942         else
3943           iii=ii
3944           jjj=jj
3945         endif
3946 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
3947 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3948 C    distance and angle dependent SS bond potential.
3949         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3950           call ssbond_ene(iii,jjj,eij)
3951           ehpb=ehpb+2*eij
3952 cd          write (iout,*) "eij",eij
3953         else
3954 C Calculate the distance between the two points and its difference from the
3955 C target distance.
3956         dd=dist(ii,jj)
3957         rdis=dd-dhpb(i)
3958 C Get the force constant corresponding to this distance.
3959         waga=forcon(i)
3960 C Calculate the contribution to energy.
3961         ehpb=ehpb+waga*rdis*rdis
3962 C
3963 C Evaluate gradient.
3964 C
3965         fac=waga*rdis/dd
3966 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3967 cd   &   ' waga=',waga,' fac=',fac
3968         do j=1,3
3969           ggg(j)=fac*(c(j,jj)-c(j,ii))
3970         enddo
3971 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3972 C If this is a SC-SC distance, we need to calculate the contributions to the
3973 C Cartesian gradient in the SC vectors (ghpbx).
3974         if (iii.lt.ii) then
3975           do j=1,3
3976             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3977             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3978           enddo
3979         endif
3980 cgrad        do j=iii,jjj-1
3981 cgrad          do k=1,3
3982 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3983 cgrad          enddo
3984 cgrad        enddo
3985         do k=1,3
3986           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3987           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3988         enddo
3989         endif
3990       enddo
3991       ehpb=0.5D0*ehpb
3992       return
3993       end
3994 C--------------------------------------------------------------------------
3995       subroutine ssbond_ene(i,j,eij)
3996 C
3997 C Calculate the distance and angle dependent SS-bond potential energy
3998 C using a free-energy function derived based on RHF/6-31G** ab initio
3999 C calculations of diethyl disulfide.
4000 C
4001 C A. Liwo and U. Kozlowska, 11/24/03
4002 C
4003       implicit real*8 (a-h,o-z)
4004       include 'DIMENSIONS'
4005       include 'COMMON.SBRIDGE'
4006       include 'COMMON.CHAIN'
4007       include 'COMMON.DERIV'
4008       include 'COMMON.LOCAL'
4009       include 'COMMON.INTERACT'
4010       include 'COMMON.VAR'
4011       include 'COMMON.IOUNITS'
4012       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4013       itypi=itype(i)
4014       xi=c(1,nres+i)
4015       yi=c(2,nres+i)
4016       zi=c(3,nres+i)
4017       dxi=dc_norm(1,nres+i)
4018       dyi=dc_norm(2,nres+i)
4019       dzi=dc_norm(3,nres+i)
4020 c      dsci_inv=dsc_inv(itypi)
4021       dsci_inv=vbld_inv(nres+i)
4022       itypj=itype(j)
4023 c      dscj_inv=dsc_inv(itypj)
4024       dscj_inv=vbld_inv(nres+j)
4025       xj=c(1,nres+j)-xi
4026       yj=c(2,nres+j)-yi
4027       zj=c(3,nres+j)-zi
4028       dxj=dc_norm(1,nres+j)
4029       dyj=dc_norm(2,nres+j)
4030       dzj=dc_norm(3,nres+j)
4031       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4032       rij=dsqrt(rrij)
4033       erij(1)=xj*rij
4034       erij(2)=yj*rij
4035       erij(3)=zj*rij
4036       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4037       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4038       om12=dxi*dxj+dyi*dyj+dzi*dzj
4039       do k=1,3
4040         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4041         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4042       enddo
4043       rij=1.0d0/rij
4044       deltad=rij-d0cm
4045       deltat1=1.0d0-om1
4046       deltat2=1.0d0+om2
4047       deltat12=om2-om1+2.0d0
4048       cosphi=om12-om1*om2
4049       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4050      &  +akct*deltad*deltat12
4051      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4052 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4053 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4054 c     &  " deltat12",deltat12," eij",eij
4055       ed=2*akcm*deltad+akct*deltat12
4056       pom1=akct*deltad
4057       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4058       eom1=-2*akth*deltat1-pom1-om2*pom2
4059       eom2= 2*akth*deltat2+pom1-om1*pom2
4060       eom12=pom2
4061       do k=1,3
4062         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4063         ghpbx(k,i)=ghpbx(k,i)-ggk
4064      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4065      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4066         ghpbx(k,j)=ghpbx(k,j)+ggk
4067      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4068      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4069         ghpbc(k,i)=ghpbc(k,i)-ggk
4070         ghpbc(k,j)=ghpbc(k,j)+ggk
4071       enddo
4072 C
4073 C Calculate the components of the gradient in DC and X
4074 C
4075 cgrad      do k=i,j-1
4076 cgrad        do l=1,3
4077 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4078 cgrad        enddo
4079 cgrad      enddo
4080       return
4081       end
4082 C--------------------------------------------------------------------------
4083       subroutine ebond(estr)
4084 c
4085 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4086 c
4087       implicit real*8 (a-h,o-z)
4088       include 'DIMENSIONS'
4089       include 'COMMON.LOCAL'
4090       include 'COMMON.GEO'
4091       include 'COMMON.INTERACT'
4092       include 'COMMON.DERIV'
4093       include 'COMMON.VAR'
4094       include 'COMMON.CHAIN'
4095       include 'COMMON.IOUNITS'
4096       include 'COMMON.NAMES'
4097       include 'COMMON.FFIELD'
4098       include 'COMMON.CONTROL'
4099       include 'COMMON.SETUP'
4100       double precision u(3),ud(3)
4101       estr=0.0d0
4102       do i=ibondp_start,ibondp_end
4103         diff = vbld(i)-vbldp0
4104 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4105         estr=estr+diff*diff
4106         do j=1,3
4107           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4108         enddo
4109 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4110       enddo
4111       estr=0.5d0*AKP*estr
4112 c
4113 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4114 c
4115       do i=ibond_start,ibond_end
4116         iti=itype(i)
4117         if (iti.ne.10) then
4118           nbi=nbondterm(iti)
4119           if (nbi.eq.1) then
4120             diff=vbld(i+nres)-vbldsc0(1,iti)
4121 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4122 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4123             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4124             do j=1,3
4125               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4126             enddo
4127           else
4128             do j=1,nbi
4129               diff=vbld(i+nres)-vbldsc0(j,iti)
4130               ud(j)=aksc(j,iti)*diff
4131               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4132             enddo
4133             uprod=u(1)
4134             do j=2,nbi
4135               uprod=uprod*u(j)
4136             enddo
4137             usum=0.0d0
4138             usumsqder=0.0d0
4139             do j=1,nbi
4140               uprod1=1.0d0
4141               uprod2=1.0d0
4142               do k=1,nbi
4143                 if (k.ne.j) then
4144                   uprod1=uprod1*u(k)
4145                   uprod2=uprod2*u(k)*u(k)
4146                 endif
4147               enddo
4148               usum=usum+uprod1
4149               usumsqder=usumsqder+ud(j)*uprod2
4150             enddo
4151             estr=estr+uprod/usum
4152             do j=1,3
4153              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4154             enddo
4155           endif
4156         endif
4157       enddo
4158       return
4159       end
4160 #ifdef CRYST_THETA
4161 C--------------------------------------------------------------------------
4162       subroutine ebend(etheta)
4163 C
4164 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4165 C angles gamma and its derivatives in consecutive thetas and gammas.
4166 C
4167       implicit real*8 (a-h,o-z)
4168       include 'DIMENSIONS'
4169       include 'COMMON.LOCAL'
4170       include 'COMMON.GEO'
4171       include 'COMMON.INTERACT'
4172       include 'COMMON.DERIV'
4173       include 'COMMON.VAR'
4174       include 'COMMON.CHAIN'
4175       include 'COMMON.IOUNITS'
4176       include 'COMMON.NAMES'
4177       include 'COMMON.FFIELD'
4178       include 'COMMON.CONTROL'
4179       common /calcthet/ term1,term2,termm,diffak,ratak,
4180      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4181      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4182       double precision y(2),z(2)
4183       delta=0.02d0*pi
4184 c      time11=dexp(-2*time)
4185 c      time12=1.0d0
4186       etheta=0.0D0
4187 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4188       do i=ithet_start,ithet_end
4189 C Zero the energy function and its derivative at 0 or pi.
4190         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4191         it=itype(i-1)
4192         if (i.gt.3) then
4193 #ifdef OSF
4194           phii=phi(i)
4195           if (phii.ne.phii) phii=150.0
4196 #else
4197           phii=phi(i)
4198 #endif
4199           y(1)=dcos(phii)
4200           y(2)=dsin(phii)
4201         else
4202           y(1)=0.0D0
4203           y(2)=0.0D0
4204         endif
4205         if (i.lt.nres) then
4206 #ifdef OSF
4207           phii1=phi(i+1)
4208           if (phii1.ne.phii1) phii1=150.0
4209           phii1=pinorm(phii1)
4210           z(1)=cos(phii1)
4211 #else
4212           phii1=phi(i+1)
4213           z(1)=dcos(phii1)
4214 #endif
4215           z(2)=dsin(phii1)
4216         else
4217           z(1)=0.0D0
4218           z(2)=0.0D0
4219         endif
4220 C Calculate the "mean" value of theta from the part of the distribution
4221 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4222 C In following comments this theta will be referred to as t_c.
4223         thet_pred_mean=0.0d0
4224         do k=1,2
4225           athetk=athet(k,it)
4226           bthetk=bthet(k,it)
4227           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4228         enddo
4229         dthett=thet_pred_mean*ssd
4230         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4231 C Derivatives of the "mean" values in gamma1 and gamma2.
4232         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4233         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4234         if (theta(i).gt.pi-delta) then
4235           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4236      &         E_tc0)
4237           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4238           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4239           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4240      &        E_theta)
4241           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4242      &        E_tc)
4243         else if (theta(i).lt.delta) then
4244           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4245           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4246           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4247      &        E_theta)
4248           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4249           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4250      &        E_tc)
4251         else
4252           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4253      &        E_theta,E_tc)
4254         endif
4255         etheta=etheta+ethetai
4256         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4257      &      'ebend',i,ethetai
4258         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4259         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4260         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4261       enddo
4262 C Ufff.... We've done all this!!!
4263       return
4264       end
4265 C---------------------------------------------------------------------------
4266       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4267      &     E_tc)
4268       implicit real*8 (a-h,o-z)
4269       include 'DIMENSIONS'
4270       include 'COMMON.LOCAL'
4271       include 'COMMON.IOUNITS'
4272       common /calcthet/ term1,term2,termm,diffak,ratak,
4273      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4274      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4275 C Calculate the contributions to both Gaussian lobes.
4276 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4277 C The "polynomial part" of the "standard deviation" of this part of
4278 C the distribution.
4279         sig=polthet(3,it)
4280         do j=2,0,-1
4281           sig=sig*thet_pred_mean+polthet(j,it)
4282         enddo
4283 C Derivative of the "interior part" of the "standard deviation of the"
4284 C gamma-dependent Gaussian lobe in t_c.
4285         sigtc=3*polthet(3,it)
4286         do j=2,1,-1
4287           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4288         enddo
4289         sigtc=sig*sigtc
4290 C Set the parameters of both Gaussian lobes of the distribution.
4291 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4292         fac=sig*sig+sigc0(it)
4293         sigcsq=fac+fac
4294         sigc=1.0D0/sigcsq
4295 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4296         sigsqtc=-4.0D0*sigcsq*sigtc
4297 c       print *,i,sig,sigtc,sigsqtc
4298 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4299         sigtc=-sigtc/(fac*fac)
4300 C Following variable is sigma(t_c)**(-2)
4301         sigcsq=sigcsq*sigcsq
4302         sig0i=sig0(it)
4303         sig0inv=1.0D0/sig0i**2
4304         delthec=thetai-thet_pred_mean
4305         delthe0=thetai-theta0i
4306         term1=-0.5D0*sigcsq*delthec*delthec
4307         term2=-0.5D0*sig0inv*delthe0*delthe0
4308 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4309 C NaNs in taking the logarithm. We extract the largest exponent which is added
4310 C to the energy (this being the log of the distribution) at the end of energy
4311 C term evaluation for this virtual-bond angle.
4312         if (term1.gt.term2) then
4313           termm=term1
4314           term2=dexp(term2-termm)
4315           term1=1.0d0
4316         else
4317           termm=term2
4318           term1=dexp(term1-termm)
4319           term2=1.0d0
4320         endif
4321 C The ratio between the gamma-independent and gamma-dependent lobes of
4322 C the distribution is a Gaussian function of thet_pred_mean too.
4323         diffak=gthet(2,it)-thet_pred_mean
4324         ratak=diffak/gthet(3,it)**2
4325         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4326 C Let's differentiate it in thet_pred_mean NOW.
4327         aktc=ak*ratak
4328 C Now put together the distribution terms to make complete distribution.
4329         termexp=term1+ak*term2
4330         termpre=sigc+ak*sig0i
4331 C Contribution of the bending energy from this theta is just the -log of
4332 C the sum of the contributions from the two lobes and the pre-exponential
4333 C factor. Simple enough, isn't it?
4334         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4335 C NOW the derivatives!!!
4336 C 6/6/97 Take into account the deformation.
4337         E_theta=(delthec*sigcsq*term1
4338      &       +ak*delthe0*sig0inv*term2)/termexp
4339         E_tc=((sigtc+aktc*sig0i)/termpre
4340      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4341      &       aktc*term2)/termexp)
4342       return
4343       end
4344 c-----------------------------------------------------------------------------
4345       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4346       implicit real*8 (a-h,o-z)
4347       include 'DIMENSIONS'
4348       include 'COMMON.LOCAL'
4349       include 'COMMON.IOUNITS'
4350       common /calcthet/ term1,term2,termm,diffak,ratak,
4351      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4352      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4353       delthec=thetai-thet_pred_mean
4354       delthe0=thetai-theta0i
4355 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4356       t3 = thetai-thet_pred_mean
4357       t6 = t3**2
4358       t9 = term1
4359       t12 = t3*sigcsq
4360       t14 = t12+t6*sigsqtc
4361       t16 = 1.0d0
4362       t21 = thetai-theta0i
4363       t23 = t21**2
4364       t26 = term2
4365       t27 = t21*t26
4366       t32 = termexp
4367       t40 = t32**2
4368       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4369      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4370      & *(-t12*t9-ak*sig0inv*t27)
4371       return
4372       end
4373 #else
4374 C--------------------------------------------------------------------------
4375       subroutine ebend(etheta)
4376 C
4377 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4378 C angles gamma and its derivatives in consecutive thetas and gammas.
4379 C ab initio-derived potentials from
4380 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4381 C
4382       implicit real*8 (a-h,o-z)
4383       include 'DIMENSIONS'
4384       include 'COMMON.LOCAL'
4385       include 'COMMON.GEO'
4386       include 'COMMON.INTERACT'
4387       include 'COMMON.DERIV'
4388       include 'COMMON.VAR'
4389       include 'COMMON.CHAIN'
4390       include 'COMMON.IOUNITS'
4391       include 'COMMON.NAMES'
4392       include 'COMMON.FFIELD'
4393       include 'COMMON.CONTROL'
4394       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4395      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4396      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4397      & sinph1ph2(maxdouble,maxdouble)
4398       logical lprn /.false./, lprn1 /.false./
4399       etheta=0.0D0
4400       do i=ithet_start,ithet_end
4401         dethetai=0.0d0
4402         dephii=0.0d0
4403         dephii1=0.0d0
4404         theti2=0.5d0*theta(i)
4405         ityp2=ithetyp(itype(i-1))
4406         do k=1,nntheterm
4407           coskt(k)=dcos(k*theti2)
4408           sinkt(k)=dsin(k*theti2)
4409         enddo
4410         if (i.gt.3) then
4411 #ifdef OSF
4412           phii=phi(i)
4413           if (phii.ne.phii) phii=150.0
4414 #else
4415           phii=phi(i)
4416 #endif
4417           ityp1=ithetyp(itype(i-2))
4418           do k=1,nsingle
4419             cosph1(k)=dcos(k*phii)
4420             sinph1(k)=dsin(k*phii)
4421           enddo
4422         else
4423           phii=0.0d0
4424           ityp1=nthetyp+1
4425           do k=1,nsingle
4426             cosph1(k)=0.0d0
4427             sinph1(k)=0.0d0
4428           enddo
4429         endif
4430         if (i.lt.nres) then
4431 #ifdef OSF
4432           phii1=phi(i+1)
4433           if (phii1.ne.phii1) phii1=150.0
4434           phii1=pinorm(phii1)
4435 #else
4436           phii1=phi(i+1)
4437 #endif
4438           ityp3=ithetyp(itype(i))
4439           do k=1,nsingle
4440             cosph2(k)=dcos(k*phii1)
4441             sinph2(k)=dsin(k*phii1)
4442           enddo
4443         else
4444           phii1=0.0d0
4445           ityp3=nthetyp+1
4446           do k=1,nsingle
4447             cosph2(k)=0.0d0
4448             sinph2(k)=0.0d0
4449           enddo
4450         endif
4451         ethetai=aa0thet(ityp1,ityp2,ityp3)
4452         do k=1,ndouble
4453           do l=1,k-1
4454             ccl=cosph1(l)*cosph2(k-l)
4455             ssl=sinph1(l)*sinph2(k-l)
4456             scl=sinph1(l)*cosph2(k-l)
4457             csl=cosph1(l)*sinph2(k-l)
4458             cosph1ph2(l,k)=ccl-ssl
4459             cosph1ph2(k,l)=ccl+ssl
4460             sinph1ph2(l,k)=scl+csl
4461             sinph1ph2(k,l)=scl-csl
4462           enddo
4463         enddo
4464         if (lprn) then
4465         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4466      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4467         write (iout,*) "coskt and sinkt"
4468         do k=1,nntheterm
4469           write (iout,*) k,coskt(k),sinkt(k)
4470         enddo
4471         endif
4472         do k=1,ntheterm
4473           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4474           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4475      &      *coskt(k)
4476           if (lprn)
4477      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4478      &     " ethetai",ethetai
4479         enddo
4480         if (lprn) then
4481         write (iout,*) "cosph and sinph"
4482         do k=1,nsingle
4483           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4484         enddo
4485         write (iout,*) "cosph1ph2 and sinph2ph2"
4486         do k=2,ndouble
4487           do l=1,k-1
4488             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4489      &         sinph1ph2(l,k),sinph1ph2(k,l)
4490           enddo
4491         enddo
4492         write(iout,*) "ethetai",ethetai
4493         endif
4494         do m=1,ntheterm2
4495           do k=1,nsingle
4496             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4497      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4498      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4499      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4500             ethetai=ethetai+sinkt(m)*aux
4501             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4502             dephii=dephii+k*sinkt(m)*(
4503      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4504      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4505             dephii1=dephii1+k*sinkt(m)*(
4506      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4507      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4508             if (lprn)
4509      &      write (iout,*) "m",m," k",k," bbthet",
4510      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4511      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4512      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4513      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4514           enddo
4515         enddo
4516         if (lprn)
4517      &  write(iout,*) "ethetai",ethetai
4518         do m=1,ntheterm3
4519           do k=2,ndouble
4520             do l=1,k-1
4521               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4522      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4523      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4524      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4525               ethetai=ethetai+sinkt(m)*aux
4526               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4527               dephii=dephii+l*sinkt(m)*(
4528      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4529      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4530      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4531      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4532               dephii1=dephii1+(k-l)*sinkt(m)*(
4533      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4534      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4535      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4536      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4537               if (lprn) then
4538               write (iout,*) "m",m," k",k," l",l," ffthet",
4539      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4540      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4541      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4542      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4543               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4544      &            cosph1ph2(k,l)*sinkt(m),
4545      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4546               endif
4547             enddo
4548           enddo
4549         enddo
4550 10      continue
4551         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4552      &   i,theta(i)*rad2deg,phii*rad2deg,
4553      &   phii1*rad2deg,ethetai
4554         etheta=etheta+ethetai
4555         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4556         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4557         gloc(nphi+i-2,icg)=wang*dethetai
4558       enddo
4559       return
4560       end
4561 #endif
4562 #ifdef CRYST_SC
4563 c-----------------------------------------------------------------------------
4564       subroutine esc(escloc)
4565 C Calculate the local energy of a side chain and its derivatives in the
4566 C corresponding virtual-bond valence angles THETA and the spherical angles
4567 C ALPHA and OMEGA.
4568       implicit real*8 (a-h,o-z)
4569       include 'DIMENSIONS'
4570       include 'COMMON.GEO'
4571       include 'COMMON.LOCAL'
4572       include 'COMMON.VAR'
4573       include 'COMMON.INTERACT'
4574       include 'COMMON.DERIV'
4575       include 'COMMON.CHAIN'
4576       include 'COMMON.IOUNITS'
4577       include 'COMMON.NAMES'
4578       include 'COMMON.FFIELD'
4579       include 'COMMON.CONTROL'
4580       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4581      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4582       common /sccalc/ time11,time12,time112,theti,it,nlobit
4583       delta=0.02d0*pi
4584       escloc=0.0D0
4585 c     write (iout,'(a)') 'ESC'
4586       do i=loc_start,loc_end
4587         it=itype(i)
4588         if (it.eq.10) goto 1
4589         nlobit=nlob(it)
4590 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4591 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4592         theti=theta(i+1)-pipol
4593         x(1)=dtan(theti)
4594         x(2)=alph(i)
4595         x(3)=omeg(i)
4596
4597         if (x(2).gt.pi-delta) then
4598           xtemp(1)=x(1)
4599           xtemp(2)=pi-delta
4600           xtemp(3)=x(3)
4601           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4602           xtemp(2)=pi
4603           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4604           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4605      &        escloci,dersc(2))
4606           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4607      &        ddersc0(1),dersc(1))
4608           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4609      &        ddersc0(3),dersc(3))
4610           xtemp(2)=pi-delta
4611           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4612           xtemp(2)=pi
4613           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4614           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4615      &            dersc0(2),esclocbi,dersc02)
4616           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4617      &            dersc12,dersc01)
4618           call splinthet(x(2),0.5d0*delta,ss,ssd)
4619           dersc0(1)=dersc01
4620           dersc0(2)=dersc02
4621           dersc0(3)=0.0d0
4622           do k=1,3
4623             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4624           enddo
4625           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4626 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4627 c    &             esclocbi,ss,ssd
4628           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4629 c         escloci=esclocbi
4630 c         write (iout,*) escloci
4631         else if (x(2).lt.delta) then
4632           xtemp(1)=x(1)
4633           xtemp(2)=delta
4634           xtemp(3)=x(3)
4635           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4636           xtemp(2)=0.0d0
4637           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4638           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4639      &        escloci,dersc(2))
4640           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4641      &        ddersc0(1),dersc(1))
4642           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4643      &        ddersc0(3),dersc(3))
4644           xtemp(2)=delta
4645           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4646           xtemp(2)=0.0d0
4647           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4648           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4649      &            dersc0(2),esclocbi,dersc02)
4650           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4651      &            dersc12,dersc01)
4652           dersc0(1)=dersc01
4653           dersc0(2)=dersc02
4654           dersc0(3)=0.0d0
4655           call splinthet(x(2),0.5d0*delta,ss,ssd)
4656           do k=1,3
4657             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4658           enddo
4659           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4660 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4661 c    &             esclocbi,ss,ssd
4662           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4663 c         write (iout,*) escloci
4664         else
4665           call enesc(x,escloci,dersc,ddummy,.false.)
4666         endif
4667
4668         escloc=escloc+escloci
4669         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4670      &     'escloc',i,escloci
4671 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4672
4673         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4674      &   wscloc*dersc(1)
4675         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4676         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4677     1   continue
4678       enddo
4679       return
4680       end
4681 C---------------------------------------------------------------------------
4682       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4683       implicit real*8 (a-h,o-z)
4684       include 'DIMENSIONS'
4685       include 'COMMON.GEO'
4686       include 'COMMON.LOCAL'
4687       include 'COMMON.IOUNITS'
4688       common /sccalc/ time11,time12,time112,theti,it,nlobit
4689       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4690       double precision contr(maxlob,-1:1)
4691       logical mixed
4692 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4693         escloc_i=0.0D0
4694         do j=1,3
4695           dersc(j)=0.0D0
4696           if (mixed) ddersc(j)=0.0d0
4697         enddo
4698         x3=x(3)
4699
4700 C Because of periodicity of the dependence of the SC energy in omega we have
4701 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4702 C To avoid underflows, first compute & store the exponents.
4703
4704         do iii=-1,1
4705
4706           x(3)=x3+iii*dwapi
4707
4708           do j=1,nlobit
4709             do k=1,3
4710               z(k)=x(k)-censc(k,j,it)
4711             enddo
4712             do k=1,3
4713               Axk=0.0D0
4714               do l=1,3
4715                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4716               enddo
4717               Ax(k,j,iii)=Axk
4718             enddo
4719             expfac=0.0D0
4720             do k=1,3
4721               expfac=expfac+Ax(k,j,iii)*z(k)
4722             enddo
4723             contr(j,iii)=expfac
4724           enddo ! j
4725
4726         enddo ! iii
4727
4728         x(3)=x3
4729 C As in the case of ebend, we want to avoid underflows in exponentiation and
4730 C subsequent NaNs and INFs in energy calculation.
4731 C Find the largest exponent
4732         emin=contr(1,-1)
4733         do iii=-1,1
4734           do j=1,nlobit
4735             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4736           enddo
4737         enddo
4738         emin=0.5D0*emin
4739 cd      print *,'it=',it,' emin=',emin
4740
4741 C Compute the contribution to SC energy and derivatives
4742         do iii=-1,1
4743
4744           do j=1,nlobit
4745 #ifdef OSF
4746             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4747             if(adexp.ne.adexp) adexp=1.0
4748             expfac=dexp(adexp)
4749 #else
4750             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4751 #endif
4752 cd          print *,'j=',j,' expfac=',expfac
4753             escloc_i=escloc_i+expfac
4754             do k=1,3
4755               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4756             enddo
4757             if (mixed) then
4758               do k=1,3,2
4759                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4760      &            +gaussc(k,2,j,it))*expfac
4761               enddo
4762             endif
4763           enddo
4764
4765         enddo ! iii
4766
4767         dersc(1)=dersc(1)/cos(theti)**2
4768         ddersc(1)=ddersc(1)/cos(theti)**2
4769         ddersc(3)=ddersc(3)
4770
4771         escloci=-(dlog(escloc_i)-emin)
4772         do j=1,3
4773           dersc(j)=dersc(j)/escloc_i
4774         enddo
4775         if (mixed) then
4776           do j=1,3,2
4777             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4778           enddo
4779         endif
4780       return
4781       end
4782 C------------------------------------------------------------------------------
4783       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4784       implicit real*8 (a-h,o-z)
4785       include 'DIMENSIONS'
4786       include 'COMMON.GEO'
4787       include 'COMMON.LOCAL'
4788       include 'COMMON.IOUNITS'
4789       common /sccalc/ time11,time12,time112,theti,it,nlobit
4790       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4791       double precision contr(maxlob)
4792       logical mixed
4793
4794       escloc_i=0.0D0
4795
4796       do j=1,3
4797         dersc(j)=0.0D0
4798       enddo
4799
4800       do j=1,nlobit
4801         do k=1,2
4802           z(k)=x(k)-censc(k,j,it)
4803         enddo
4804         z(3)=dwapi
4805         do k=1,3
4806           Axk=0.0D0
4807           do l=1,3
4808             Axk=Axk+gaussc(l,k,j,it)*z(l)
4809           enddo
4810           Ax(k,j)=Axk
4811         enddo
4812         expfac=0.0D0
4813         do k=1,3
4814           expfac=expfac+Ax(k,j)*z(k)
4815         enddo
4816         contr(j)=expfac
4817       enddo ! j
4818
4819 C As in the case of ebend, we want to avoid underflows in exponentiation and
4820 C subsequent NaNs and INFs in energy calculation.
4821 C Find the largest exponent
4822       emin=contr(1)
4823       do j=1,nlobit
4824         if (emin.gt.contr(j)) emin=contr(j)
4825       enddo
4826       emin=0.5D0*emin
4827
4828 C Compute the contribution to SC energy and derivatives
4829
4830       dersc12=0.0d0
4831       do j=1,nlobit
4832         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4833         escloc_i=escloc_i+expfac
4834         do k=1,2
4835           dersc(k)=dersc(k)+Ax(k,j)*expfac
4836         enddo
4837         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4838      &            +gaussc(1,2,j,it))*expfac
4839         dersc(3)=0.0d0
4840       enddo
4841
4842       dersc(1)=dersc(1)/cos(theti)**2
4843       dersc12=dersc12/cos(theti)**2
4844       escloci=-(dlog(escloc_i)-emin)
4845       do j=1,2
4846         dersc(j)=dersc(j)/escloc_i
4847       enddo
4848       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4849       return
4850       end
4851 #else
4852 c----------------------------------------------------------------------------------
4853       subroutine esc(escloc)
4854 C Calculate the local energy of a side chain and its derivatives in the
4855 C corresponding virtual-bond valence angles THETA and the spherical angles
4856 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4857 C added by Urszula Kozlowska. 07/11/2007
4858 C
4859       implicit real*8 (a-h,o-z)
4860       include 'DIMENSIONS'
4861       include 'COMMON.GEO'
4862       include 'COMMON.LOCAL'
4863       include 'COMMON.VAR'
4864       include 'COMMON.SCROT'
4865       include 'COMMON.INTERACT'
4866       include 'COMMON.DERIV'
4867       include 'COMMON.CHAIN'
4868       include 'COMMON.IOUNITS'
4869       include 'COMMON.NAMES'
4870       include 'COMMON.FFIELD'
4871       include 'COMMON.CONTROL'
4872       include 'COMMON.VECTORS'
4873       double precision x_prime(3),y_prime(3),z_prime(3)
4874      &    , sumene,dsc_i,dp2_i,x(65),
4875      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4876      &    de_dxx,de_dyy,de_dzz,de_dt
4877       double precision s1_t,s1_6_t,s2_t,s2_6_t
4878       double precision
4879      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4880      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4881      & dt_dCi(3),dt_dCi1(3)
4882       common /sccalc/ time11,time12,time112,theti,it,nlobit
4883       delta=0.02d0*pi
4884       escloc=0.0D0
4885       do i=loc_start,loc_end
4886         costtab(i+1) =dcos(theta(i+1))
4887         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4888         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4889         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4890         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4891         cosfac=dsqrt(cosfac2)
4892         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4893         sinfac=dsqrt(sinfac2)
4894         it=itype(i)
4895         if (it.eq.10) goto 1
4896 c
4897 C  Compute the axes of tghe local cartesian coordinates system; store in
4898 c   x_prime, y_prime and z_prime
4899 c
4900         do j=1,3
4901           x_prime(j) = 0.00
4902           y_prime(j) = 0.00
4903           z_prime(j) = 0.00
4904         enddo
4905 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4906 C     &   dc_norm(3,i+nres)
4907         do j = 1,3
4908           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4909           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4910         enddo
4911         do j = 1,3
4912           z_prime(j) = -uz(j,i-1)
4913         enddo
4914 c       write (2,*) "i",i
4915 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4916 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4917 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4918 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4919 c      & " xy",scalar(x_prime(1),y_prime(1)),
4920 c      & " xz",scalar(x_prime(1),z_prime(1)),
4921 c      & " yy",scalar(y_prime(1),y_prime(1)),
4922 c      & " yz",scalar(y_prime(1),z_prime(1)),
4923 c      & " zz",scalar(z_prime(1),z_prime(1))
4924 c
4925 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4926 C to local coordinate system. Store in xx, yy, zz.
4927 c
4928         xx=0.0d0
4929         yy=0.0d0
4930         zz=0.0d0
4931         do j = 1,3
4932           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4933           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4934           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4935         enddo
4936
4937         xxtab(i)=xx
4938         yytab(i)=yy
4939         zztab(i)=zz
4940 C
4941 C Compute the energy of the ith side cbain
4942 C
4943 c        write (2,*) "xx",xx," yy",yy," zz",zz
4944         it=itype(i)
4945         do j = 1,65
4946           x(j) = sc_parmin(j,it)
4947         enddo
4948 #ifdef CHECK_COORD
4949 Cc diagnostics - remove later
4950         xx1 = dcos(alph(2))
4951         yy1 = dsin(alph(2))*dcos(omeg(2))
4952         zz1 = -dsin(alph(2))*dsin(omeg(2))
4953         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4954      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4955      &    xx1,yy1,zz1
4956 C,"  --- ", xx_w,yy_w,zz_w
4957 c end diagnostics
4958 #endif
4959         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4960      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4961      &   + x(10)*yy*zz
4962         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4963      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4964      & + x(20)*yy*zz
4965         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4966      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4967      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4968      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4969      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4970      &  +x(40)*xx*yy*zz
4971         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4972      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4973      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4974      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4975      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4976      &  +x(60)*xx*yy*zz
4977         dsc_i   = 0.743d0+x(61)
4978         dp2_i   = 1.9d0+x(62)
4979         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4980      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4981         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4982      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4983         s1=(1+x(63))/(0.1d0 + dscp1)
4984         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4985         s2=(1+x(65))/(0.1d0 + dscp2)
4986         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4987         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4988      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4989 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4990 c     &   sumene4,
4991 c     &   dscp1,dscp2,sumene
4992 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4993         escloc = escloc + sumene
4994 c        write (2,*) "i",i," escloc",sumene,escloc
4995 #ifdef DEBUG
4996 C
4997 C This section to check the numerical derivatives of the energy of ith side
4998 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4999 C #define DEBUG in the code to turn it on.
5000 C
5001         write (2,*) "sumene               =",sumene
5002         aincr=1.0d-7
5003         xxsave=xx
5004         xx=xx+aincr
5005         write (2,*) xx,yy,zz
5006         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5007         de_dxx_num=(sumenep-sumene)/aincr
5008         xx=xxsave
5009         write (2,*) "xx+ sumene from enesc=",sumenep
5010         yysave=yy
5011         yy=yy+aincr
5012         write (2,*) xx,yy,zz
5013         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5014         de_dyy_num=(sumenep-sumene)/aincr
5015         yy=yysave
5016         write (2,*) "yy+ sumene from enesc=",sumenep
5017         zzsave=zz
5018         zz=zz+aincr
5019         write (2,*) xx,yy,zz
5020         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5021         de_dzz_num=(sumenep-sumene)/aincr
5022         zz=zzsave
5023         write (2,*) "zz+ sumene from enesc=",sumenep
5024         costsave=cost2tab(i+1)
5025         sintsave=sint2tab(i+1)
5026         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5027         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5028         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5029         de_dt_num=(sumenep-sumene)/aincr
5030         write (2,*) " t+ sumene from enesc=",sumenep
5031         cost2tab(i+1)=costsave
5032         sint2tab(i+1)=sintsave
5033 C End of diagnostics section.
5034 #endif
5035 C
5036 C Compute the gradient of esc
5037 C
5038         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5039         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5040         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5041         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5042         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5043         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5044         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5045         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5046         pom1=(sumene3*sint2tab(i+1)+sumene1)
5047      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5048         pom2=(sumene4*cost2tab(i+1)+sumene2)
5049      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5050         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5051         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5052      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5053      &  +x(40)*yy*zz
5054         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5055         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5056      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5057      &  +x(60)*yy*zz
5058         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5059      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5060      &        +(pom1+pom2)*pom_dx
5061 #ifdef DEBUG
5062         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5063 #endif
5064 C
5065         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5066         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5067      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5068      &  +x(40)*xx*zz
5069         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5070         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5071      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5072      &  +x(59)*zz**2 +x(60)*xx*zz
5073         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5074      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5075      &        +(pom1-pom2)*pom_dy
5076 #ifdef DEBUG
5077         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5078 #endif
5079 C
5080         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5081      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5082      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5083      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5084      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5085      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5086      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5087      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5088 #ifdef DEBUG
5089         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5090 #endif
5091 C
5092         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5093      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5094      &  +pom1*pom_dt1+pom2*pom_dt2
5095 #ifdef DEBUG
5096         write(2,*), "de_dt = ", de_dt,de_dt_num
5097 #endif
5098 c
5099 C
5100        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5101        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5102        cosfac2xx=cosfac2*xx
5103        sinfac2yy=sinfac2*yy
5104        do k = 1,3
5105          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5106      &      vbld_inv(i+1)
5107          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5108      &      vbld_inv(i)
5109          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5110          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5111 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5112 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5113 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5114 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5115          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5116          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5117          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5118          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5119          dZZ_Ci1(k)=0.0d0
5120          dZZ_Ci(k)=0.0d0
5121          do j=1,3
5122            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5123            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5124          enddo
5125
5126          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5127          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5128          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5129 c
5130          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5131          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5132        enddo
5133
5134        do k=1,3
5135          dXX_Ctab(k,i)=dXX_Ci(k)
5136          dXX_C1tab(k,i)=dXX_Ci1(k)
5137          dYY_Ctab(k,i)=dYY_Ci(k)
5138          dYY_C1tab(k,i)=dYY_Ci1(k)
5139          dZZ_Ctab(k,i)=dZZ_Ci(k)
5140          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5141          dXX_XYZtab(k,i)=dXX_XYZ(k)
5142          dYY_XYZtab(k,i)=dYY_XYZ(k)
5143          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5144        enddo
5145
5146        do k = 1,3
5147 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5148 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5149 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5150 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5151 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5152 c     &    dt_dci(k)
5153 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5154 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5155          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5156      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5157          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5158      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5159          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5160      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5161        enddo
5162 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5163 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5164
5165 C to check gradient call subroutine check_grad
5166
5167     1 continue
5168       enddo
5169       return
5170       end
5171 c------------------------------------------------------------------------------
5172       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5173       implicit none
5174       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5175      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5176       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5177      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5178      &   + x(10)*yy*zz
5179       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5180      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5181      & + x(20)*yy*zz
5182       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5183      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5184      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5185      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5186      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5187      &  +x(40)*xx*yy*zz
5188       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5189      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5190      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5191      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5192      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5193      &  +x(60)*xx*yy*zz
5194       dsc_i   = 0.743d0+x(61)
5195       dp2_i   = 1.9d0+x(62)
5196       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5197      &          *(xx*cost2+yy*sint2))
5198       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5199      &          *(xx*cost2-yy*sint2))
5200       s1=(1+x(63))/(0.1d0 + dscp1)
5201       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5202       s2=(1+x(65))/(0.1d0 + dscp2)
5203       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5204       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5205      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5206       enesc=sumene
5207       return
5208       end
5209 #endif
5210 c------------------------------------------------------------------------------
5211       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5212 C
5213 C This procedure calculates two-body contact function g(rij) and its derivative:
5214 C
5215 C           eps0ij                                     !       x < -1
5216 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5217 C            0                                         !       x > 1
5218 C
5219 C where x=(rij-r0ij)/delta
5220 C
5221 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5222 C
5223       implicit none
5224       double precision rij,r0ij,eps0ij,fcont,fprimcont
5225       double precision x,x2,x4,delta
5226 c     delta=0.02D0*r0ij
5227 c      delta=0.2D0*r0ij
5228       x=(rij-r0ij)/delta
5229       if (x.lt.-1.0D0) then
5230         fcont=eps0ij
5231         fprimcont=0.0D0
5232       else if (x.le.1.0D0) then
5233         x2=x*x
5234         x4=x2*x2
5235         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5236         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5237       else
5238         fcont=0.0D0
5239         fprimcont=0.0D0
5240       endif
5241       return
5242       end
5243 c------------------------------------------------------------------------------
5244       subroutine splinthet(theti,delta,ss,ssder)
5245       implicit real*8 (a-h,o-z)
5246       include 'DIMENSIONS'
5247       include 'COMMON.VAR'
5248       include 'COMMON.GEO'
5249       thetup=pi-delta
5250       thetlow=delta
5251       if (theti.gt.pipol) then
5252         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5253       else
5254         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5255         ssder=-ssder
5256       endif
5257       return
5258       end
5259 c------------------------------------------------------------------------------
5260       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5261       implicit none
5262       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5263       double precision ksi,ksi2,ksi3,a1,a2,a3
5264       a1=fprim0*delta/(f1-f0)
5265       a2=3.0d0-2.0d0*a1
5266       a3=a1-2.0d0
5267       ksi=(x-x0)/delta
5268       ksi2=ksi*ksi
5269       ksi3=ksi2*ksi
5270       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5271       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5272       return
5273       end
5274 c------------------------------------------------------------------------------
5275       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5276       implicit none
5277       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5278       double precision ksi,ksi2,ksi3,a1,a2,a3
5279       ksi=(x-x0)/delta
5280       ksi2=ksi*ksi
5281       ksi3=ksi2*ksi
5282       a1=fprim0x*delta
5283       a2=3*(f1x-f0x)-2*fprim0x*delta
5284       a3=fprim0x*delta-2*(f1x-f0x)
5285       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5286       return
5287       end
5288 C-----------------------------------------------------------------------------
5289 #ifdef CRYST_TOR
5290 C-----------------------------------------------------------------------------
5291       subroutine etor(etors,edihcnstr)
5292       implicit real*8 (a-h,o-z)
5293       include 'DIMENSIONS'
5294       include 'COMMON.VAR'
5295       include 'COMMON.GEO'
5296       include 'COMMON.LOCAL'
5297       include 'COMMON.TORSION'
5298       include 'COMMON.INTERACT'
5299       include 'COMMON.DERIV'
5300       include 'COMMON.CHAIN'
5301       include 'COMMON.NAMES'
5302       include 'COMMON.IOUNITS'
5303       include 'COMMON.FFIELD'
5304       include 'COMMON.TORCNSTR'
5305       include 'COMMON.CONTROL'
5306       logical lprn
5307 C Set lprn=.true. for debugging
5308       lprn=.false.
5309 c      lprn=.true.
5310       etors=0.0D0
5311       do i=iphi_start,iphi_end
5312       etors_ii=0.0D0
5313         itori=itortyp(itype(i-2))
5314         itori1=itortyp(itype(i-1))
5315         phii=phi(i)
5316         gloci=0.0D0
5317 C Proline-Proline pair is a special case...
5318         if (itori.eq.3 .and. itori1.eq.3) then
5319           if (phii.gt.-dwapi3) then
5320             cosphi=dcos(3*phii)
5321             fac=1.0D0/(1.0D0-cosphi)
5322             etorsi=v1(1,3,3)*fac
5323             etorsi=etorsi+etorsi
5324             etors=etors+etorsi-v1(1,3,3)
5325             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5326             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5327           endif
5328           do j=1,3
5329             v1ij=v1(j+1,itori,itori1)
5330             v2ij=v2(j+1,itori,itori1)
5331             cosphi=dcos(j*phii)
5332             sinphi=dsin(j*phii)
5333             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5334             if (energy_dec) etors_ii=etors_ii+
5335      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5336             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5337           enddo
5338         else
5339           do j=1,nterm_old
5340             v1ij=v1(j,itori,itori1)
5341             v2ij=v2(j,itori,itori1)
5342             cosphi=dcos(j*phii)
5343             sinphi=dsin(j*phii)
5344             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5345             if (energy_dec) etors_ii=etors_ii+
5346      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5347             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5348           enddo
5349         endif
5350         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5351              'etor',i,etors_ii
5352         if (lprn)
5353      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5354      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5355      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5356         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5357 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5358       enddo
5359 ! 6/20/98 - dihedral angle constraints
5360       edihcnstr=0.0d0
5361       do i=1,ndih_constr
5362         itori=idih_constr(i)
5363         phii=phi(itori)
5364         difi=phii-phi0(i)
5365         if (difi.gt.drange(i)) then
5366           difi=difi-drange(i)
5367           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5368           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5369         else if (difi.lt.-drange(i)) then
5370           difi=difi+drange(i)
5371           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5372           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5373         endif
5374 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5375 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5376       enddo
5377 !      write (iout,*) 'edihcnstr',edihcnstr
5378       return
5379       end
5380 c------------------------------------------------------------------------------
5381       subroutine etor_d(etors_d)
5382       etors_d=0.0d0
5383       return
5384       end
5385 c----------------------------------------------------------------------------
5386 #else
5387       subroutine etor(etors,edihcnstr)
5388       implicit real*8 (a-h,o-z)
5389       include 'DIMENSIONS'
5390       include 'COMMON.VAR'
5391       include 'COMMON.GEO'
5392       include 'COMMON.LOCAL'
5393       include 'COMMON.TORSION'
5394       include 'COMMON.INTERACT'
5395       include 'COMMON.DERIV'
5396       include 'COMMON.CHAIN'
5397       include 'COMMON.NAMES'
5398       include 'COMMON.IOUNITS'
5399       include 'COMMON.FFIELD'
5400       include 'COMMON.TORCNSTR'
5401       include 'COMMON.CONTROL'
5402       logical lprn
5403 C Set lprn=.true. for debugging
5404       lprn=.false.
5405 c     lprn=.true.
5406       etors=0.0D0
5407       do i=iphi_start,iphi_end
5408       etors_ii=0.0D0
5409         itori=itortyp(itype(i-2))
5410         itori1=itortyp(itype(i-1))
5411         phii=phi(i)
5412         gloci=0.0D0
5413 C Regular cosine and sine terms
5414         do j=1,nterm(itori,itori1)
5415           v1ij=v1(j,itori,itori1)
5416           v2ij=v2(j,itori,itori1)
5417           cosphi=dcos(j*phii)
5418           sinphi=dsin(j*phii)
5419           etors=etors+v1ij*cosphi+v2ij*sinphi
5420           if (energy_dec) etors_ii=etors_ii+
5421      &                v1ij*cosphi+v2ij*sinphi
5422           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5423         enddo
5424 C Lorentz terms
5425 C                         v1
5426 C  E = SUM ----------------------------------- - v1
5427 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5428 C
5429         cosphi=dcos(0.5d0*phii)
5430         sinphi=dsin(0.5d0*phii)
5431         do j=1,nlor(itori,itori1)
5432           vl1ij=vlor1(j,itori,itori1)
5433           vl2ij=vlor2(j,itori,itori1)
5434           vl3ij=vlor3(j,itori,itori1)
5435           pom=vl2ij*cosphi+vl3ij*sinphi
5436           pom1=1.0d0/(pom*pom+1.0d0)
5437           etors=etors+vl1ij*pom1
5438           if (energy_dec) etors_ii=etors_ii+
5439      &                vl1ij*pom1
5440           pom=-pom*pom1*pom1
5441           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5442         enddo
5443 C Subtract the constant term
5444         etors=etors-v0(itori,itori1)
5445           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5446      &         'etor',i,etors_ii-v0(itori,itori1)
5447         if (lprn)
5448      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5449      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5450      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5451         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5452 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5453       enddo
5454 ! 6/20/98 - dihedral angle constraints
5455       edihcnstr=0.0d0
5456 c      do i=1,ndih_constr
5457       do i=idihconstr_start,idihconstr_end
5458         itori=idih_constr(i)
5459         phii=phi(itori)
5460         difi=pinorm(phii-phi0(i))
5461         if (difi.gt.drange(i)) then
5462           difi=difi-drange(i)
5463           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5464           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5465         else if (difi.lt.-drange(i)) then
5466           difi=difi+drange(i)
5467           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5468           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5469         else
5470           difi=0.0
5471         endif
5472 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5473 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5474 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5475       enddo
5476 cd       write (iout,*) 'edihcnstr',edihcnstr
5477       return
5478       end
5479 c----------------------------------------------------------------------------
5480       subroutine etor_d(etors_d)
5481 C 6/23/01 Compute double torsional energy
5482       implicit real*8 (a-h,o-z)
5483       include 'DIMENSIONS'
5484       include 'COMMON.VAR'
5485       include 'COMMON.GEO'
5486       include 'COMMON.LOCAL'
5487       include 'COMMON.TORSION'
5488       include 'COMMON.INTERACT'
5489       include 'COMMON.DERIV'
5490       include 'COMMON.CHAIN'
5491       include 'COMMON.NAMES'
5492       include 'COMMON.IOUNITS'
5493       include 'COMMON.FFIELD'
5494       include 'COMMON.TORCNSTR'
5495       logical lprn
5496 C Set lprn=.true. for debugging
5497       lprn=.false.
5498 c     lprn=.true.
5499       etors_d=0.0D0
5500       do i=iphid_start,iphid_end
5501         itori=itortyp(itype(i-2))
5502         itori1=itortyp(itype(i-1))
5503         itori2=itortyp(itype(i))
5504         phii=phi(i)
5505         phii1=phi(i+1)
5506         gloci1=0.0D0
5507         gloci2=0.0D0
5508 C Regular cosine and sine terms
5509         do j=1,ntermd_1(itori,itori1,itori2)
5510           v1cij=v1c(1,j,itori,itori1,itori2)
5511           v1sij=v1s(1,j,itori,itori1,itori2)
5512           v2cij=v1c(2,j,itori,itori1,itori2)
5513           v2sij=v1s(2,j,itori,itori1,itori2)
5514           cosphi1=dcos(j*phii)
5515           sinphi1=dsin(j*phii)
5516           cosphi2=dcos(j*phii1)
5517           sinphi2=dsin(j*phii1)
5518           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5519      &     v2cij*cosphi2+v2sij*sinphi2
5520           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5521           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5522         enddo
5523         do k=2,ntermd_2(itori,itori1,itori2)
5524           do l=1,k-1
5525             v1cdij = v2c(k,l,itori,itori1,itori2)
5526             v2cdij = v2c(l,k,itori,itori1,itori2)
5527             v1sdij = v2s(k,l,itori,itori1,itori2)
5528             v2sdij = v2s(l,k,itori,itori1,itori2)
5529             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5530             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5531             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5532             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5533             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5534      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5535             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5536      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5537             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5538      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5539           enddo
5540         enddo
5541         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5542         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5543       enddo
5544       return
5545       end
5546 #endif
5547 c------------------------------------------------------------------------------
5548       subroutine eback_sc_corr(esccor)
5549 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5550 c        conformational states; temporarily implemented as differences
5551 c        between UNRES torsional potentials (dependent on three types of
5552 c        residues) and the torsional potentials dependent on all 20 types
5553 c        of residues computed from AM1  energy surfaces of terminally-blocked
5554 c        amino-acid residues.
5555       implicit real*8 (a-h,o-z)
5556       include 'DIMENSIONS'
5557       include 'COMMON.VAR'
5558       include 'COMMON.GEO'
5559       include 'COMMON.LOCAL'
5560       include 'COMMON.TORSION'
5561       include 'COMMON.SCCOR'
5562       include 'COMMON.INTERACT'
5563       include 'COMMON.DERIV'
5564       include 'COMMON.CHAIN'
5565       include 'COMMON.NAMES'
5566       include 'COMMON.IOUNITS'
5567       include 'COMMON.FFIELD'
5568       include 'COMMON.CONTROL'
5569       logical lprn
5570 C Set lprn=.true. for debugging
5571       lprn=.false.
5572 c      lprn=.true.
5573 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5574       esccor=0.0D0
5575       do i=iphi_start,iphi_end
5576         esccor_ii=0.0D0
5577         itori=itype(i-2)
5578         itori1=itype(i-1)
5579         phii=phi(i)
5580         gloci=0.0D0
5581         do j=1,nterm_sccor
5582           v1ij=v1sccor(j,itori,itori1)
5583           v2ij=v2sccor(j,itori,itori1)
5584           cosphi=dcos(j*phii)
5585           sinphi=dsin(j*phii)
5586           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5587           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5588         enddo
5589         if (lprn)
5590      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5591      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5592      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5593         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5594       enddo
5595       return
5596       end
5597 c----------------------------------------------------------------------------
5598       subroutine multibody(ecorr)
5599 C This subroutine calculates multi-body contributions to energy following
5600 C the idea of Skolnick et al. If side chains I and J make a contact and
5601 C at the same time side chains I+1 and J+1 make a contact, an extra
5602 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5603       implicit real*8 (a-h,o-z)
5604       include 'DIMENSIONS'
5605       include 'COMMON.IOUNITS'
5606       include 'COMMON.DERIV'
5607       include 'COMMON.INTERACT'
5608       include 'COMMON.CONTACTS'
5609       double precision gx(3),gx1(3)
5610       logical lprn
5611
5612 C Set lprn=.true. for debugging
5613       lprn=.false.
5614
5615       if (lprn) then
5616         write (iout,'(a)') 'Contact function values:'
5617         do i=nnt,nct-2
5618           write (iout,'(i2,20(1x,i2,f10.5))')
5619      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5620         enddo
5621       endif
5622       ecorr=0.0D0
5623       do i=nnt,nct
5624         do j=1,3
5625           gradcorr(j,i)=0.0D0
5626           gradxorr(j,i)=0.0D0
5627         enddo
5628       enddo
5629       do i=nnt,nct-2
5630
5631         DO ISHIFT = 3,4
5632
5633         i1=i+ishift
5634         num_conti=num_cont(i)
5635         num_conti1=num_cont(i1)
5636         do jj=1,num_conti
5637           j=jcont(jj,i)
5638           do kk=1,num_conti1
5639             j1=jcont(kk,i1)
5640             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5641 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5642 cd   &                   ' ishift=',ishift
5643 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5644 C The system gains extra energy.
5645               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5646             endif   ! j1==j+-ishift
5647           enddo     ! kk
5648         enddo       ! jj
5649
5650         ENDDO ! ISHIFT
5651
5652       enddo         ! i
5653       return
5654       end
5655 c------------------------------------------------------------------------------
5656       double precision function esccorr(i,j,k,l,jj,kk)
5657       implicit real*8 (a-h,o-z)
5658       include 'DIMENSIONS'
5659       include 'COMMON.IOUNITS'
5660       include 'COMMON.DERIV'
5661       include 'COMMON.INTERACT'
5662       include 'COMMON.CONTACTS'
5663       double precision gx(3),gx1(3)
5664       logical lprn
5665       lprn=.false.
5666       eij=facont(jj,i)
5667       ekl=facont(kk,k)
5668 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5669 C Calculate the multi-body contribution to energy.
5670 C Calculate multi-body contributions to the gradient.
5671 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5672 cd   & k,l,(gacont(m,kk,k),m=1,3)
5673       do m=1,3
5674         gx(m) =ekl*gacont(m,jj,i)
5675         gx1(m)=eij*gacont(m,kk,k)
5676         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5677         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5678         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5679         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5680       enddo
5681       do m=i,j-1
5682         do ll=1,3
5683           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5684         enddo
5685       enddo
5686       do m=k,l-1
5687         do ll=1,3
5688           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5689         enddo
5690       enddo
5691       esccorr=-eij*ekl
5692       return
5693       end
5694 c------------------------------------------------------------------------------
5695       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5696 C This subroutine calculates multi-body contributions to hydrogen-bonding
5697       implicit real*8 (a-h,o-z)
5698       include 'DIMENSIONS'
5699       include 'COMMON.IOUNITS'
5700 #ifdef MPI
5701       include "mpif.h"
5702       parameter (max_cont=maxconts)
5703       parameter (max_dim=26)
5704       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5705       double precision zapas(max_dim,maxconts,max_fg_procs),
5706      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5707       common /przechowalnia/ zapas
5708       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5709      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5710 #endif
5711       include 'COMMON.SETUP'
5712       include 'COMMON.FFIELD'
5713       include 'COMMON.DERIV'
5714       include 'COMMON.INTERACT'
5715       include 'COMMON.CONTACTS'
5716       include 'COMMON.CONTROL'
5717       include 'COMMON.LOCAL'
5718       double precision gx(3),gx1(3),time00
5719       logical lprn,ldone
5720
5721 C Set lprn=.true. for debugging
5722       lprn=.false.
5723 #ifdef MPI
5724       n_corr=0
5725       n_corr1=0
5726       if (nfgtasks.le.1) goto 30
5727       if (lprn) then
5728         write (iout,'(a)') 'Contact function values before RECEIVE:'
5729         do i=nnt,nct-2
5730           write (iout,'(2i3,50(1x,i2,f5.2))')
5731      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5732      &    j=1,num_cont_hb(i))
5733         enddo
5734       endif
5735       call flush(iout)
5736       do i=1,ntask_cont_from
5737         ncont_recv(i)=0
5738       enddo
5739       do i=1,ntask_cont_to
5740         ncont_sent(i)=0
5741       enddo
5742 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5743 c     & ntask_cont_to
5744 C Make the list of contacts to send to send to other procesors
5745 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5746 c      call flush(iout)
5747       do i=iturn3_start,iturn3_end
5748 c        write (iout,*) "make contact list turn3",i," num_cont",
5749 c     &    num_cont_hb(i)
5750         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5751       enddo
5752       do i=iturn4_start,iturn4_end
5753 c        write (iout,*) "make contact list turn4",i," num_cont",
5754 c     &   num_cont_hb(i)
5755         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5756       enddo
5757       do ii=1,nat_sent
5758         i=iat_sent(ii)
5759 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5760 c     &    num_cont_hb(i)
5761         do j=1,num_cont_hb(i)
5762         do k=1,4
5763           jjc=jcont_hb(j,i)
5764           iproc=iint_sent_local(k,jjc,ii)
5765 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5766           if (iproc.gt.0) then
5767             ncont_sent(iproc)=ncont_sent(iproc)+1
5768             nn=ncont_sent(iproc)
5769             zapas(1,nn,iproc)=i
5770             zapas(2,nn,iproc)=jjc
5771             zapas(3,nn,iproc)=facont_hb(j,i)
5772             zapas(4,nn,iproc)=ees0p(j,i)
5773             zapas(5,nn,iproc)=ees0m(j,i)
5774             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5775             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5776             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5777             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5778             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5779             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5780             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5781             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5782             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5783             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5784             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5785             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5786             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5787             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5788             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5789             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5790             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5791             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5792             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5793             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5794             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5795           endif
5796         enddo
5797         enddo
5798       enddo
5799       if (lprn) then
5800       write (iout,*)
5801      &  "Numbers of contacts to be sent to other processors",
5802      &  (ncont_sent(i),i=1,ntask_cont_to)
5803       write (iout,*) "Contacts sent"
5804       do ii=1,ntask_cont_to
5805         nn=ncont_sent(ii)
5806         iproc=itask_cont_to(ii)
5807         write (iout,*) nn," contacts to processor",iproc,
5808      &   " of CONT_TO_COMM group"
5809         do i=1,nn
5810           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5811         enddo
5812       enddo
5813       call flush(iout)
5814       endif
5815       CorrelType=477
5816       CorrelID=fg_rank+1
5817       CorrelType1=478
5818       CorrelID1=nfgtasks+fg_rank+1
5819       ireq=0
5820 C Receive the numbers of needed contacts from other processors
5821       do ii=1,ntask_cont_from
5822         iproc=itask_cont_from(ii)
5823         ireq=ireq+1
5824         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
5825      &    FG_COMM,req(ireq),IERR)
5826       enddo
5827 c      write (iout,*) "IRECV ended"
5828 c      call flush(iout)
5829 C Send the number of contacts needed by other processors
5830       do ii=1,ntask_cont_to
5831         iproc=itask_cont_to(ii)
5832         ireq=ireq+1
5833         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
5834      &    FG_COMM,req(ireq),IERR)
5835       enddo
5836 c      write (iout,*) "ISEND ended"
5837 c      write (iout,*) "number of requests (nn)",ireq
5838       call flush(iout)
5839       if (ireq.gt.0)
5840      &  call MPI_Waitall(ireq,req,status_array,ierr)
5841 c      write (iout,*)
5842 c     &  "Numbers of contacts to be received from other processors",
5843 c     &  (ncont_recv(i),i=1,ntask_cont_from)
5844 c      call flush(iout)
5845 C Receive contacts
5846       ireq=0
5847       do ii=1,ntask_cont_from
5848         iproc=itask_cont_from(ii)
5849         nn=ncont_recv(ii)
5850 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
5851 c     &   " of CONT_TO_COMM group"
5852         call flush(iout)
5853         if (nn.gt.0) then
5854           ireq=ireq+1
5855           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
5856      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5857 c          write (iout,*) "ireq,req",ireq,req(ireq)
5858         endif
5859       enddo
5860 C Send the contacts to processors that need them
5861       do ii=1,ntask_cont_to
5862         iproc=itask_cont_to(ii)
5863         nn=ncont_sent(ii)
5864 c        write (iout,*) nn," contacts to processor",iproc,
5865 c     &   " of CONT_TO_COMM group"
5866         if (nn.gt.0) then
5867           ireq=ireq+1
5868           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
5869      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5870 c          write (iout,*) "ireq,req",ireq,req(ireq)
5871 c          do i=1,nn
5872 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5873 c          enddo
5874         endif
5875       enddo
5876 c      write (iout,*) "number of requests (contacts)",ireq
5877 c      write (iout,*) "req",(req(i),i=1,4)
5878 c      call flush(iout)
5879       if (ireq.gt.0)
5880      & call MPI_Waitall(ireq,req,status_array,ierr)
5881       do iii=1,ntask_cont_from
5882         iproc=itask_cont_from(iii)
5883         nn=ncont_recv(iii)
5884         if (lprn) then
5885         write (iout,*) "Received",nn," contacts from processor",iproc,
5886      &   " of CONT_FROM_COMM group"
5887         call flush(iout)
5888         do i=1,nn
5889           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
5890         enddo
5891         call flush(iout)
5892         endif
5893         do i=1,nn
5894           ii=zapas_recv(1,i,iii)
5895 c Flag the received contacts to prevent double-counting
5896           jj=-zapas_recv(2,i,iii)
5897 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
5898 c          call flush(iout)
5899           nnn=num_cont_hb(ii)+1
5900           num_cont_hb(ii)=nnn
5901           jcont_hb(nnn,ii)=jj
5902           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
5903           ees0p(nnn,ii)=zapas_recv(4,i,iii)
5904           ees0m(nnn,ii)=zapas_recv(5,i,iii)
5905           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
5906           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
5907           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
5908           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
5909           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
5910           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
5911           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
5912           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
5913           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
5914           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
5915           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
5916           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
5917           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
5918           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
5919           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
5920           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
5921           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
5922           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
5923           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
5924           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
5925           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
5926         enddo
5927       enddo
5928       call flush(iout)
5929       if (lprn) then
5930         write (iout,'(a)') 'Contact function values after receive:'
5931         do i=nnt,nct-2
5932           write (iout,'(2i3,50(1x,i3,f5.2))')
5933      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5934      &    j=1,num_cont_hb(i))
5935         enddo
5936         call flush(iout)
5937       endif
5938    30 continue
5939 #endif
5940       if (lprn) then
5941         write (iout,'(a)') 'Contact function values:'
5942         do i=nnt,nct-2
5943           write (iout,'(2i3,50(1x,i3,f5.2))')
5944      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5945      &    j=1,num_cont_hb(i))
5946         enddo
5947       endif
5948       ecorr=0.0D0
5949 C Remove the loop below after debugging !!!
5950       do i=nnt,nct
5951         do j=1,3
5952           gradcorr(j,i)=0.0D0
5953           gradxorr(j,i)=0.0D0
5954         enddo
5955       enddo
5956 C Calculate the local-electrostatic correlation terms
5957       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
5958         i1=i+1
5959         num_conti=num_cont_hb(i)
5960         num_conti1=num_cont_hb(i+1)
5961         do jj=1,num_conti
5962           j=jcont_hb(jj,i)
5963           jp=iabs(j)
5964           do kk=1,num_conti1
5965             j1=jcont_hb(kk,i1)
5966             jp1=iabs(j1)
5967 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5968 c     &         ' jj=',jj,' kk=',kk
5969             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
5970      &          .or. j.lt.0 .and. j1.gt.0) .and.
5971      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
5972 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5973 C The system gains extra energy.
5974               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
5975               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5976      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5977               n_corr=n_corr+1
5978             else if (j1.eq.j) then
5979 C Contacts I-J and I-(J+1) occur simultaneously.
5980 C The system loses extra energy.
5981 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5982             endif
5983           enddo ! kk
5984           do kk=1,num_conti
5985             j1=jcont_hb(kk,i)
5986 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5987 c    &         ' jj=',jj,' kk=',kk
5988             if (j1.eq.j+1) then
5989 C Contacts I-J and (I+1)-J occur simultaneously.
5990 C The system loses extra energy.
5991 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5992             endif ! j1==j+1
5993           enddo ! kk
5994         enddo ! jj
5995       enddo ! i
5996       return
5997       end
5998 c------------------------------------------------------------------------------
5999       subroutine add_hb_contact(ii,jj,itask)
6000       implicit real*8 (a-h,o-z)
6001       include "DIMENSIONS"
6002       include "COMMON.IOUNITS"
6003       integer max_cont
6004       integer max_dim
6005       parameter (max_cont=maxconts)
6006       parameter (max_dim=26)
6007       include "COMMON.CONTACTS"
6008       double precision zapas(max_dim,maxconts,max_fg_procs),
6009      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6010       common /przechowalnia/ zapas
6011       integer i,j,ii,jj,iproc,itask(4),nn
6012 c      write (iout,*) "itask",itask
6013       do i=1,2
6014         iproc=itask(i)
6015         if (iproc.gt.0) then
6016           do j=1,num_cont_hb(ii)
6017             jjc=jcont_hb(j,ii)
6018 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6019             if (jjc.eq.jj) then
6020               ncont_sent(iproc)=ncont_sent(iproc)+1
6021               nn=ncont_sent(iproc)
6022               zapas(1,nn,iproc)=ii
6023               zapas(2,nn,iproc)=jjc
6024               zapas(3,nn,iproc)=facont_hb(j,ii)
6025               zapas(4,nn,iproc)=ees0p(j,ii)
6026               zapas(5,nn,iproc)=ees0m(j,ii)
6027               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6028               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6029               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6030               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6031               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6032               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6033               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6034               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6035               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6036               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6037               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6038               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6039               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6040               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6041               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6042               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6043               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6044               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6045               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6046               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6047               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6048               exit
6049             endif
6050           enddo
6051         endif
6052       enddo
6053       return
6054       end
6055 c------------------------------------------------------------------------------
6056       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6057      &  n_corr1)
6058 C This subroutine calculates multi-body contributions to hydrogen-bonding
6059       implicit real*8 (a-h,o-z)
6060       include 'DIMENSIONS'
6061       include 'COMMON.IOUNITS'
6062 #ifdef MPI
6063       include "mpif.h"
6064       parameter (max_cont=maxconts)
6065       parameter (max_dim=70)
6066       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6067       double precision zapas(max_dim,maxconts,max_fg_procs),
6068      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6069       common /przechowalnia/ zapas
6070       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6071      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6072 #endif
6073       include 'COMMON.SETUP'
6074       include 'COMMON.FFIELD'
6075       include 'COMMON.DERIV'
6076       include 'COMMON.LOCAL'
6077       include 'COMMON.INTERACT'
6078       include 'COMMON.CONTACTS'
6079       include 'COMMON.CHAIN'
6080       include 'COMMON.CONTROL'
6081       double precision gx(3),gx1(3)
6082       integer num_cont_hb_old(maxres)
6083       logical lprn,ldone
6084       double precision eello4,eello5,eelo6,eello_turn6
6085       external eello4,eello5,eello6,eello_turn6
6086 C Set lprn=.true. for debugging
6087       lprn=.false.
6088       eturn6=0.0d0
6089 #ifdef MPI
6090       do i=1,nres
6091         num_cont_hb_old(i)=num_cont_hb(i)
6092       enddo
6093       n_corr=0
6094       n_corr1=0
6095       if (nfgtasks.le.1) goto 30
6096       if (lprn) then
6097         write (iout,'(a)') 'Contact function values before RECEIVE:'
6098         do i=nnt,nct-2
6099           write (iout,'(2i3,50(1x,i2,f5.2))')
6100      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6101      &    j=1,num_cont_hb(i))
6102         enddo
6103       endif
6104       call flush(iout)
6105       do i=1,ntask_cont_from
6106         ncont_recv(i)=0
6107       enddo
6108       do i=1,ntask_cont_to
6109         ncont_sent(i)=0
6110       enddo
6111 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6112 c     & ntask_cont_to
6113 C Make the list of contacts to send to send to other procesors
6114       do i=iturn3_start,iturn3_end
6115 c        write (iout,*) "make contact list turn3",i," num_cont",
6116 c     &    num_cont_hb(i)
6117         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6118       enddo
6119       do i=iturn4_start,iturn4_end
6120 c        write (iout,*) "make contact list turn4",i," num_cont",
6121 c     &   num_cont_hb(i)
6122         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6123       enddo
6124       do ii=1,nat_sent
6125         i=iat_sent(ii)
6126 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6127 c     &    num_cont_hb(i)
6128         do j=1,num_cont_hb(i)
6129         do k=1,4
6130           jjc=jcont_hb(j,i)
6131           iproc=iint_sent_local(k,jjc,ii)
6132 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6133           if (iproc.ne.0) then
6134             ncont_sent(iproc)=ncont_sent(iproc)+1
6135             nn=ncont_sent(iproc)
6136             zapas(1,nn,iproc)=i
6137             zapas(2,nn,iproc)=jjc
6138             zapas(3,nn,iproc)=d_cont(j,i)
6139             ind=3
6140             do kk=1,3
6141               ind=ind+1
6142               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6143             enddo
6144             do kk=1,2
6145               do ll=1,2
6146                 ind=ind+1
6147                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6148               enddo
6149             enddo
6150             do jj=1,5
6151               do kk=1,3
6152                 do ll=1,2
6153                   do mm=1,2
6154                     ind=ind+1
6155                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6156                   enddo
6157                 enddo
6158               enddo
6159             enddo
6160           endif
6161         enddo
6162         enddo
6163       enddo
6164       if (lprn) then
6165       write (iout,*)
6166      &  "Numbers of contacts to be sent to other processors",
6167      &  (ncont_sent(i),i=1,ntask_cont_to)
6168       write (iout,*) "Contacts sent"
6169       do ii=1,ntask_cont_to
6170         nn=ncont_sent(ii)
6171         iproc=itask_cont_to(ii)
6172         write (iout,*) nn," contacts to processor",iproc,
6173      &   " of CONT_TO_COMM group"
6174         do i=1,nn
6175           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6176         enddo
6177       enddo
6178       call flush(iout)
6179       endif
6180       CorrelType=477
6181       CorrelID=fg_rank+1
6182       CorrelType1=478
6183       CorrelID1=nfgtasks+fg_rank+1
6184       ireq=0
6185 C Receive the numbers of needed contacts from other processors
6186       do ii=1,ntask_cont_from
6187         iproc=itask_cont_from(ii)
6188         ireq=ireq+1
6189         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6190      &    FG_COMM,req(ireq),IERR)
6191       enddo
6192 c      write (iout,*) "IRECV ended"
6193 c      call flush(iout)
6194 C Send the number of contacts needed by other processors
6195       do ii=1,ntask_cont_to
6196         iproc=itask_cont_to(ii)
6197         ireq=ireq+1
6198         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6199      &    FG_COMM,req(ireq),IERR)
6200       enddo
6201 c      write (iout,*) "ISEND ended"
6202 c      write (iout,*) "number of requests (nn)",ireq
6203       call flush(iout)
6204       if (ireq.gt.0)
6205      &  call MPI_Waitall(ireq,req,status_array,ierr)
6206 c      write (iout,*)
6207 c     &  "Numbers of contacts to be received from other processors",
6208 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6209 c      call flush(iout)
6210 C Receive contacts
6211       ireq=0
6212       do ii=1,ntask_cont_from
6213         iproc=itask_cont_from(ii)
6214         nn=ncont_recv(ii)
6215 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6216 c     &   " of CONT_TO_COMM group"
6217         call flush(iout)
6218         if (nn.gt.0) then
6219           ireq=ireq+1
6220           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6221      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6222 c          write (iout,*) "ireq,req",ireq,req(ireq)
6223         endif
6224       enddo
6225 C Send the contacts to processors that need them
6226       do ii=1,ntask_cont_to
6227         iproc=itask_cont_to(ii)
6228         nn=ncont_sent(ii)
6229 c        write (iout,*) nn," contacts to processor",iproc,
6230 c     &   " of CONT_TO_COMM group"
6231         if (nn.gt.0) then
6232           ireq=ireq+1
6233           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6234      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6235 c          write (iout,*) "ireq,req",ireq,req(ireq)
6236 c          do i=1,nn
6237 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6238 c          enddo
6239         endif
6240       enddo
6241 c      write (iout,*) "number of requests (contacts)",ireq
6242 c      write (iout,*) "req",(req(i),i=1,4)
6243 c      call flush(iout)
6244       if (ireq.gt.0)
6245      & call MPI_Waitall(ireq,req,status_array,ierr)
6246       do iii=1,ntask_cont_from
6247         iproc=itask_cont_from(iii)
6248         nn=ncont_recv(iii)
6249         if (lprn) then
6250         write (iout,*) "Received",nn," contacts from processor",iproc,
6251      &   " of CONT_FROM_COMM group"
6252         call flush(iout)
6253         do i=1,nn
6254           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6255         enddo
6256         call flush(iout)
6257         endif
6258         do i=1,nn
6259           ii=zapas_recv(1,i,iii)
6260 c Flag the received contacts to prevent double-counting
6261           jj=-zapas_recv(2,i,iii)
6262 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6263 c          call flush(iout)
6264           nnn=num_cont_hb(ii)+1
6265           num_cont_hb(ii)=nnn
6266           jcont_hb(nnn,ii)=jj
6267           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6268           ind=3
6269           do kk=1,3
6270             ind=ind+1
6271             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6272           enddo
6273           do kk=1,2
6274             do ll=1,2
6275               ind=ind+1
6276               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6277             enddo
6278           enddo
6279           do jj=1,5
6280             do kk=1,3
6281               do ll=1,2
6282                 do mm=1,2
6283                   ind=ind+1
6284                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6285                 enddo
6286               enddo
6287             enddo
6288           enddo
6289         enddo
6290       enddo
6291       call flush(iout)
6292       if (lprn) then
6293         write (iout,'(a)') 'Contact function values after receive:'
6294         do i=nnt,nct-2
6295           write (iout,'(2i3,50(1x,i3,5f6.3))')
6296      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6297      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6298         enddo
6299         call flush(iout)
6300       endif
6301    30 continue
6302 #endif
6303       if (lprn) then
6304         write (iout,'(a)') 'Contact function values:'
6305         do i=nnt,nct-2
6306           write (iout,'(2i3,50(1x,i2,5f6.3))')
6307      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6308      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6309         enddo
6310       endif
6311       ecorr=0.0D0
6312       ecorr5=0.0d0
6313       ecorr6=0.0d0
6314 C Remove the loop below after debugging !!!
6315       do i=nnt,nct
6316         do j=1,3
6317           gradcorr(j,i)=0.0D0
6318           gradxorr(j,i)=0.0D0
6319         enddo
6320       enddo
6321 C Calculate the dipole-dipole interaction energies
6322       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6323       do i=iatel_s,iatel_e+1
6324         num_conti=num_cont_hb(i)
6325         do jj=1,num_conti
6326           j=jcont_hb(jj,i)
6327 #ifdef MOMENT
6328           call dipole(i,j,jj)
6329 #endif
6330         enddo
6331       enddo
6332       endif
6333 C Calculate the local-electrostatic correlation terms
6334 c                write (iout,*) "gradcorr5 in eello5 before loop"
6335 c                do iii=1,nres
6336 c                  write (iout,'(i5,3f10.5)')
6337 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6338 c                enddo
6339       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6340 c        write (iout,*) "corr loop i",i
6341         i1=i+1
6342         num_conti=num_cont_hb(i)
6343         num_conti1=num_cont_hb(i+1)
6344         do jj=1,num_conti
6345           j=jcont_hb(jj,i)
6346           jp=iabs(j)
6347           do kk=1,num_conti1
6348             j1=jcont_hb(kk,i1)
6349             jp1=iabs(j1)
6350 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6351 c     &         ' jj=',jj,' kk=',kk
6352 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6353             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6354      &          .or. j.lt.0 .and. j1.gt.0) .and.
6355      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6356 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6357 C The system gains extra energy.
6358               n_corr=n_corr+1
6359               sqd1=dsqrt(d_cont(jj,i))
6360               sqd2=dsqrt(d_cont(kk,i1))
6361               sred_geom = sqd1*sqd2
6362               IF (sred_geom.lt.cutoff_corr) THEN
6363                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6364      &            ekont,fprimcont)
6365 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6366 cd     &         ' jj=',jj,' kk=',kk
6367                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6368                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6369                 do l=1,3
6370                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6371                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6372                 enddo
6373                 n_corr1=n_corr1+1
6374 cd               write (iout,*) 'sred_geom=',sred_geom,
6375 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6376 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6377 cd               write (iout,*) "g_contij",g_contij
6378 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6379 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6380                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6381                 if (wcorr4.gt.0.0d0)
6382      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6383                   if (energy_dec.and.wcorr4.gt.0.0d0)
6384      1                 write (iout,'(a6,4i5,0pf7.3)')
6385      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6386 c                write (iout,*) "gradcorr5 before eello5"
6387 c                do iii=1,nres
6388 c                  write (iout,'(i5,3f10.5)')
6389 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6390 c                enddo
6391                 if (wcorr5.gt.0.0d0)
6392      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6393 c                write (iout,*) "gradcorr5 after eello5"
6394 c                do iii=1,nres
6395 c                  write (iout,'(i5,3f10.5)')
6396 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6397 c                enddo
6398                   if (energy_dec.and.wcorr5.gt.0.0d0)
6399      1                 write (iout,'(a6,4i5,0pf7.3)')
6400      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6401 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6402 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6403                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6404      &               .or. wturn6.eq.0.0d0))then
6405 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6406                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6407                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6408      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6409 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6410 cd     &            'ecorr6=',ecorr6
6411 cd                write (iout,'(4e15.5)') sred_geom,
6412 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6413 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6414 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6415                 else if (wturn6.gt.0.0d0
6416      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6417 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6418                   eturn6=eturn6+eello_turn6(i,jj,kk)
6419                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6420      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6421 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6422                 endif
6423               ENDIF
6424 1111          continue
6425             endif
6426           enddo ! kk
6427         enddo ! jj
6428       enddo ! i
6429       do i=1,nres
6430         num_cont_hb(i)=num_cont_hb_old(i)
6431       enddo
6432 c                write (iout,*) "gradcorr5 in eello5"
6433 c                do iii=1,nres
6434 c                  write (iout,'(i5,3f10.5)')
6435 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6436 c                enddo
6437       return
6438       end
6439 c------------------------------------------------------------------------------
6440       subroutine add_hb_contact_eello(ii,jj,itask)
6441       implicit real*8 (a-h,o-z)
6442       include "DIMENSIONS"
6443       include "COMMON.IOUNITS"
6444       integer max_cont
6445       integer max_dim
6446       parameter (max_cont=maxconts)
6447       parameter (max_dim=70)
6448       include "COMMON.CONTACTS"
6449       double precision zapas(max_dim,maxconts,max_fg_procs),
6450      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6451       common /przechowalnia/ zapas
6452       integer i,j,ii,jj,iproc,itask(4),nn
6453 c      write (iout,*) "itask",itask
6454       do i=1,2
6455         iproc=itask(i)
6456         if (iproc.gt.0) then
6457           do j=1,num_cont_hb(ii)
6458             jjc=jcont_hb(j,ii)
6459 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6460             if (jjc.eq.jj) then
6461               ncont_sent(iproc)=ncont_sent(iproc)+1
6462               nn=ncont_sent(iproc)
6463               zapas(1,nn,iproc)=ii
6464               zapas(2,nn,iproc)=jjc
6465               zapas(3,nn,iproc)=d_cont(j,ii)
6466               ind=3
6467               do kk=1,3
6468                 ind=ind+1
6469                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6470               enddo
6471               do kk=1,2
6472                 do ll=1,2
6473                   ind=ind+1
6474                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6475                 enddo
6476               enddo
6477               do jj=1,5
6478                 do kk=1,3
6479                   do ll=1,2
6480                     do mm=1,2
6481                       ind=ind+1
6482                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6483                     enddo
6484                   enddo
6485                 enddo
6486               enddo
6487               exit
6488             endif
6489           enddo
6490         endif
6491       enddo
6492       return
6493       end
6494 c------------------------------------------------------------------------------
6495       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6496       implicit real*8 (a-h,o-z)
6497       include 'DIMENSIONS'
6498       include 'COMMON.IOUNITS'
6499       include 'COMMON.DERIV'
6500       include 'COMMON.INTERACT'
6501       include 'COMMON.CONTACTS'
6502       double precision gx(3),gx1(3)
6503       logical lprn
6504       lprn=.false.
6505       eij=facont_hb(jj,i)
6506       ekl=facont_hb(kk,k)
6507       ees0pij=ees0p(jj,i)
6508       ees0pkl=ees0p(kk,k)
6509       ees0mij=ees0m(jj,i)
6510       ees0mkl=ees0m(kk,k)
6511       ekont=eij*ekl
6512       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6513 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6514 C Following 4 lines for diagnostics.
6515 cd    ees0pkl=0.0D0
6516 cd    ees0pij=1.0D0
6517 cd    ees0mkl=0.0D0
6518 cd    ees0mij=1.0D0
6519 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6520 c     & 'Contacts ',i,j,
6521 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6522 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6523 c     & 'gradcorr_long'
6524 C Calculate the multi-body contribution to energy.
6525       ecorr=ecorr+ekont*ees
6526 C Calculate multi-body contributions to the gradient.
6527       coeffpees0pij=coeffp*ees0pij
6528       coeffmees0mij=coeffm*ees0mij
6529       coeffpees0pkl=coeffp*ees0pkl
6530       coeffmees0mkl=coeffm*ees0mkl
6531       do ll=1,3
6532 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6533         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6534      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6535      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6536         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6537      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6538      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6539 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6540         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6541      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6542      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6543         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6544      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6545      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6546         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6547      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6548      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6549         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6550         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6551         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6552      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6553      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6554         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6555         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6556 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6557       enddo
6558 c      write (iout,*)
6559 cgrad      do m=i+1,j-1
6560 cgrad        do ll=1,3
6561 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6562 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6563 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6564 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6565 cgrad        enddo
6566 cgrad      enddo
6567 cgrad      do m=k+1,l-1
6568 cgrad        do ll=1,3
6569 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6570 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6571 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6572 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6573 cgrad        enddo
6574 cgrad      enddo
6575 c      write (iout,*) "ehbcorr",ekont*ees
6576       ehbcorr=ekont*ees
6577       return
6578       end
6579 #ifdef MOMENT
6580 C---------------------------------------------------------------------------
6581       subroutine dipole(i,j,jj)
6582       implicit real*8 (a-h,o-z)
6583       include 'DIMENSIONS'
6584       include 'COMMON.IOUNITS'
6585       include 'COMMON.CHAIN'
6586       include 'COMMON.FFIELD'
6587       include 'COMMON.DERIV'
6588       include 'COMMON.INTERACT'
6589       include 'COMMON.CONTACTS'
6590       include 'COMMON.TORSION'
6591       include 'COMMON.VAR'
6592       include 'COMMON.GEO'
6593       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6594      &  auxmat(2,2)
6595       iti1 = itortyp(itype(i+1))
6596       if (j.lt.nres-1) then
6597         itj1 = itortyp(itype(j+1))
6598       else
6599         itj1=ntortyp+1
6600       endif
6601       do iii=1,2
6602         dipi(iii,1)=Ub2(iii,i)
6603         dipderi(iii)=Ub2der(iii,i)
6604         dipi(iii,2)=b1(iii,iti1)
6605         dipj(iii,1)=Ub2(iii,j)
6606         dipderj(iii)=Ub2der(iii,j)
6607         dipj(iii,2)=b1(iii,itj1)
6608       enddo
6609       kkk=0
6610       do iii=1,2
6611         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6612         do jjj=1,2
6613           kkk=kkk+1
6614           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6615         enddo
6616       enddo
6617       do kkk=1,5
6618         do lll=1,3
6619           mmm=0
6620           do iii=1,2
6621             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6622      &        auxvec(1))
6623             do jjj=1,2
6624               mmm=mmm+1
6625               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6626             enddo
6627           enddo
6628         enddo
6629       enddo
6630       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6631       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6632       do iii=1,2
6633         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6634       enddo
6635       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6636       do iii=1,2
6637         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6638       enddo
6639       return
6640       end
6641 #endif
6642 C---------------------------------------------------------------------------
6643       subroutine calc_eello(i,j,k,l,jj,kk)
6644 C
6645 C This subroutine computes matrices and vectors needed to calculate
6646 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6647 C
6648       implicit real*8 (a-h,o-z)
6649       include 'DIMENSIONS'
6650       include 'COMMON.IOUNITS'
6651       include 'COMMON.CHAIN'
6652       include 'COMMON.DERIV'
6653       include 'COMMON.INTERACT'
6654       include 'COMMON.CONTACTS'
6655       include 'COMMON.TORSION'
6656       include 'COMMON.VAR'
6657       include 'COMMON.GEO'
6658       include 'COMMON.FFIELD'
6659       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6660      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6661       logical lprn
6662       common /kutas/ lprn
6663 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6664 cd     & ' jj=',jj,' kk=',kk
6665 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6666 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6667 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6668       do iii=1,2
6669         do jjj=1,2
6670           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6671           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6672         enddo
6673       enddo
6674       call transpose2(aa1(1,1),aa1t(1,1))
6675       call transpose2(aa2(1,1),aa2t(1,1))
6676       do kkk=1,5
6677         do lll=1,3
6678           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6679      &      aa1tder(1,1,lll,kkk))
6680           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6681      &      aa2tder(1,1,lll,kkk))
6682         enddo
6683       enddo
6684       if (l.eq.j+1) then
6685 C parallel orientation of the two CA-CA-CA frames.
6686         if (i.gt.1) then
6687           iti=itortyp(itype(i))
6688         else
6689           iti=ntortyp+1
6690         endif
6691         itk1=itortyp(itype(k+1))
6692         itj=itortyp(itype(j))
6693         if (l.lt.nres-1) then
6694           itl1=itortyp(itype(l+1))
6695         else
6696           itl1=ntortyp+1
6697         endif
6698 C A1 kernel(j+1) A2T
6699 cd        do iii=1,2
6700 cd          write (iout,'(3f10.5,5x,3f10.5)')
6701 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6702 cd        enddo
6703         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6704      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6705      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6706 C Following matrices are needed only for 6-th order cumulants
6707         IF (wcorr6.gt.0.0d0) THEN
6708         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6709      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6710      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6711         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6712      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6713      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6714      &   ADtEAderx(1,1,1,1,1,1))
6715         lprn=.false.
6716         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6717      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6718      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6719      &   ADtEA1derx(1,1,1,1,1,1))
6720         ENDIF
6721 C End 6-th order cumulants
6722 cd        lprn=.false.
6723 cd        if (lprn) then
6724 cd        write (2,*) 'In calc_eello6'
6725 cd        do iii=1,2
6726 cd          write (2,*) 'iii=',iii
6727 cd          do kkk=1,5
6728 cd            write (2,*) 'kkk=',kkk
6729 cd            do jjj=1,2
6730 cd              write (2,'(3(2f10.5),5x)')
6731 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6732 cd            enddo
6733 cd          enddo
6734 cd        enddo
6735 cd        endif
6736         call transpose2(EUgder(1,1,k),auxmat(1,1))
6737         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6738         call transpose2(EUg(1,1,k),auxmat(1,1))
6739         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6740         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6741         do iii=1,2
6742           do kkk=1,5
6743             do lll=1,3
6744               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6745      &          EAEAderx(1,1,lll,kkk,iii,1))
6746             enddo
6747           enddo
6748         enddo
6749 C A1T kernel(i+1) A2
6750         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6751      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6752      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6753 C Following matrices are needed only for 6-th order cumulants
6754         IF (wcorr6.gt.0.0d0) THEN
6755         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6756      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6757      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6758         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6759      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6760      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6761      &   ADtEAderx(1,1,1,1,1,2))
6762         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6763      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6764      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6765      &   ADtEA1derx(1,1,1,1,1,2))
6766         ENDIF
6767 C End 6-th order cumulants
6768         call transpose2(EUgder(1,1,l),auxmat(1,1))
6769         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6770         call transpose2(EUg(1,1,l),auxmat(1,1))
6771         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6772         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6773         do iii=1,2
6774           do kkk=1,5
6775             do lll=1,3
6776               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6777      &          EAEAderx(1,1,lll,kkk,iii,2))
6778             enddo
6779           enddo
6780         enddo
6781 C AEAb1 and AEAb2
6782 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6783 C They are needed only when the fifth- or the sixth-order cumulants are
6784 C indluded.
6785         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6786         call transpose2(AEA(1,1,1),auxmat(1,1))
6787         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6788         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6789         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6790         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6791         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6792         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6793         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6794         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6795         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6796         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6797         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6798         call transpose2(AEA(1,1,2),auxmat(1,1))
6799         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6800         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6801         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6802         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6803         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6804         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6805         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6806         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6807         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6808         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6809         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6810 C Calculate the Cartesian derivatives of the vectors.
6811         do iii=1,2
6812           do kkk=1,5
6813             do lll=1,3
6814               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6815               call matvec2(auxmat(1,1),b1(1,iti),
6816      &          AEAb1derx(1,lll,kkk,iii,1,1))
6817               call matvec2(auxmat(1,1),Ub2(1,i),
6818      &          AEAb2derx(1,lll,kkk,iii,1,1))
6819               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6820      &          AEAb1derx(1,lll,kkk,iii,2,1))
6821               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6822      &          AEAb2derx(1,lll,kkk,iii,2,1))
6823               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6824               call matvec2(auxmat(1,1),b1(1,itj),
6825      &          AEAb1derx(1,lll,kkk,iii,1,2))
6826               call matvec2(auxmat(1,1),Ub2(1,j),
6827      &          AEAb2derx(1,lll,kkk,iii,1,2))
6828               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6829      &          AEAb1derx(1,lll,kkk,iii,2,2))
6830               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6831      &          AEAb2derx(1,lll,kkk,iii,2,2))
6832             enddo
6833           enddo
6834         enddo
6835         ENDIF
6836 C End vectors
6837       else
6838 C Antiparallel orientation of the two CA-CA-CA frames.
6839         if (i.gt.1) then
6840           iti=itortyp(itype(i))
6841         else
6842           iti=ntortyp+1
6843         endif
6844         itk1=itortyp(itype(k+1))
6845         itl=itortyp(itype(l))
6846         itj=itortyp(itype(j))
6847         if (j.lt.nres-1) then
6848           itj1=itortyp(itype(j+1))
6849         else
6850           itj1=ntortyp+1
6851         endif
6852 C A2 kernel(j-1)T A1T
6853         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6854      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6855      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6856 C Following matrices are needed only for 6-th order cumulants
6857         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6858      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6859         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6860      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6861      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6862         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6863      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6864      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6865      &   ADtEAderx(1,1,1,1,1,1))
6866         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6867      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6868      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6869      &   ADtEA1derx(1,1,1,1,1,1))
6870         ENDIF
6871 C End 6-th order cumulants
6872         call transpose2(EUgder(1,1,k),auxmat(1,1))
6873         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6874         call transpose2(EUg(1,1,k),auxmat(1,1))
6875         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6876         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6877         do iii=1,2
6878           do kkk=1,5
6879             do lll=1,3
6880               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6881      &          EAEAderx(1,1,lll,kkk,iii,1))
6882             enddo
6883           enddo
6884         enddo
6885 C A2T kernel(i+1)T A1
6886         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6887      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6888      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6889 C Following matrices are needed only for 6-th order cumulants
6890         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6891      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6892         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6893      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6894      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6895         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6896      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6897      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6898      &   ADtEAderx(1,1,1,1,1,2))
6899         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6900      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6901      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6902      &   ADtEA1derx(1,1,1,1,1,2))
6903         ENDIF
6904 C End 6-th order cumulants
6905         call transpose2(EUgder(1,1,j),auxmat(1,1))
6906         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6907         call transpose2(EUg(1,1,j),auxmat(1,1))
6908         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6909         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6910         do iii=1,2
6911           do kkk=1,5
6912             do lll=1,3
6913               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6914      &          EAEAderx(1,1,lll,kkk,iii,2))
6915             enddo
6916           enddo
6917         enddo
6918 C AEAb1 and AEAb2
6919 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6920 C They are needed only when the fifth- or the sixth-order cumulants are
6921 C indluded.
6922         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6923      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6924         call transpose2(AEA(1,1,1),auxmat(1,1))
6925         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6926         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6927         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6928         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6929         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6930         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6931         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6932         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6933         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6934         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6935         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6936         call transpose2(AEA(1,1,2),auxmat(1,1))
6937         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6938         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6939         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6940         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6941         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6942         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6943         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6944         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6945         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6946         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6947         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6948 C Calculate the Cartesian derivatives of the vectors.
6949         do iii=1,2
6950           do kkk=1,5
6951             do lll=1,3
6952               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6953               call matvec2(auxmat(1,1),b1(1,iti),
6954      &          AEAb1derx(1,lll,kkk,iii,1,1))
6955               call matvec2(auxmat(1,1),Ub2(1,i),
6956      &          AEAb2derx(1,lll,kkk,iii,1,1))
6957               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6958      &          AEAb1derx(1,lll,kkk,iii,2,1))
6959               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6960      &          AEAb2derx(1,lll,kkk,iii,2,1))
6961               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6962               call matvec2(auxmat(1,1),b1(1,itl),
6963      &          AEAb1derx(1,lll,kkk,iii,1,2))
6964               call matvec2(auxmat(1,1),Ub2(1,l),
6965      &          AEAb2derx(1,lll,kkk,iii,1,2))
6966               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6967      &          AEAb1derx(1,lll,kkk,iii,2,2))
6968               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6969      &          AEAb2derx(1,lll,kkk,iii,2,2))
6970             enddo
6971           enddo
6972         enddo
6973         ENDIF
6974 C End vectors
6975       endif
6976       return
6977       end
6978 C---------------------------------------------------------------------------
6979       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6980      &  KK,KKderg,AKA,AKAderg,AKAderx)
6981       implicit none
6982       integer nderg
6983       logical transp
6984       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6985      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6986      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6987       integer iii,kkk,lll
6988       integer jjj,mmm
6989       logical lprn
6990       common /kutas/ lprn
6991       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6992       do iii=1,nderg
6993         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6994      &    AKAderg(1,1,iii))
6995       enddo
6996 cd      if (lprn) write (2,*) 'In kernel'
6997       do kkk=1,5
6998 cd        if (lprn) write (2,*) 'kkk=',kkk
6999         do lll=1,3
7000           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7001      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7002 cd          if (lprn) then
7003 cd            write (2,*) 'lll=',lll
7004 cd            write (2,*) 'iii=1'
7005 cd            do jjj=1,2
7006 cd              write (2,'(3(2f10.5),5x)')
7007 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7008 cd            enddo
7009 cd          endif
7010           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7011      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7012 cd          if (lprn) then
7013 cd            write (2,*) 'lll=',lll
7014 cd            write (2,*) 'iii=2'
7015 cd            do jjj=1,2
7016 cd              write (2,'(3(2f10.5),5x)')
7017 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7018 cd            enddo
7019 cd          endif
7020         enddo
7021       enddo
7022       return
7023       end
7024 C---------------------------------------------------------------------------
7025       double precision function eello4(i,j,k,l,jj,kk)
7026       implicit real*8 (a-h,o-z)
7027       include 'DIMENSIONS'
7028       include 'COMMON.IOUNITS'
7029       include 'COMMON.CHAIN'
7030       include 'COMMON.DERIV'
7031       include 'COMMON.INTERACT'
7032       include 'COMMON.CONTACTS'
7033       include 'COMMON.TORSION'
7034       include 'COMMON.VAR'
7035       include 'COMMON.GEO'
7036       double precision pizda(2,2),ggg1(3),ggg2(3)
7037 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7038 cd        eello4=0.0d0
7039 cd        return
7040 cd      endif
7041 cd      print *,'eello4:',i,j,k,l,jj,kk
7042 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7043 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7044 cold      eij=facont_hb(jj,i)
7045 cold      ekl=facont_hb(kk,k)
7046 cold      ekont=eij*ekl
7047       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7048 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7049       gcorr_loc(k-1)=gcorr_loc(k-1)
7050      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7051       if (l.eq.j+1) then
7052         gcorr_loc(l-1)=gcorr_loc(l-1)
7053      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7054       else
7055         gcorr_loc(j-1)=gcorr_loc(j-1)
7056      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7057       endif
7058       do iii=1,2
7059         do kkk=1,5
7060           do lll=1,3
7061             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7062      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7063 cd            derx(lll,kkk,iii)=0.0d0
7064           enddo
7065         enddo
7066       enddo
7067 cd      gcorr_loc(l-1)=0.0d0
7068 cd      gcorr_loc(j-1)=0.0d0
7069 cd      gcorr_loc(k-1)=0.0d0
7070 cd      eel4=1.0d0
7071 cd      write (iout,*)'Contacts have occurred for peptide groups',
7072 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7073 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7074       if (j.lt.nres-1) then
7075         j1=j+1
7076         j2=j-1
7077       else
7078         j1=j-1
7079         j2=j-2
7080       endif
7081       if (l.lt.nres-1) then
7082         l1=l+1
7083         l2=l-1
7084       else
7085         l1=l-1
7086         l2=l-2
7087       endif
7088       do ll=1,3
7089 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7090 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7091         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7092         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7093 cgrad        ghalf=0.5d0*ggg1(ll)
7094         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7095         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7096         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7097         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7098         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7099         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7100 cgrad        ghalf=0.5d0*ggg2(ll)
7101         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7102         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7103         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7104         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7105         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7106         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7107       enddo
7108 cgrad      do m=i+1,j-1
7109 cgrad        do ll=1,3
7110 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7111 cgrad        enddo
7112 cgrad      enddo
7113 cgrad      do m=k+1,l-1
7114 cgrad        do ll=1,3
7115 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7116 cgrad        enddo
7117 cgrad      enddo
7118 cgrad      do m=i+2,j2
7119 cgrad        do ll=1,3
7120 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7121 cgrad        enddo
7122 cgrad      enddo
7123 cgrad      do m=k+2,l2
7124 cgrad        do ll=1,3
7125 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7126 cgrad        enddo
7127 cgrad      enddo
7128 cd      do iii=1,nres-3
7129 cd        write (2,*) iii,gcorr_loc(iii)
7130 cd      enddo
7131       eello4=ekont*eel4
7132 cd      write (2,*) 'ekont',ekont
7133 cd      write (iout,*) 'eello4',ekont*eel4
7134       return
7135       end
7136 C---------------------------------------------------------------------------
7137       double precision function eello5(i,j,k,l,jj,kk)
7138       implicit real*8 (a-h,o-z)
7139       include 'DIMENSIONS'
7140       include 'COMMON.IOUNITS'
7141       include 'COMMON.CHAIN'
7142       include 'COMMON.DERIV'
7143       include 'COMMON.INTERACT'
7144       include 'COMMON.CONTACTS'
7145       include 'COMMON.TORSION'
7146       include 'COMMON.VAR'
7147       include 'COMMON.GEO'
7148       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7149       double precision ggg1(3),ggg2(3)
7150 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7151 C                                                                              C
7152 C                            Parallel chains                                   C
7153 C                                                                              C
7154 C          o             o                   o             o                   C
7155 C         /l\           / \             \   / \           / \   /              C
7156 C        /   \         /   \             \ /   \         /   \ /               C
7157 C       j| o |l1       | o |              o| o |         | o |o                C
7158 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7159 C      \i/   \         /   \ /             /   \         /   \                 C
7160 C       o    k1             o                                                  C
7161 C         (I)          (II)                (III)          (IV)                 C
7162 C                                                                              C
7163 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7164 C                                                                              C
7165 C                            Antiparallel chains                               C
7166 C                                                                              C
7167 C          o             o                   o             o                   C
7168 C         /j\           / \             \   / \           / \   /              C
7169 C        /   \         /   \             \ /   \         /   \ /               C
7170 C      j1| o |l        | o |              o| o |         | o |o                C
7171 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7172 C      \i/   \         /   \ /             /   \         /   \                 C
7173 C       o     k1            o                                                  C
7174 C         (I)          (II)                (III)          (IV)                 C
7175 C                                                                              C
7176 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7177 C                                                                              C
7178 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7179 C                                                                              C
7180 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7181 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7182 cd        eello5=0.0d0
7183 cd        return
7184 cd      endif
7185 cd      write (iout,*)
7186 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7187 cd     &   ' and',k,l
7188       itk=itortyp(itype(k))
7189       itl=itortyp(itype(l))
7190       itj=itortyp(itype(j))
7191       eello5_1=0.0d0
7192       eello5_2=0.0d0
7193       eello5_3=0.0d0
7194       eello5_4=0.0d0
7195 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7196 cd     &   eel5_3_num,eel5_4_num)
7197       do iii=1,2
7198         do kkk=1,5
7199           do lll=1,3
7200             derx(lll,kkk,iii)=0.0d0
7201           enddo
7202         enddo
7203       enddo
7204 cd      eij=facont_hb(jj,i)
7205 cd      ekl=facont_hb(kk,k)
7206 cd      ekont=eij*ekl
7207 cd      write (iout,*)'Contacts have occurred for peptide groups',
7208 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7209 cd      goto 1111
7210 C Contribution from the graph I.
7211 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7212 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7213       call transpose2(EUg(1,1,k),auxmat(1,1))
7214       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7215       vv(1)=pizda(1,1)-pizda(2,2)
7216       vv(2)=pizda(1,2)+pizda(2,1)
7217       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7218      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7219 C Explicit gradient in virtual-dihedral angles.
7220       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7221      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7222      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7223       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7224       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7225       vv(1)=pizda(1,1)-pizda(2,2)
7226       vv(2)=pizda(1,2)+pizda(2,1)
7227       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7228      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7229      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7230       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7231       vv(1)=pizda(1,1)-pizda(2,2)
7232       vv(2)=pizda(1,2)+pizda(2,1)
7233       if (l.eq.j+1) then
7234         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7235      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7236      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7237       else
7238         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7239      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7240      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7241       endif
7242 C Cartesian gradient
7243       do iii=1,2
7244         do kkk=1,5
7245           do lll=1,3
7246             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7247      &        pizda(1,1))
7248             vv(1)=pizda(1,1)-pizda(2,2)
7249             vv(2)=pizda(1,2)+pizda(2,1)
7250             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7251      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7252      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7253           enddo
7254         enddo
7255       enddo
7256 c      goto 1112
7257 c1111  continue
7258 C Contribution from graph II
7259       call transpose2(EE(1,1,itk),auxmat(1,1))
7260       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7261       vv(1)=pizda(1,1)+pizda(2,2)
7262       vv(2)=pizda(2,1)-pizda(1,2)
7263       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7264      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7265 C Explicit gradient in virtual-dihedral angles.
7266       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7267      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7268       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7269       vv(1)=pizda(1,1)+pizda(2,2)
7270       vv(2)=pizda(2,1)-pizda(1,2)
7271       if (l.eq.j+1) then
7272         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7273      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7274      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7275       else
7276         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7277      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7278      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7279       endif
7280 C Cartesian gradient
7281       do iii=1,2
7282         do kkk=1,5
7283           do lll=1,3
7284             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7285      &        pizda(1,1))
7286             vv(1)=pizda(1,1)+pizda(2,2)
7287             vv(2)=pizda(2,1)-pizda(1,2)
7288             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7289      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7290      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7291           enddo
7292         enddo
7293       enddo
7294 cd      goto 1112
7295 cd1111  continue
7296       if (l.eq.j+1) then
7297 cd        goto 1110
7298 C Parallel orientation
7299 C Contribution from graph III
7300         call transpose2(EUg(1,1,l),auxmat(1,1))
7301         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7302         vv(1)=pizda(1,1)-pizda(2,2)
7303         vv(2)=pizda(1,2)+pizda(2,1)
7304         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7305      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7306 C Explicit gradient in virtual-dihedral angles.
7307         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7308      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7309      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7310         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7311         vv(1)=pizda(1,1)-pizda(2,2)
7312         vv(2)=pizda(1,2)+pizda(2,1)
7313         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7314      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7315      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7316         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7317         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7318         vv(1)=pizda(1,1)-pizda(2,2)
7319         vv(2)=pizda(1,2)+pizda(2,1)
7320         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7321      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7322      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7323 C Cartesian gradient
7324         do iii=1,2
7325           do kkk=1,5
7326             do lll=1,3
7327               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7328      &          pizda(1,1))
7329               vv(1)=pizda(1,1)-pizda(2,2)
7330               vv(2)=pizda(1,2)+pizda(2,1)
7331               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7332      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7333      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7334             enddo
7335           enddo
7336         enddo
7337 cd        goto 1112
7338 C Contribution from graph IV
7339 cd1110    continue
7340         call transpose2(EE(1,1,itl),auxmat(1,1))
7341         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7342         vv(1)=pizda(1,1)+pizda(2,2)
7343         vv(2)=pizda(2,1)-pizda(1,2)
7344         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7345      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7346 C Explicit gradient in virtual-dihedral angles.
7347         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7348      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7349         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7350         vv(1)=pizda(1,1)+pizda(2,2)
7351         vv(2)=pizda(2,1)-pizda(1,2)
7352         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7353      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7354      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7355 C Cartesian gradient
7356         do iii=1,2
7357           do kkk=1,5
7358             do lll=1,3
7359               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7360      &          pizda(1,1))
7361               vv(1)=pizda(1,1)+pizda(2,2)
7362               vv(2)=pizda(2,1)-pizda(1,2)
7363               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7364      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7365      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7366             enddo
7367           enddo
7368         enddo
7369       else
7370 C Antiparallel orientation
7371 C Contribution from graph III
7372 c        goto 1110
7373         call transpose2(EUg(1,1,j),auxmat(1,1))
7374         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7375         vv(1)=pizda(1,1)-pizda(2,2)
7376         vv(2)=pizda(1,2)+pizda(2,1)
7377         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7378      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7379 C Explicit gradient in virtual-dihedral angles.
7380         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7381      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7382      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7383         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7384         vv(1)=pizda(1,1)-pizda(2,2)
7385         vv(2)=pizda(1,2)+pizda(2,1)
7386         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7387      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7388      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7389         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7390         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7391         vv(1)=pizda(1,1)-pizda(2,2)
7392         vv(2)=pizda(1,2)+pizda(2,1)
7393         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7394      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7395      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7396 C Cartesian gradient
7397         do iii=1,2
7398           do kkk=1,5
7399             do lll=1,3
7400               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7401      &          pizda(1,1))
7402               vv(1)=pizda(1,1)-pizda(2,2)
7403               vv(2)=pizda(1,2)+pizda(2,1)
7404               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7405      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7406      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7407             enddo
7408           enddo
7409         enddo
7410 cd        goto 1112
7411 C Contribution from graph IV
7412 1110    continue
7413         call transpose2(EE(1,1,itj),auxmat(1,1))
7414         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7415         vv(1)=pizda(1,1)+pizda(2,2)
7416         vv(2)=pizda(2,1)-pizda(1,2)
7417         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7418      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7419 C Explicit gradient in virtual-dihedral angles.
7420         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7421      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7422         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7423         vv(1)=pizda(1,1)+pizda(2,2)
7424         vv(2)=pizda(2,1)-pizda(1,2)
7425         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7426      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7427      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7428 C Cartesian gradient
7429         do iii=1,2
7430           do kkk=1,5
7431             do lll=1,3
7432               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7433      &          pizda(1,1))
7434               vv(1)=pizda(1,1)+pizda(2,2)
7435               vv(2)=pizda(2,1)-pizda(1,2)
7436               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7437      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7438      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7439             enddo
7440           enddo
7441         enddo
7442       endif
7443 1112  continue
7444       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7445 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7446 cd        write (2,*) 'ijkl',i,j,k,l
7447 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7448 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7449 cd      endif
7450 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7451 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7452 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7453 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7454       if (j.lt.nres-1) then
7455         j1=j+1
7456         j2=j-1
7457       else
7458         j1=j-1
7459         j2=j-2
7460       endif
7461       if (l.lt.nres-1) then
7462         l1=l+1
7463         l2=l-1
7464       else
7465         l1=l-1
7466         l2=l-2
7467       endif
7468 cd      eij=1.0d0
7469 cd      ekl=1.0d0
7470 cd      ekont=1.0d0
7471 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7472 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7473 C        summed up outside the subrouine as for the other subroutines
7474 C        handling long-range interactions. The old code is commented out
7475 C        with "cgrad" to keep track of changes.
7476       do ll=1,3
7477 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7478 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7479         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7480         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7481 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7482 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7483 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7484 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7485 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7486 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7487 c     &   gradcorr5ij,
7488 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7489 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7490 cgrad        ghalf=0.5d0*ggg1(ll)
7491 cd        ghalf=0.0d0
7492         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7493         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7494         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7495         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7496         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7497         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7498 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7499 cgrad        ghalf=0.5d0*ggg2(ll)
7500 cd        ghalf=0.0d0
7501         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7502         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7503         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7504         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7505         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7506         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7507       enddo
7508 cd      goto 1112
7509 cgrad      do m=i+1,j-1
7510 cgrad        do ll=1,3
7511 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7512 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7513 cgrad        enddo
7514 cgrad      enddo
7515 cgrad      do m=k+1,l-1
7516 cgrad        do ll=1,3
7517 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7518 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7519 cgrad        enddo
7520 cgrad      enddo
7521 c1112  continue
7522 cgrad      do m=i+2,j2
7523 cgrad        do ll=1,3
7524 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7525 cgrad        enddo
7526 cgrad      enddo
7527 cgrad      do m=k+2,l2
7528 cgrad        do ll=1,3
7529 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7530 cgrad        enddo
7531 cgrad      enddo
7532 cd      do iii=1,nres-3
7533 cd        write (2,*) iii,g_corr5_loc(iii)
7534 cd      enddo
7535       eello5=ekont*eel5
7536 cd      write (2,*) 'ekont',ekont
7537 cd      write (iout,*) 'eello5',ekont*eel5
7538       return
7539       end
7540 c--------------------------------------------------------------------------
7541       double precision function eello6(i,j,k,l,jj,kk)
7542       implicit real*8 (a-h,o-z)
7543       include 'DIMENSIONS'
7544       include 'COMMON.IOUNITS'
7545       include 'COMMON.CHAIN'
7546       include 'COMMON.DERIV'
7547       include 'COMMON.INTERACT'
7548       include 'COMMON.CONTACTS'
7549       include 'COMMON.TORSION'
7550       include 'COMMON.VAR'
7551       include 'COMMON.GEO'
7552       include 'COMMON.FFIELD'
7553       double precision ggg1(3),ggg2(3)
7554 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7555 cd        eello6=0.0d0
7556 cd        return
7557 cd      endif
7558 cd      write (iout,*)
7559 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7560 cd     &   ' and',k,l
7561       eello6_1=0.0d0
7562       eello6_2=0.0d0
7563       eello6_3=0.0d0
7564       eello6_4=0.0d0
7565       eello6_5=0.0d0
7566       eello6_6=0.0d0
7567 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7568 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7569       do iii=1,2
7570         do kkk=1,5
7571           do lll=1,3
7572             derx(lll,kkk,iii)=0.0d0
7573           enddo
7574         enddo
7575       enddo
7576 cd      eij=facont_hb(jj,i)
7577 cd      ekl=facont_hb(kk,k)
7578 cd      ekont=eij*ekl
7579 cd      eij=1.0d0
7580 cd      ekl=1.0d0
7581 cd      ekont=1.0d0
7582       if (l.eq.j+1) then
7583         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7584         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7585         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7586         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7587         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7588         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7589       else
7590         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7591         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7592         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7593         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7594         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7595           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7596         else
7597           eello6_5=0.0d0
7598         endif
7599         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7600       endif
7601 C If turn contributions are considered, they will be handled separately.
7602       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7603 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7604 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7605 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7606 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7607 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7608 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7609 cd      goto 1112
7610       if (j.lt.nres-1) then
7611         j1=j+1
7612         j2=j-1
7613       else
7614         j1=j-1
7615         j2=j-2
7616       endif
7617       if (l.lt.nres-1) then
7618         l1=l+1
7619         l2=l-1
7620       else
7621         l1=l-1
7622         l2=l-2
7623       endif
7624       do ll=1,3
7625 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7626 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7627 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7628 cgrad        ghalf=0.5d0*ggg1(ll)
7629 cd        ghalf=0.0d0
7630         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7631         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7632         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7633         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7634         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7635         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7636         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7637         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7638 cgrad        ghalf=0.5d0*ggg2(ll)
7639 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7640 cd        ghalf=0.0d0
7641         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7642         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7643         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7644         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7645         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7646         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7647       enddo
7648 cd      goto 1112
7649 cgrad      do m=i+1,j-1
7650 cgrad        do ll=1,3
7651 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7652 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7653 cgrad        enddo
7654 cgrad      enddo
7655 cgrad      do m=k+1,l-1
7656 cgrad        do ll=1,3
7657 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7658 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7659 cgrad        enddo
7660 cgrad      enddo
7661 cgrad1112  continue
7662 cgrad      do m=i+2,j2
7663 cgrad        do ll=1,3
7664 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7665 cgrad        enddo
7666 cgrad      enddo
7667 cgrad      do m=k+2,l2
7668 cgrad        do ll=1,3
7669 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7670 cgrad        enddo
7671 cgrad      enddo
7672 cd      do iii=1,nres-3
7673 cd        write (2,*) iii,g_corr6_loc(iii)
7674 cd      enddo
7675       eello6=ekont*eel6
7676 cd      write (2,*) 'ekont',ekont
7677 cd      write (iout,*) 'eello6',ekont*eel6
7678       return
7679       end
7680 c--------------------------------------------------------------------------
7681       double precision function eello6_graph1(i,j,k,l,imat,swap)
7682       implicit real*8 (a-h,o-z)
7683       include 'DIMENSIONS'
7684       include 'COMMON.IOUNITS'
7685       include 'COMMON.CHAIN'
7686       include 'COMMON.DERIV'
7687       include 'COMMON.INTERACT'
7688       include 'COMMON.CONTACTS'
7689       include 'COMMON.TORSION'
7690       include 'COMMON.VAR'
7691       include 'COMMON.GEO'
7692       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7693       logical swap
7694       logical lprn
7695       common /kutas/ lprn
7696 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7697 C
7698 C      Parallel       Antiparallel
7699 C
7700 C          o             o
7701 C         /l\           /j\
7702 C        /   \         /   \
7703 C       /| o |         | o |\
7704 C     \ j|/k\|  /   \  |/k\|l /
7705 C      \ /   \ /     \ /   \ /
7706 C       o     o       o     o
7707 C       i             i
7708 C
7709 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7710       itk=itortyp(itype(k))
7711       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7712       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7713       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7714       call transpose2(EUgC(1,1,k),auxmat(1,1))
7715       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7716       vv1(1)=pizda1(1,1)-pizda1(2,2)
7717       vv1(2)=pizda1(1,2)+pizda1(2,1)
7718       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7719       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7720       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7721       s5=scalar2(vv(1),Dtobr2(1,i))
7722 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7723       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7724       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7725      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7726      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7727      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7728      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7729      & +scalar2(vv(1),Dtobr2der(1,i)))
7730       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7731       vv1(1)=pizda1(1,1)-pizda1(2,2)
7732       vv1(2)=pizda1(1,2)+pizda1(2,1)
7733       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7734       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7735       if (l.eq.j+1) then
7736         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7737      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7738      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7739      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7740      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7741       else
7742         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7743      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7744      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7745      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7746      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7747       endif
7748       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7749       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7750       vv1(1)=pizda1(1,1)-pizda1(2,2)
7751       vv1(2)=pizda1(1,2)+pizda1(2,1)
7752       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7753      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7754      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7755      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7756       do iii=1,2
7757         if (swap) then
7758           ind=3-iii
7759         else
7760           ind=iii
7761         endif
7762         do kkk=1,5
7763           do lll=1,3
7764             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7765             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7766             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7767             call transpose2(EUgC(1,1,k),auxmat(1,1))
7768             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7769      &        pizda1(1,1))
7770             vv1(1)=pizda1(1,1)-pizda1(2,2)
7771             vv1(2)=pizda1(1,2)+pizda1(2,1)
7772             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7773             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7774      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7775             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7776      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7777             s5=scalar2(vv(1),Dtobr2(1,i))
7778             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7779           enddo
7780         enddo
7781       enddo
7782       return
7783       end
7784 c----------------------------------------------------------------------------
7785       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7786       implicit real*8 (a-h,o-z)
7787       include 'DIMENSIONS'
7788       include 'COMMON.IOUNITS'
7789       include 'COMMON.CHAIN'
7790       include 'COMMON.DERIV'
7791       include 'COMMON.INTERACT'
7792       include 'COMMON.CONTACTS'
7793       include 'COMMON.TORSION'
7794       include 'COMMON.VAR'
7795       include 'COMMON.GEO'
7796       logical swap
7797       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7798      & auxvec1(2),auxvec2(1),auxmat1(2,2)
7799       logical lprn
7800       common /kutas/ lprn
7801 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7802 C
7803 C      Parallel       Antiparallel
7804 C
7805 C          o             o
7806 C     \   /l\           /j\   /
7807 C      \ /   \         /   \ /
7808 C       o| o |         | o |o
7809 C     \ j|/k\|      \  |/k\|l
7810 C      \ /   \       \ /   \
7811 C       o             o
7812 C       i             i
7813 C
7814 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7815 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7816 C AL 7/4/01 s1 would occur in the sixth-order moment,
7817 C           but not in a cluster cumulant
7818 #ifdef MOMENT
7819       s1=dip(1,jj,i)*dip(1,kk,k)
7820 #endif
7821       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7822       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7823       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7824       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7825       call transpose2(EUg(1,1,k),auxmat(1,1))
7826       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7827       vv(1)=pizda(1,1)-pizda(2,2)
7828       vv(2)=pizda(1,2)+pizda(2,1)
7829       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7830 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7831 #ifdef MOMENT
7832       eello6_graph2=-(s1+s2+s3+s4)
7833 #else
7834       eello6_graph2=-(s2+s3+s4)
7835 #endif
7836 c      eello6_graph2=-s3
7837 C Derivatives in gamma(i-1)
7838       if (i.gt.1) then
7839 #ifdef MOMENT
7840         s1=dipderg(1,jj,i)*dip(1,kk,k)
7841 #endif
7842         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7843         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7844         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7845         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7846 #ifdef MOMENT
7847         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7848 #else
7849         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7850 #endif
7851 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7852       endif
7853 C Derivatives in gamma(k-1)
7854 #ifdef MOMENT
7855       s1=dip(1,jj,i)*dipderg(1,kk,k)
7856 #endif
7857       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7858       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7859       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7860       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7861       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7862       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7863       vv(1)=pizda(1,1)-pizda(2,2)
7864       vv(2)=pizda(1,2)+pizda(2,1)
7865       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7866 #ifdef MOMENT
7867       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7868 #else
7869       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7870 #endif
7871 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7872 C Derivatives in gamma(j-1) or gamma(l-1)
7873       if (j.gt.1) then
7874 #ifdef MOMENT
7875         s1=dipderg(3,jj,i)*dip(1,kk,k)
7876 #endif
7877         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7878         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7879         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7880         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7881         vv(1)=pizda(1,1)-pizda(2,2)
7882         vv(2)=pizda(1,2)+pizda(2,1)
7883         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7884 #ifdef MOMENT
7885         if (swap) then
7886           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7887         else
7888           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7889         endif
7890 #endif
7891         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7892 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7893       endif
7894 C Derivatives in gamma(l-1) or gamma(j-1)
7895       if (l.gt.1) then
7896 #ifdef MOMENT
7897         s1=dip(1,jj,i)*dipderg(3,kk,k)
7898 #endif
7899         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7900         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7901         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7902         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7903         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7904         vv(1)=pizda(1,1)-pizda(2,2)
7905         vv(2)=pizda(1,2)+pizda(2,1)
7906         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7907 #ifdef MOMENT
7908         if (swap) then
7909           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7910         else
7911           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7912         endif
7913 #endif
7914         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7915 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7916       endif
7917 C Cartesian derivatives.
7918       if (lprn) then
7919         write (2,*) 'In eello6_graph2'
7920         do iii=1,2
7921           write (2,*) 'iii=',iii
7922           do kkk=1,5
7923             write (2,*) 'kkk=',kkk
7924             do jjj=1,2
7925               write (2,'(3(2f10.5),5x)')
7926      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7927             enddo
7928           enddo
7929         enddo
7930       endif
7931       do iii=1,2
7932         do kkk=1,5
7933           do lll=1,3
7934 #ifdef MOMENT
7935             if (iii.eq.1) then
7936               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7937             else
7938               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7939             endif
7940 #endif
7941             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7942      &        auxvec(1))
7943             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7944             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7945      &        auxvec(1))
7946             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7947             call transpose2(EUg(1,1,k),auxmat(1,1))
7948             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7949      &        pizda(1,1))
7950             vv(1)=pizda(1,1)-pizda(2,2)
7951             vv(2)=pizda(1,2)+pizda(2,1)
7952             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7953 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7954 #ifdef MOMENT
7955             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7956 #else
7957             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7958 #endif
7959             if (swap) then
7960               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7961             else
7962               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7963             endif
7964           enddo
7965         enddo
7966       enddo
7967       return
7968       end
7969 c----------------------------------------------------------------------------
7970       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7971       implicit real*8 (a-h,o-z)
7972       include 'DIMENSIONS'
7973       include 'COMMON.IOUNITS'
7974       include 'COMMON.CHAIN'
7975       include 'COMMON.DERIV'
7976       include 'COMMON.INTERACT'
7977       include 'COMMON.CONTACTS'
7978       include 'COMMON.TORSION'
7979       include 'COMMON.VAR'
7980       include 'COMMON.GEO'
7981       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7982       logical swap
7983 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7984 C
7985 C      Parallel       Antiparallel
7986 C
7987 C          o             o
7988 C         /l\   /   \   /j\
7989 C        /   \ /     \ /   \
7990 C       /| o |o       o| o |\
7991 C       j|/k\|  /      |/k\|l /
7992 C        /   \ /       /   \ /
7993 C       /     o       /     o
7994 C       i             i
7995 C
7996 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7997 C
7998 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7999 C           energy moment and not to the cluster cumulant.
8000       iti=itortyp(itype(i))
8001       if (j.lt.nres-1) then
8002         itj1=itortyp(itype(j+1))
8003       else
8004         itj1=ntortyp+1
8005       endif
8006       itk=itortyp(itype(k))
8007       itk1=itortyp(itype(k+1))
8008       if (l.lt.nres-1) then
8009         itl1=itortyp(itype(l+1))
8010       else
8011         itl1=ntortyp+1
8012       endif
8013 #ifdef MOMENT
8014       s1=dip(4,jj,i)*dip(4,kk,k)
8015 #endif
8016       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8017       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8018       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8019       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8020       call transpose2(EE(1,1,itk),auxmat(1,1))
8021       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8022       vv(1)=pizda(1,1)+pizda(2,2)
8023       vv(2)=pizda(2,1)-pizda(1,2)
8024       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8025 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8026 cd     & "sum",-(s2+s3+s4)
8027 #ifdef MOMENT
8028       eello6_graph3=-(s1+s2+s3+s4)
8029 #else
8030       eello6_graph3=-(s2+s3+s4)
8031 #endif
8032 c      eello6_graph3=-s4
8033 C Derivatives in gamma(k-1)
8034       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8035       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8036       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8037       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8038 C Derivatives in gamma(l-1)
8039       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8040       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8041       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8042       vv(1)=pizda(1,1)+pizda(2,2)
8043       vv(2)=pizda(2,1)-pizda(1,2)
8044       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8045       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8046 C Cartesian derivatives.
8047       do iii=1,2
8048         do kkk=1,5
8049           do lll=1,3
8050 #ifdef MOMENT
8051             if (iii.eq.1) then
8052               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8053             else
8054               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8055             endif
8056 #endif
8057             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8058      &        auxvec(1))
8059             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8060             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8061      &        auxvec(1))
8062             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8063             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8064      &        pizda(1,1))
8065             vv(1)=pizda(1,1)+pizda(2,2)
8066             vv(2)=pizda(2,1)-pizda(1,2)
8067             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8068 #ifdef MOMENT
8069             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8070 #else
8071             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8072 #endif
8073             if (swap) then
8074               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8075             else
8076               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8077             endif
8078 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8079           enddo
8080         enddo
8081       enddo
8082       return
8083       end
8084 c----------------------------------------------------------------------------
8085       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8086       implicit real*8 (a-h,o-z)
8087       include 'DIMENSIONS'
8088       include 'COMMON.IOUNITS'
8089       include 'COMMON.CHAIN'
8090       include 'COMMON.DERIV'
8091       include 'COMMON.INTERACT'
8092       include 'COMMON.CONTACTS'
8093       include 'COMMON.TORSION'
8094       include 'COMMON.VAR'
8095       include 'COMMON.GEO'
8096       include 'COMMON.FFIELD'
8097       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8098      & auxvec1(2),auxmat1(2,2)
8099       logical swap
8100 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8101 C
8102 C      Parallel       Antiparallel
8103 C
8104 C          o             o
8105 C         /l\   /   \   /j\
8106 C        /   \ /     \ /   \
8107 C       /| o |o       o| o |\
8108 C     \ j|/k\|      \  |/k\|l
8109 C      \ /   \       \ /   \
8110 C       o     \       o     \
8111 C       i             i
8112 C
8113 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8114 C
8115 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8116 C           energy moment and not to the cluster cumulant.
8117 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8118       iti=itortyp(itype(i))
8119       itj=itortyp(itype(j))
8120       if (j.lt.nres-1) then
8121         itj1=itortyp(itype(j+1))
8122       else
8123         itj1=ntortyp+1
8124       endif
8125       itk=itortyp(itype(k))
8126       if (k.lt.nres-1) then
8127         itk1=itortyp(itype(k+1))
8128       else
8129         itk1=ntortyp+1
8130       endif
8131       itl=itortyp(itype(l))
8132       if (l.lt.nres-1) then
8133         itl1=itortyp(itype(l+1))
8134       else
8135         itl1=ntortyp+1
8136       endif
8137 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8138 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8139 cd     & ' itl',itl,' itl1',itl1
8140 #ifdef MOMENT
8141       if (imat.eq.1) then
8142         s1=dip(3,jj,i)*dip(3,kk,k)
8143       else
8144         s1=dip(2,jj,j)*dip(2,kk,l)
8145       endif
8146 #endif
8147       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8148       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8149       if (j.eq.l+1) then
8150         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8151         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8152       else
8153         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8154         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8155       endif
8156       call transpose2(EUg(1,1,k),auxmat(1,1))
8157       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8158       vv(1)=pizda(1,1)-pizda(2,2)
8159       vv(2)=pizda(2,1)+pizda(1,2)
8160       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8161 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8162 #ifdef MOMENT
8163       eello6_graph4=-(s1+s2+s3+s4)
8164 #else
8165       eello6_graph4=-(s2+s3+s4)
8166 #endif
8167 C Derivatives in gamma(i-1)
8168       if (i.gt.1) then
8169 #ifdef MOMENT
8170         if (imat.eq.1) then
8171           s1=dipderg(2,jj,i)*dip(3,kk,k)
8172         else
8173           s1=dipderg(4,jj,j)*dip(2,kk,l)
8174         endif
8175 #endif
8176         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8177         if (j.eq.l+1) then
8178           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8179           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8180         else
8181           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8182           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8183         endif
8184         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8185         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8186 cd          write (2,*) 'turn6 derivatives'
8187 #ifdef MOMENT
8188           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8189 #else
8190           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8191 #endif
8192         else
8193 #ifdef MOMENT
8194           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8195 #else
8196           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8197 #endif
8198         endif
8199       endif
8200 C Derivatives in gamma(k-1)
8201 #ifdef MOMENT
8202       if (imat.eq.1) then
8203         s1=dip(3,jj,i)*dipderg(2,kk,k)
8204       else
8205         s1=dip(2,jj,j)*dipderg(4,kk,l)
8206       endif
8207 #endif
8208       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8209       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8210       if (j.eq.l+1) then
8211         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8212         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8213       else
8214         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8215         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8216       endif
8217       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8218       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8219       vv(1)=pizda(1,1)-pizda(2,2)
8220       vv(2)=pizda(2,1)+pizda(1,2)
8221       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8222       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8223 #ifdef MOMENT
8224         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8225 #else
8226         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8227 #endif
8228       else
8229 #ifdef MOMENT
8230         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8231 #else
8232         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8233 #endif
8234       endif
8235 C Derivatives in gamma(j-1) or gamma(l-1)
8236       if (l.eq.j+1 .and. l.gt.1) then
8237         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8238         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8239         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8240         vv(1)=pizda(1,1)-pizda(2,2)
8241         vv(2)=pizda(2,1)+pizda(1,2)
8242         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8243         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8244       else if (j.gt.1) then
8245         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8246         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8247         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8248         vv(1)=pizda(1,1)-pizda(2,2)
8249         vv(2)=pizda(2,1)+pizda(1,2)
8250         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8251         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8252           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8253         else
8254           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8255         endif
8256       endif
8257 C Cartesian derivatives.
8258       do iii=1,2
8259         do kkk=1,5
8260           do lll=1,3
8261 #ifdef MOMENT
8262             if (iii.eq.1) then
8263               if (imat.eq.1) then
8264                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8265               else
8266                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8267               endif
8268             else
8269               if (imat.eq.1) then
8270                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8271               else
8272                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8273               endif
8274             endif
8275 #endif
8276             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8277      &        auxvec(1))
8278             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8279             if (j.eq.l+1) then
8280               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8281      &          b1(1,itj1),auxvec(1))
8282               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8283             else
8284               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8285      &          b1(1,itl1),auxvec(1))
8286               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8287             endif
8288             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8289      &        pizda(1,1))
8290             vv(1)=pizda(1,1)-pizda(2,2)
8291             vv(2)=pizda(2,1)+pizda(1,2)
8292             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8293             if (swap) then
8294               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8295 #ifdef MOMENT
8296                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8297      &             -(s1+s2+s4)
8298 #else
8299                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8300      &             -(s2+s4)
8301 #endif
8302                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8303               else
8304 #ifdef MOMENT
8305                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8306 #else
8307                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8308 #endif
8309                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8310               endif
8311             else
8312 #ifdef MOMENT
8313               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8314 #else
8315               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8316 #endif
8317               if (l.eq.j+1) then
8318                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8319               else
8320                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8321               endif
8322             endif
8323           enddo
8324         enddo
8325       enddo
8326       return
8327       end
8328 c----------------------------------------------------------------------------
8329       double precision function eello_turn6(i,jj,kk)
8330       implicit real*8 (a-h,o-z)
8331       include 'DIMENSIONS'
8332       include 'COMMON.IOUNITS'
8333       include 'COMMON.CHAIN'
8334       include 'COMMON.DERIV'
8335       include 'COMMON.INTERACT'
8336       include 'COMMON.CONTACTS'
8337       include 'COMMON.TORSION'
8338       include 'COMMON.VAR'
8339       include 'COMMON.GEO'
8340       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8341      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8342      &  ggg1(3),ggg2(3)
8343       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8344      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8345 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8346 C           the respective energy moment and not to the cluster cumulant.
8347       s1=0.0d0
8348       s8=0.0d0
8349       s13=0.0d0
8350 c
8351       eello_turn6=0.0d0
8352       j=i+4
8353       k=i+1
8354       l=i+3
8355       iti=itortyp(itype(i))
8356       itk=itortyp(itype(k))
8357       itk1=itortyp(itype(k+1))
8358       itl=itortyp(itype(l))
8359       itj=itortyp(itype(j))
8360 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8361 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8362 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8363 cd        eello6=0.0d0
8364 cd        return
8365 cd      endif
8366 cd      write (iout,*)
8367 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8368 cd     &   ' and',k,l
8369 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8370       do iii=1,2
8371         do kkk=1,5
8372           do lll=1,3
8373             derx_turn(lll,kkk,iii)=0.0d0
8374           enddo
8375         enddo
8376       enddo
8377 cd      eij=1.0d0
8378 cd      ekl=1.0d0
8379 cd      ekont=1.0d0
8380       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8381 cd      eello6_5=0.0d0
8382 cd      write (2,*) 'eello6_5',eello6_5
8383 #ifdef MOMENT
8384       call transpose2(AEA(1,1,1),auxmat(1,1))
8385       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8386       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8387       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8388 #endif
8389       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8390       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8391       s2 = scalar2(b1(1,itk),vtemp1(1))
8392 #ifdef MOMENT
8393       call transpose2(AEA(1,1,2),atemp(1,1))
8394       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8395       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8396       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8397 #endif
8398       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8399       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8400       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8401 #ifdef MOMENT
8402       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8403       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8404       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8405       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8406       ss13 = scalar2(b1(1,itk),vtemp4(1))
8407       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8408 #endif
8409 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8410 c      s1=0.0d0
8411 c      s2=0.0d0
8412 c      s8=0.0d0
8413 c      s12=0.0d0
8414 c      s13=0.0d0
8415       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8416 C Derivatives in gamma(i+2)
8417       s1d =0.0d0
8418       s8d =0.0d0
8419 #ifdef MOMENT
8420       call transpose2(AEA(1,1,1),auxmatd(1,1))
8421       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8422       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8423       call transpose2(AEAderg(1,1,2),atempd(1,1))
8424       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8425       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8426 #endif
8427       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8428       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8429       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8430 c      s1d=0.0d0
8431 c      s2d=0.0d0
8432 c      s8d=0.0d0
8433 c      s12d=0.0d0
8434 c      s13d=0.0d0
8435       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8436 C Derivatives in gamma(i+3)
8437 #ifdef MOMENT
8438       call transpose2(AEA(1,1,1),auxmatd(1,1))
8439       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8440       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8441       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8442 #endif
8443       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8444       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8445       s2d = scalar2(b1(1,itk),vtemp1d(1))
8446 #ifdef MOMENT
8447       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8448       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8449 #endif
8450       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8451 #ifdef MOMENT
8452       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8453       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8454       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8455 #endif
8456 c      s1d=0.0d0
8457 c      s2d=0.0d0
8458 c      s8d=0.0d0
8459 c      s12d=0.0d0
8460 c      s13d=0.0d0
8461 #ifdef MOMENT
8462       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8463      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8464 #else
8465       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8466      &               -0.5d0*ekont*(s2d+s12d)
8467 #endif
8468 C Derivatives in gamma(i+4)
8469       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8470       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8471       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8472 #ifdef MOMENT
8473       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8474       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8475       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8476 #endif
8477 c      s1d=0.0d0
8478 c      s2d=0.0d0
8479 c      s8d=0.0d0
8480 C      s12d=0.0d0
8481 c      s13d=0.0d0
8482 #ifdef MOMENT
8483       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8484 #else
8485       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8486 #endif
8487 C Derivatives in gamma(i+5)
8488 #ifdef MOMENT
8489       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8490       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8491       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8492 #endif
8493       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8494       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8495       s2d = scalar2(b1(1,itk),vtemp1d(1))
8496 #ifdef MOMENT
8497       call transpose2(AEA(1,1,2),atempd(1,1))
8498       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8499       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8500 #endif
8501       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8502       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8503 #ifdef MOMENT
8504       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8505       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8506       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8507 #endif
8508 c      s1d=0.0d0
8509 c      s2d=0.0d0
8510 c      s8d=0.0d0
8511 c      s12d=0.0d0
8512 c      s13d=0.0d0
8513 #ifdef MOMENT
8514       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8515      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8516 #else
8517       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8518      &               -0.5d0*ekont*(s2d+s12d)
8519 #endif
8520 C Cartesian derivatives
8521       do iii=1,2
8522         do kkk=1,5
8523           do lll=1,3
8524 #ifdef MOMENT
8525             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8526             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8527             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8528 #endif
8529             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8530             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8531      &          vtemp1d(1))
8532             s2d = scalar2(b1(1,itk),vtemp1d(1))
8533 #ifdef MOMENT
8534             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8535             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8536             s8d = -(atempd(1,1)+atempd(2,2))*
8537      &           scalar2(cc(1,1,itl),vtemp2(1))
8538 #endif
8539             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8540      &           auxmatd(1,1))
8541             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8542             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8543 c      s1d=0.0d0
8544 c      s2d=0.0d0
8545 c      s8d=0.0d0
8546 c      s12d=0.0d0
8547 c      s13d=0.0d0
8548 #ifdef MOMENT
8549             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8550      &        - 0.5d0*(s1d+s2d)
8551 #else
8552             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8553      &        - 0.5d0*s2d
8554 #endif
8555 #ifdef MOMENT
8556             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8557      &        - 0.5d0*(s8d+s12d)
8558 #else
8559             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8560      &        - 0.5d0*s12d
8561 #endif
8562           enddo
8563         enddo
8564       enddo
8565 #ifdef MOMENT
8566       do kkk=1,5
8567         do lll=1,3
8568           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8569      &      achuj_tempd(1,1))
8570           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8571           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8572           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8573           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8574           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8575      &      vtemp4d(1))
8576           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8577           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8578           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8579         enddo
8580       enddo
8581 #endif
8582 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8583 cd     &  16*eel_turn6_num
8584 cd      goto 1112
8585       if (j.lt.nres-1) then
8586         j1=j+1
8587         j2=j-1
8588       else
8589         j1=j-1
8590         j2=j-2
8591       endif
8592       if (l.lt.nres-1) then
8593         l1=l+1
8594         l2=l-1
8595       else
8596         l1=l-1
8597         l2=l-2
8598       endif
8599       do ll=1,3
8600 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8601 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8602 cgrad        ghalf=0.5d0*ggg1(ll)
8603 cd        ghalf=0.0d0
8604         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8605         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8606         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8607      &    +ekont*derx_turn(ll,2,1)
8608         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8609         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8610      &    +ekont*derx_turn(ll,4,1)
8611         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8612         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8613         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8614 cgrad        ghalf=0.5d0*ggg2(ll)
8615 cd        ghalf=0.0d0
8616         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8617      &    +ekont*derx_turn(ll,2,2)
8618         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8619         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8620      &    +ekont*derx_turn(ll,4,2)
8621         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8622         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8623         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8624       enddo
8625 cd      goto 1112
8626 cgrad      do m=i+1,j-1
8627 cgrad        do ll=1,3
8628 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8629 cgrad        enddo
8630 cgrad      enddo
8631 cgrad      do m=k+1,l-1
8632 cgrad        do ll=1,3
8633 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8634 cgrad        enddo
8635 cgrad      enddo
8636 cgrad1112  continue
8637 cgrad      do m=i+2,j2
8638 cgrad        do ll=1,3
8639 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8640 cgrad        enddo
8641 cgrad      enddo
8642 cgrad      do m=k+2,l2
8643 cgrad        do ll=1,3
8644 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8645 cgrad        enddo
8646 cgrad      enddo
8647 cd      do iii=1,nres-3
8648 cd        write (2,*) iii,g_corr6_loc(iii)
8649 cd      enddo
8650       eello_turn6=ekont*eel_turn6
8651 cd      write (2,*) 'ekont',ekont
8652 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8653       return
8654       end
8655
8656 C-----------------------------------------------------------------------------
8657       double precision function scalar(u,v)
8658 !DIR$ INLINEALWAYS scalar
8659 #ifndef OSF
8660 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8661 #endif
8662       implicit none
8663       double precision u(3),v(3)
8664 cd      double precision sc
8665 cd      integer i
8666 cd      sc=0.0d0
8667 cd      do i=1,3
8668 cd        sc=sc+u(i)*v(i)
8669 cd      enddo
8670 cd      scalar=sc
8671
8672       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8673       return
8674       end
8675 crc-------------------------------------------------
8676       SUBROUTINE MATVEC2(A1,V1,V2)
8677 !DIR$ INLINEALWAYS MATVEC2
8678 #ifndef OSF
8679 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8680 #endif
8681       implicit real*8 (a-h,o-z)
8682       include 'DIMENSIONS'
8683       DIMENSION A1(2,2),V1(2),V2(2)
8684 c      DO 1 I=1,2
8685 c        VI=0.0
8686 c        DO 3 K=1,2
8687 c    3     VI=VI+A1(I,K)*V1(K)
8688 c        Vaux(I)=VI
8689 c    1 CONTINUE
8690
8691       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8692       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8693
8694       v2(1)=vaux1
8695       v2(2)=vaux2
8696       END
8697 C---------------------------------------
8698       SUBROUTINE MATMAT2(A1,A2,A3)
8699 #ifndef OSF
8700 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8701 #endif
8702       implicit real*8 (a-h,o-z)
8703       include 'DIMENSIONS'
8704       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8705 c      DIMENSION AI3(2,2)
8706 c        DO  J=1,2
8707 c          A3IJ=0.0
8708 c          DO K=1,2
8709 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8710 c          enddo
8711 c          A3(I,J)=A3IJ
8712 c       enddo
8713 c      enddo
8714
8715       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8716       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8717       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8718       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8719
8720       A3(1,1)=AI3_11
8721       A3(2,1)=AI3_21
8722       A3(1,2)=AI3_12
8723       A3(2,2)=AI3_22
8724       END
8725
8726 c-------------------------------------------------------------------------
8727       double precision function scalar2(u,v)
8728 !DIR$ INLINEALWAYS scalar2
8729       implicit none
8730       double precision u(2),v(2)
8731       double precision sc
8732       integer i
8733       scalar2=u(1)*v(1)+u(2)*v(2)
8734       return
8735       end
8736
8737 C-----------------------------------------------------------------------------
8738
8739       subroutine transpose2(a,at)
8740 !DIR$ INLINEALWAYS transpose2
8741 #ifndef OSF
8742 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8743 #endif
8744       implicit none
8745       double precision a(2,2),at(2,2)
8746       at(1,1)=a(1,1)
8747       at(1,2)=a(2,1)
8748       at(2,1)=a(1,2)
8749       at(2,2)=a(2,2)
8750       return
8751       end
8752 c--------------------------------------------------------------------------
8753       subroutine transpose(n,a,at)
8754       implicit none
8755       integer n,i,j
8756       double precision a(n,n),at(n,n)
8757       do i=1,n
8758         do j=1,n
8759           at(j,i)=a(i,j)
8760         enddo
8761       enddo
8762       return
8763       end
8764 C---------------------------------------------------------------------------
8765       subroutine prodmat3(a1,a2,kk,transp,prod)
8766 !DIR$ INLINEALWAYS prodmat3
8767 #ifndef OSF
8768 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8769 #endif
8770       implicit none
8771       integer i,j
8772       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8773       logical transp
8774 crc      double precision auxmat(2,2),prod_(2,2)
8775
8776       if (transp) then
8777 crc        call transpose2(kk(1,1),auxmat(1,1))
8778 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8779 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8780
8781            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8782      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8783            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8784      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8785            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8786      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8787            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8788      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8789
8790       else
8791 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8792 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8793
8794            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8795      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8796            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8797      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8798            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8799      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8800            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8801      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8802
8803       endif
8804 c      call transpose2(a2(1,1),a2t(1,1))
8805
8806 crc      print *,transp
8807 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8808 crc      print *,((prod(i,j),i=1,2),j=1,2)
8809
8810       return
8811       end
8812