source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 c      print *,"Processor",myrank," computed USCSC"
 135 #ifdef TIMING
 136 #ifdef MPI
 137       time01=MPI_Wtime()
 138 #else
 139       time00=tcpu()
 140 #endif
 141 #endif
 142       call vec_and_deriv
 143 #ifdef TIMING
 144 #ifdef MPI
 145       time_vec=time_vec+MPI_Wtime()-time01
 146 #else
 147       time_vec=time_vec+tcpu()-time01
 148 #endif
 149 #endif
 150 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 151       if (ipot.lt.6) then
 152 #ifdef SPLITELE
 153          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 154      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 155      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 156      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 157 #else
 158          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #endif
 163             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 164          else
 165             ees=0.0d0
 166             evdw1=0.0d0
 167             eel_loc=0.0d0
 168             eello_turn3=0.0d0
 169             eello_turn4=0.0d0
 170          endif
 171       else
 172 c        write (iout,*) "Soft-spheer ELEC potential"
 173         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 174      &   eello_turn4)
 175       endif
 176 c      print *,"Processor",myrank," computed UELEC"
 177 C
 178 C Calculate excluded-volume interaction energy between peptide groups
 179 C and side chains.
 180 C
 181       if (ipot.lt.6) then
 182        if(wscp.gt.0d0) then
 183         call escp(evdw2,evdw2_14)
 184        else
 185         evdw2=0
 186         evdw2_14=0
 187        endif
 188       else
 189 c        write (iout,*) "Soft-sphere SCP potential"
 190         call escp_soft_sphere(evdw2,evdw2_14)
 191       endif
 192 c
 193 c Calculate the bond-stretching energy
 194 c
 195       call ebond(estr)
 196 C
 197 C Calculate the disulfide-bridge and other energy and the contributions
 198 C from other distance constraints.
 199 cd    print *,'Calling EHPB'
 200       call edis(ehpb)
 201 cd    print *,'EHPB exitted succesfully.'
 202 C
 203 C Calculate the virtual-bond-angle energy.
 204 C
 205       if (wang.gt.0d0) then
 206         call ebend(ebe)
 207       else
 208         ebe=0
 209       endif
 210 c      print *,"Processor",myrank," computed UB"
 211 C
 212 C Calculate the SC local energy.
 213 C
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 c      print *,"Processor",myrank," computed Usccorr"
 245 C
 246 C 12/1/95 Multi-body terms
 247 C
 248       n_corr=0
 249       n_corr1=0
 250       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 251      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 252          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 253 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 254 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 255       else
 256          ecorr=0.0d0
 257          ecorr5=0.0d0
 258          ecorr6=0.0d0
 259          eturn6=0.0d0
 260       endif
 261       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 262          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 263 cd         write (iout,*) "multibody_hb ecorr",ecorr
 264       endif
 265 c      print *,"Processor",myrank," computed Ucorr"
 266 C
 267 C If performing constraint dynamics, call the constraint energy
 268 C  after the equilibration time
 269       if(usampl.and.totT.gt.eq_time) then
 270          call EconstrQ
 271          call Econstr_back
 272       else
 273          Uconst=0.0d0
 274          Uconst_back=0.0d0
 275       endif
 276 #ifdef TIMING
 277 #ifdef MPI
 278       time_enecalc=time_enecalc+MPI_Wtime()-time00
 279 #else
 280       time_enecalc=time_enecalc+tcpu()-time00
 281 #endif
 282 #endif
 283 c      print *,"Processor",myrank," computed Uconstr"
 284 #ifdef TIMING
 285 #ifdef MPI
 286       time00=MPI_Wtime()
 287 #else
 288       time00=tcpu()
 289 #endif
 290 #endif
 291 c
 292 C Sum the energies
 293 C
 294       energia(1)=evdw
 295 #ifdef SCP14
 296       energia(2)=evdw2-evdw2_14
 297       energia(18)=evdw2_14
 298 #else
 299       energia(2)=evdw2
 300       energia(18)=0.0d0
 301 #endif
 302 #ifdef SPLITELE
 303       energia(3)=ees
 304       energia(16)=evdw1
 305 #else
 306       energia(3)=ees+evdw1
 307       energia(16)=0.0d0
 308 #endif
 309       energia(4)=ecorr
 310       energia(5)=ecorr5
 311       energia(6)=ecorr6
 312       energia(7)=eel_loc
 313       energia(8)=eello_turn3
 314       energia(9)=eello_turn4
 315       energia(10)=eturn6
 316       energia(11)=ebe
 317       energia(12)=escloc
 318       energia(13)=etors
 319       energia(14)=etors_d
 320       energia(15)=ehpb
 321       energia(19)=edihcnstr
 322       energia(17)=estr
 323       energia(20)=Uconst+Uconst_back
 324       energia(21)=esccor
 325       energia(22)=evdw_p
 326       energia(23)=evdw_m
 327 c      print *," Processor",myrank," calls SUM_ENERGY"
 328       call sum_energy(energia,.true.)
 329 c      print *," Processor",myrank," left SUM_ENERGY"
 330 #ifdef TIMING
 331 #ifdef MPI
 332       time_sumene=time_sumene+MPI_Wtime()-time00
 333 #else
 334       time_sumene=time_sumene+tcpu()-time00
 335 #endif
 336 #endif
 337       return
 338       end
 339 c-------------------------------------------------------------------------------
 340       subroutine sum_energy(energia,reduce)
 341       implicit real*8 (a-h,o-z)
 342       include 'DIMENSIONS'
 343 #ifndef ISNAN
 344       external proc_proc
 345 #ifdef WINPGI
 346 cMS$ATTRIBUTES C ::  proc_proc
 347 #endif
 348 #endif
 349 #ifdef MPI
 350       include "mpif.h"
 351 #endif
 352       include 'COMMON.SETUP'
 353       include 'COMMON.IOUNITS'
 354       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 355       include 'COMMON.FFIELD'
 356       include 'COMMON.DERIV'
 357       include 'COMMON.INTERACT'
 358       include 'COMMON.SBRIDGE'
 359       include 'COMMON.CHAIN'
 360       include 'COMMON.VAR'
 361       include 'COMMON.CONTROL'
 362       include 'COMMON.TIME1'
 363       logical reduce
 364 #ifdef MPI
 365       if (nfgtasks.gt.1 .and. reduce) then
 366 #ifdef DEBUG
 367         write (iout,*) "energies before REDUCE"
 368         call enerprint(energia)
 369         call flush(iout)
 370 #endif
 371         do i=0,n_ene
 372           enebuff(i)=energia(i)
 373         enddo
 374         time00=MPI_Wtime()
 375         call MPI_Barrier(FG_COMM,IERR)
 376         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 377         time00=MPI_Wtime()
 378         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 379      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 380 #ifdef DEBUG
 381         write (iout,*) "energies after REDUCE"
 382         call enerprint(energia)
 383         call flush(iout)
 384 #endif
 385         time_Reduce=time_Reduce+MPI_Wtime()-time00
 386       endif
 387       if (fg_rank.eq.0) then
 388 #endif
 389 #ifdef TSCSC
 390       evdw=energia(22)+wsct*energia(23)
 391 #else
 392       evdw=energia(1)
 393 #endif
 394 #ifdef SCP14
 395       evdw2=energia(2)+energia(18)
 396       evdw2_14=energia(18)
 397 #else
 398       evdw2=energia(2)
 399 #endif
 400 #ifdef SPLITELE
 401       ees=energia(3)
 402       evdw1=energia(16)
 403 #else
 404       ees=energia(3)
 405       evdw1=0.0d0
 406 #endif
 407       ecorr=energia(4)
 408       ecorr5=energia(5)
 409       ecorr6=energia(6)
 410       eel_loc=energia(7)
 411       eello_turn3=energia(8)
 412       eello_turn4=energia(9)
 413       eturn6=energia(10)
 414       ebe=energia(11)
 415       escloc=energia(12)
 416       etors=energia(13)
 417       etors_d=energia(14)
 418       ehpb=energia(15)
 419       edihcnstr=energia(19)
 420       estr=energia(17)
 421       Uconst=energia(20)
 422       esccor=energia(21)
 423 #ifdef SPLITELE
 424       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 425      & +wang*ebe+wtor*etors+wscloc*escloc
 426      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 427      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 428      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 429      & +wbond*estr+Uconst+wsccor*esccor
 430 #else
 431       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 432      & +wang*ebe+wtor*etors+wscloc*escloc
 433      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 434      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 435      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 436      & +wbond*estr+Uconst+wsccor*esccor
 437 #endif
 438       energia(0)=etot
 439 c detecting NaNQ
 440 #ifdef ISNAN
 441 #ifdef AIX
 442       if (isnan(etot).ne.0) energia(0)=1.0d+99
 443 #else
 444       if (isnan(etot)) energia(0)=1.0d+99
 445 #endif
 446 #else
 447       i=0
 448 #ifdef WINPGI
 449       idumm=proc_proc(etot,i)
 450 #else
 451       call proc_proc(etot,i)
 452 #endif
 453       if(i.eq.1)energia(0)=1.0d+99
 454 #endif
 455 #ifdef MPI
 456       endif
 457 #endif
 458       return
 459       end
 460 c-------------------------------------------------------------------------------
 461       subroutine sum_gradient
 462       implicit real*8 (a-h,o-z)
 463       include 'DIMENSIONS'
 464 #ifndef ISNAN
 465       external proc_proc
 466 #ifdef WINPGI
 467 cMS$ATTRIBUTES C ::  proc_proc
 468 #endif
 469 #endif
 470 #ifdef MPI
 471       include 'mpif.h'
 472 #endif
 473       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 474      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 475       include 'COMMON.SETUP'
 476       include 'COMMON.IOUNITS'
 477       include 'COMMON.FFIELD'
 478       include 'COMMON.DERIV'
 479       include 'COMMON.INTERACT'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CHAIN'
 482       include 'COMMON.VAR'
 483       include 'COMMON.CONTROL'
 484       include 'COMMON.TIME1'
 485       include 'COMMON.MAXGRAD'
 486       include 'COMMON.SCCOR'
 487 #ifdef TIMING
 488 #ifdef MPI
 489       time01=MPI_Wtime()
 490 #else
 491       time01=tcpu()
 492 #endif
 493 #endif
 494 #ifdef DEBUG
 495       write (iout,*) "sum_gradient gvdwc, gvdwx"
 496       do i=1,nres
 497         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 498      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 499      &   (gvdwcT(j,i),j=1,3)
 500       enddo
 501       call flush(iout)
 502 #endif
 503 #ifdef MPI
 504 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 505         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 506      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 507 #endif
 508 C
 509 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 510 C            in virtual-bond-vector coordinates
 511 C
 512 #ifdef DEBUG
 513 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 514 c      do i=1,nres-1
 515 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 516 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 517 c      enddo
 518 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 521 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 522 c      enddo
 523       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 524       do i=1,nres
 525         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 526      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 527      &   g_corr5_loc(i)
 528       enddo
 529       call flush(iout)
 530 #endif
 531 #ifdef SPLITELE
 532 #ifdef TSCSC
 533       do i=1,nct
 534         do j=1,3
 535           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 536      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 537      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 538      &                wel_loc*gel_loc_long(j,i)+
 539      &                wcorr*gradcorr_long(j,i)+
 540      &                wcorr5*gradcorr5_long(j,i)+
 541      &                wcorr6*gradcorr6_long(j,i)+
 542      &                wturn6*gcorr6_turn_long(j,i)+
 543      &                wstrain*ghpbc(j,i)
 544         enddo
 545       enddo
 546 #else
 547       do i=1,nct
 548         do j=1,3
 549           gradbufc(j,i)=wsc*gvdwc(j,i)+
 550      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 551      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 552      &                wel_loc*gel_loc_long(j,i)+
 553      &                wcorr*gradcorr_long(j,i)+
 554      &                wcorr5*gradcorr5_long(j,i)+
 555      &                wcorr6*gradcorr6_long(j,i)+
 556      &                wturn6*gcorr6_turn_long(j,i)+
 557      &                wstrain*ghpbc(j,i)
 558         enddo
 559       enddo
 560 #endif
 561 #else
 562       do i=1,nct
 563         do j=1,3
 564           gradbufc(j,i)=wsc*gvdwc(j,i)+
 565      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 566      &                welec*gelc_long(j,i)+
 567      &                wbond*gradb(j,i)+
 568      &                wel_loc*gel_loc_long(j,i)+
 569      &                wcorr*gradcorr_long(j,i)+
 570      &                wcorr5*gradcorr5_long(j,i)+
 571      &                wcorr6*gradcorr6_long(j,i)+
 572      &                wturn6*gcorr6_turn_long(j,i)+
 573      &                wstrain*ghpbc(j,i)
 574         enddo
 575       enddo
 576 #endif
 577 #ifdef MPI
 578       if (nfgtasks.gt.1) then
 579       time00=MPI_Wtime()
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc before allreduce"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       do i=1,nres
 588         do j=1,3
 589           gradbufc_sum(j,i)=gradbufc(j,i)
 590         enddo
 591       enddo
 592 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 593 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 594 c      time_reduce=time_reduce+MPI_Wtime()-time00
 595 #ifdef DEBUG
 596 c      write (iout,*) "gradbufc_sum after allreduce"
 597 c      do i=1,nres
 598 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 599 c      enddo
 600 c      call flush(iout)
 601 #endif
 602 #ifdef TIMING
 603 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 604 #endif
 605       do i=nnt,nres
 606         do k=1,3
 607           gradbufc(k,i)=0.0d0
 608         enddo
 609       enddo
 610 #ifdef DEBUG
 611       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 612       write (iout,*) (i," jgrad_start",jgrad_start(i),
 613      &                  " jgrad_end  ",jgrad_end(i),
 614      &                  i=igrad_start,igrad_end)
 615 #endif
 616 c
 617 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 618 c do not parallelize this part.
 619 c
 620 c      do i=igrad_start,igrad_end
 621 c        do j=jgrad_start(i),jgrad_end(i)
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627       do j=1,3
 628         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 629       enddo
 630       do i=nres-2,nnt,-1
 631         do j=1,3
 632           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 633         enddo
 634       enddo
 635 #ifdef DEBUG
 636       write (iout,*) "gradbufc after summing"
 637       do i=1,nres
 638         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 639       enddo
 640       call flush(iout)
 641 #endif
 642       else
 643 #endif
 644 #ifdef DEBUG
 645       write (iout,*) "gradbufc"
 646       do i=1,nres
 647         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 648       enddo
 649       call flush(iout)
 650 #endif
 651       do i=1,nres
 652         do j=1,3
 653           gradbufc_sum(j,i)=gradbufc(j,i)
 654           gradbufc(j,i)=0.0d0
 655         enddo
 656       enddo
 657       do j=1,3
 658         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 659       enddo
 660       do i=nres-2,nnt,-1
 661         do j=1,3
 662           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 663         enddo
 664       enddo
 665 c      do i=nnt,nres-1
 666 c        do k=1,3
 667 c          gradbufc(k,i)=0.0d0
 668 c        enddo
 669 c        do j=i+1,nres
 670 c          do k=1,3
 671 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 672 c          enddo
 673 c        enddo
 674 c      enddo
 675 #ifdef DEBUG
 676       write (iout,*) "gradbufc after summing"
 677       do i=1,nres
 678         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 679       enddo
 680       call flush(iout)
 681 #endif
 682 #ifdef MPI
 683       endif
 684 #endif
 685       do k=1,3
 686         gradbufc(k,nres)=0.0d0
 687       enddo
 688       do i=1,nct
 689         do j=1,3
 690 #ifdef SPLITELE
 691           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 692      &                wel_loc*gel_loc(j,i)+
 693      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 694      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 695      &                wel_loc*gel_loc_long(j,i)+
 696      &                wcorr*gradcorr_long(j,i)+
 697      &                wcorr5*gradcorr5_long(j,i)+
 698      &                wcorr6*gradcorr6_long(j,i)+
 699      &                wturn6*gcorr6_turn_long(j,i))+
 700      &                wbond*gradb(j,i)+
 701      &                wcorr*gradcorr(j,i)+
 702      &                wturn3*gcorr3_turn(j,i)+
 703      &                wturn4*gcorr4_turn(j,i)+
 704      &                wcorr5*gradcorr5(j,i)+
 705      &                wcorr6*gradcorr6(j,i)+
 706      &                wturn6*gcorr6_turn(j,i)+
 707      &                wsccor*gsccorc(j,i)
 708      &               +wscloc*gscloc(j,i)
 709 #else
 710           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 711      &                wel_loc*gel_loc(j,i)+
 712      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 713      &                welec*gelc_long(j,i)+
 714      &                wel_loc*gel_loc_long(j,i)+
 715      &                wcorr*gcorr_long(j,i)+
 716      &                wcorr5*gradcorr5_long(j,i)+
 717      &                wcorr6*gradcorr6_long(j,i)+
 718      &                wturn6*gcorr6_turn_long(j,i))+
 719      &                wbond*gradb(j,i)+
 720      &                wcorr*gradcorr(j,i)+
 721      &                wturn3*gcorr3_turn(j,i)+
 722      &                wturn4*gcorr4_turn(j,i)+
 723      &                wcorr5*gradcorr5(j,i)+
 724      &                wcorr6*gradcorr6(j,i)+
 725      &                wturn6*gcorr6_turn(j,i)+
 726      &                wsccor*gsccorc(j,i)
 727      &               +wscloc*gscloc(j,i)
 728 #endif
 729 #ifdef TSCSC
 730           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 731      &                  wscp*gradx_scp(j,i)+
 732      &                  wbond*gradbx(j,i)+
 733      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 734      &                  wsccor*gsccorx(j,i)
 735      &                 +wscloc*gsclocx(j,i)
 736 #else
 737           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 738      &                  wbond*gradbx(j,i)+
 739      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 740      &                  wsccor*gsccorx(j,i)
 741      &                 +wscloc*gsclocx(j,i)
 742 #endif
 743         enddo
 744       enddo
 745 #ifdef DEBUG
 746       write (iout,*) "gloc before adding corr"
 747       do i=1,4*nres
 748         write (iout,*) i,gloc(i,icg)
 749       enddo
 750 #endif
 751       do i=1,nres-3
 752         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 753      &   +wcorr5*g_corr5_loc(i)
 754      &   +wcorr6*g_corr6_loc(i)
 755      &   +wturn4*gel_loc_turn4(i)
 756      &   +wturn3*gel_loc_turn3(i)
 757      &   +wturn6*gel_loc_turn6(i)
 758      &   +wel_loc*gel_loc_loc(i)
 759       enddo
 760 #ifdef DEBUG
 761       write (iout,*) "gloc after adding corr"
 762       do i=1,4*nres
 763         write (iout,*) i,gloc(i,icg)
 764       enddo
 765 #endif
 766 #ifdef MPI
 767       if (nfgtasks.gt.1) then
 768         do j=1,3
 769           do i=1,nres
 770             gradbufc(j,i)=gradc(j,i,icg)
 771             gradbufx(j,i)=gradx(j,i,icg)
 772           enddo
 773         enddo
 774         do i=1,4*nres
 775           glocbuf(i)=gloc(i,icg)
 776         enddo
 777 #define DEBUG
 778 #ifdef DEBUG
 779       write (iout,*) "gloc_sc before reduce"
 780       do i=1,nres
 781        do j=1,3
 782         write (iout,*) i,j,gloc_sc(j,i,icg)
 783        enddo
 784       enddo
 785 #endif
 786 #undef DEBUG
 787         do i=1,nres
 788          do j=1,3
 789           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 790          enddo
 791         enddo
 792         time00=MPI_Wtime()
 793         call MPI_Barrier(FG_COMM,IERR)
 794         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 795         time00=MPI_Wtime()
 796         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 797      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 798         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 799      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 800         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 802         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 803      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 804         time_reduce=time_reduce+MPI_Wtime()-time00
 805 #define DEBUG
 806 #ifdef DEBUG
 807       write (iout,*) "gloc_sc after reduce"
 808       do i=1,nres
 809        do j=1,3
 810         write (iout,*) i,j,gloc_sc(j,i,icg)
 811        enddo
 812       enddo
 813 #endif
 814 #undef DEBUG
 815 #ifdef DEBUG
 816       write (iout,*) "gloc after reduce"
 817       do i=1,4*nres
 818         write (iout,*) i,gloc(i,icg)
 819       enddo
 820 #endif
 821       endif
 822 #endif
 823       if (gnorm_check) then
 824 c
 825 c Compute the maximum elements of the gradient
 826 c
 827       gvdwc_max=0.0d0
 828       gvdwc_scp_max=0.0d0
 829       gelc_max=0.0d0
 830       gvdwpp_max=0.0d0
 831       gradb_max=0.0d0
 832       ghpbc_max=0.0d0
 833       gradcorr_max=0.0d0
 834       gel_loc_max=0.0d0
 835       gcorr3_turn_max=0.0d0
 836       gcorr4_turn_max=0.0d0
 837       gradcorr5_max=0.0d0
 838       gradcorr6_max=0.0d0
 839       gcorr6_turn_max=0.0d0
 840       gsccorc_max=0.0d0
 841       gscloc_max=0.0d0
 842       gvdwx_max=0.0d0
 843       gradx_scp_max=0.0d0
 844       ghpbx_max=0.0d0
 845       gradxorr_max=0.0d0
 846       gsccorx_max=0.0d0
 847       gsclocx_max=0.0d0
 848       do i=1,nct
 849         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 850         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 851 #ifdef TSCSC
 852         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 853         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 854 #endif
 855         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 856         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 857      &   gvdwc_scp_max=gvdwc_scp_norm
 858         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 859         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 860         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 861         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 862         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 863         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 864         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 865         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 866         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 867         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 868         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 869         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 870         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 871      &    gcorr3_turn(1,i)))
 872         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 873      &    gcorr3_turn_max=gcorr3_turn_norm
 874         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 875      &    gcorr4_turn(1,i)))
 876         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 877      &    gcorr4_turn_max=gcorr4_turn_norm
 878         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 879         if (gradcorr5_norm.gt.gradcorr5_max)
 880      &    gradcorr5_max=gradcorr5_norm
 881         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 882         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 883         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 884      &    gcorr6_turn(1,i)))
 885         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 886      &    gcorr6_turn_max=gcorr6_turn_norm
 887         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 888         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 889         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 890         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 891         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 892         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 893 #ifdef TSCSC
 894         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 895         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 896 #endif
 897         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 898         if (gradx_scp_norm.gt.gradx_scp_max)
 899      &    gradx_scp_max=gradx_scp_norm
 900         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 901         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 902         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 903         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 904         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 905         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 906         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 907         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 908       enddo
 909       if (gradout) then
 910 #ifdef AIX
 911         open(istat,file=statname,position="append")
 912 #else
 913         open(istat,file=statname,access="append")
 914 #endif
 915         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 916      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 917      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 918      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 919      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 920      &     gsccorx_max,gsclocx_max
 921         close(istat)
 922         if (gvdwc_max.gt.1.0d4) then
 923           write (iout,*) "gvdwc gvdwx gradb gradbx"
 924           do i=nnt,nct
 925             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 926      &        gradb(j,i),gradbx(j,i),j=1,3)
 927           enddo
 928           call pdbout(0.0d0,'cipiszcze',iout)
 929           call flush(iout)
 930         endif
 931       endif
 932       endif
 933 #ifdef DEBUG
 934       write (iout,*) "gradc gradx gloc"
 935       do i=1,nres
 936         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 937      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 938       enddo
 939 #endif
 940 #ifdef TIMING
 941 #ifdef MPI
 942       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 943 #else
 944       time_sumgradient=time_sumgradient+tcpu()-time01
 945 #endif
 946 #endif
 947       return
 948       end
 949 c-------------------------------------------------------------------------------
 950       subroutine rescale_weights(t_bath)
 951       implicit real*8 (a-h,o-z)
 952       include 'DIMENSIONS'
 953       include 'COMMON.IOUNITS'
 954       include 'COMMON.FFIELD'
 955       include 'COMMON.SBRIDGE'
 956       double precision kfac /2.4d0/
 957       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 958 c      facT=temp0/t_bath
 959 c      facT=2*temp0/(t_bath+temp0)
 960       if (rescale_mode.eq.0) then
 961         facT=1.0d0
 962         facT2=1.0d0
 963         facT3=1.0d0
 964         facT4=1.0d0
 965         facT5=1.0d0
 966       else if (rescale_mode.eq.1) then
 967         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 968         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 969         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 970         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 971         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 972       else if (rescale_mode.eq.2) then
 973         x=t_bath/temp0
 974         x2=x*x
 975         x3=x2*x
 976         x4=x3*x
 977         x5=x4*x
 978         facT=licznik/dlog(dexp(x)+dexp(-x))
 979         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 980         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 981         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 982         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 983       else
 984         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 985         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 986 #ifdef MPI
 987        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 988 #endif
 989        stop 555
 990       endif
 991       welec=weights(3)*fact
 992       wcorr=weights(4)*fact3
 993       wcorr5=weights(5)*fact4
 994       wcorr6=weights(6)*fact5
 995       wel_loc=weights(7)*fact2
 996       wturn3=weights(8)*fact2
 997       wturn4=weights(9)*fact3
 998       wturn6=weights(10)*fact5
 999       wtor=weights(13)*fact
1000       wtor_d=weights(14)*fact2
1001       wsccor=weights(21)*fact
1002 #ifdef TSCSC
1003 c      wsct=t_bath/temp0
1004       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1005 #endif
1006       return
1007       end
1008 C------------------------------------------------------------------------
1009       subroutine enerprint(energia)
1010       implicit real*8 (a-h,o-z)
1011       include 'DIMENSIONS'
1012       include 'COMMON.IOUNITS'
1013       include 'COMMON.FFIELD'
1014       include 'COMMON.SBRIDGE'
1015       include 'COMMON.MD'
1016       double precision energia(0:n_ene)
1017       etot=energia(0)
1018 #ifdef TSCSC
1019       evdw=energia(22)+wsct*energia(23)
1020 #else
1021       evdw=energia(1)
1022 #endif
1023       evdw2=energia(2)
1024 #ifdef SCP14
1025       evdw2=energia(2)+energia(18)
1026 #else
1027       evdw2=energia(2)
1028 #endif
1029       ees=energia(3)
1030 #ifdef SPLITELE
1031       evdw1=energia(16)
1032 #endif
1033       ecorr=energia(4)
1034       ecorr5=energia(5)
1035       ecorr6=energia(6)
1036       eel_loc=energia(7)
1037       eello_turn3=energia(8)
1038       eello_turn4=energia(9)
1039       eello_turn6=energia(10)
1040       ebe=energia(11)
1041       escloc=energia(12)
1042       etors=energia(13)
1043       etors_d=energia(14)
1044       ehpb=energia(15)
1045       edihcnstr=energia(19)
1046       estr=energia(17)
1047       Uconst=energia(20)
1048       esccor=energia(21)
1049 #ifdef SPLITELE
1050       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1051      &  estr,wbond,ebe,wang,
1052      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1053      &  ecorr,wcorr,
1054      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1055      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1056      &  edihcnstr,ebr*nss,
1057      &  Uconst,etot
1058    10 format (/'Virtual-chain energies:'//
1059      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1060      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1061      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1062      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1063      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1064      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1065      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1066      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1067      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1068      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1069      & ' (SS bridges & dist. cnstr.)'/
1070      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1071      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1072      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1073      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1074      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1075      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1076      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1077      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1078      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1079      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1080      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1081      & 'ETOT=  ',1pE16.6,' (total)')
1082 #else
1083       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1084      &  estr,wbond,ebe,wang,
1085      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1086      &  ecorr,wcorr,
1087      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1088      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1089      &  ebr*nss,Uconst,etot
1090    10 format (/'Virtual-chain energies:'//
1091      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1092      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1093      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1094      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1095      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1096      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1097      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1098      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1099      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1100      & ' (SS bridges & dist. cnstr.)'/
1101      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1102      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1105      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1106      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1107      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1108      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1109      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1110      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1111      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1112      & 'ETOT=  ',1pE16.6,' (total)')
1113 #endif
1114       return
1115       end
1116 C-----------------------------------------------------------------------
1117       subroutine elj(evdw,evdw_p,evdw_m)
1118 C
1119 C This subroutine calculates the interaction energy of nonbonded side chains
1120 C assuming the LJ potential of interaction.
1121 C
1122       implicit real*8 (a-h,o-z)
1123       include 'DIMENSIONS'
1124       parameter (accur=1.0d-10)
1125       include 'COMMON.GEO'
1126       include 'COMMON.VAR'
1127       include 'COMMON.LOCAL'
1128       include 'COMMON.CHAIN'
1129       include 'COMMON.DERIV'
1130       include 'COMMON.INTERACT'
1131       include 'COMMON.TORSION'
1132       include 'COMMON.SBRIDGE'
1133       include 'COMMON.NAMES'
1134       include 'COMMON.IOUNITS'
1135       include 'COMMON.CONTACTS'
1136       dimension gg(3)
1137 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1138       evdw=0.0D0
1139       do i=iatsc_s,iatsc_e
1140         itypi=iabs(itype(i))
1141         itypi1=iabs(itype(i+1))
1142         xi=c(1,nres+i)
1143         yi=c(2,nres+i)
1144         zi=c(3,nres+i)
1145 C Change 12/1/95
1146         num_conti=0
1147 C
1148 C Calculate SC interaction energy.
1149 C
1150         do iint=1,nint_gr(i)
1151 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1152 cd   &                  'iend=',iend(i,iint)
1153           do j=istart(i,iint),iend(i,iint)
1154             itypj=iabs(itype(j))
1155             xj=c(1,nres+j)-xi
1156             yj=c(2,nres+j)-yi
1157             zj=c(3,nres+j)-zi
1158 C Change 12/1/95 to calculate four-body interactions
1159             rij=xj*xj+yj*yj+zj*zj
1160             rrij=1.0D0/rij
1161 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1162             eps0ij=eps(itypi,itypj)
1163             fac=rrij**expon2
1164             e1=fac*fac*aa(itypi,itypj)
1165             e2=fac*bb(itypi,itypj)
1166             evdwij=e1+e2
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1170 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1173 #ifdef TSCSC
1174             if (bb(itypi,itypj).gt.0) then
1175                evdw_p=evdw_p+evdwij
1176             else
1177                evdw_m=evdw_m+evdwij
1178             endif
1179 #else
1180             evdw=evdw+evdwij
1181 #endif
1182 C
1183 C Calculate the components of the gradient in DC and X
1184 C
1185             fac=-rrij*(e1+evdwij)
1186             gg(1)=xj*fac
1187             gg(2)=yj*fac
1188             gg(3)=zj*fac
1189 #ifdef TSCSC
1190             if (bb(itypi,itypj).gt.0.0d0) then
1191               do k=1,3
1192                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1194                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1195                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1196               enddo
1197             else
1198               do k=1,3
1199                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1200                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1201                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1202                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1203               enddo
1204             endif
1205 #else
1206             do k=1,3
1207               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1208               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1209               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1210               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1211             enddo
1212 #endif
1213 cgrad            do k=i,j-1
1214 cgrad              do l=1,3
1215 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1216 cgrad              enddo
1217 cgrad            enddo
1218 C
1219 C 12/1/95, revised on 5/20/97
1220 C
1221 C Calculate the contact function. The ith column of the array JCONT will
1222 C contain the numbers of atoms that make contacts with the atom I (of numbers
1223 C greater than I). The arrays FACONT and GACONT will contain the values of
1224 C the contact function and its derivative.
1225 C
1226 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1227 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1228 C Uncomment next line, if the correlation interactions are contact function only
1229             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1230               rij=dsqrt(rij)
1231               sigij=sigma(itypi,itypj)
1232               r0ij=rs0(itypi,itypj)
1233 C
1234 C Check whether the SC's are not too far to make a contact.
1235 C
1236               rcut=1.5d0*r0ij
1237               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1238 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1239 C
1240               if (fcont.gt.0.0D0) then
1241 C If the SC-SC distance if close to sigma, apply spline.
1242 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1243 cAdam &             fcont1,fprimcont1)
1244 cAdam           fcont1=1.0d0-fcont1
1245 cAdam           if (fcont1.gt.0.0d0) then
1246 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1247 cAdam             fcont=fcont*fcont1
1248 cAdam           endif
1249 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1250 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1251 cga             do k=1,3
1252 cga               gg(k)=gg(k)*eps0ij
1253 cga             enddo
1254 cga             eps0ij=-evdwij*eps0ij
1255 C Uncomment for AL's type of SC correlation interactions.
1256 cadam           eps0ij=-evdwij
1257                 num_conti=num_conti+1
1258                 jcont(num_conti,i)=j
1259                 facont(num_conti,i)=fcont*eps0ij
1260                 fprimcont=eps0ij*fprimcont/rij
1261                 fcont=expon*fcont
1262 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1263 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1264 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1265 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1266                 gacont(1,num_conti,i)=-fprimcont*xj
1267                 gacont(2,num_conti,i)=-fprimcont*yj
1268                 gacont(3,num_conti,i)=-fprimcont*zj
1269 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1270 cd              write (iout,'(2i3,3f10.5)')
1271 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1272               endif
1273             endif
1274           enddo      ! j
1275         enddo        ! iint
1276 C Change 12/1/95
1277         num_cont(i)=num_conti
1278       enddo          ! i
1279       do i=1,nct
1280         do j=1,3
1281           gvdwc(j,i)=expon*gvdwc(j,i)
1282           gvdwx(j,i)=expon*gvdwx(j,i)
1283         enddo
1284       enddo
1285 C******************************************************************************
1286 C
1287 C                              N O T E !!!
1288 C
1289 C To save time, the factor of EXPON has been extracted from ALL components
1290 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1291 C use!
1292 C
1293 C******************************************************************************
1294       return
1295       end
1296 C-----------------------------------------------------------------------------
1297       subroutine eljk(evdw,evdw_p,evdw_m)
1298 C
1299 C This subroutine calculates the interaction energy of nonbonded side chains
1300 C assuming the LJK potential of interaction.
1301 C
1302       implicit real*8 (a-h,o-z)
1303       include 'DIMENSIONS'
1304       include 'COMMON.GEO'
1305       include 'COMMON.VAR'
1306       include 'COMMON.LOCAL'
1307       include 'COMMON.CHAIN'
1308       include 'COMMON.DERIV'
1309       include 'COMMON.INTERACT'
1310       include 'COMMON.IOUNITS'
1311       include 'COMMON.NAMES'
1312       dimension gg(3)
1313       logical scheck
1314 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1315       evdw=0.0D0
1316       do i=iatsc_s,iatsc_e
1317         itypi=iabs(itype(i))
1318         itypi1=iabs(itype(i+1))
1319         xi=c(1,nres+i)
1320         yi=c(2,nres+i)
1321         zi=c(3,nres+i)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             itypj=iabs(itype(j))
1328             xj=c(1,nres+j)-xi
1329             yj=c(2,nres+j)-yi
1330             zj=c(3,nres+j)-zi
1331             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1332             fac_augm=rrij**expon
1333             e_augm=augm(itypi,itypj)*fac_augm
1334             r_inv_ij=dsqrt(rrij)
1335             rij=1.0D0/r_inv_ij
1336             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1337             fac=r_shift_inv**expon
1338             e1=fac*fac*aa(itypi,itypj)
1339             e2=fac*bb(itypi,itypj)
1340             evdwij=e_augm+e1+e2
1341 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1342 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1343 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1344 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1345 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1346 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1347 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1348 #ifdef TSCSC
1349             if (bb(itypi,itypj).gt.0) then
1350                evdw_p=evdw_p+evdwij
1351             else
1352                evdw_m=evdw_m+evdwij
1353             endif
1354 #else
1355             evdw=evdw+evdwij
1356 #endif
1357 C
1358 C Calculate the components of the gradient in DC and X
1359 C
1360             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1361             gg(1)=xj*fac
1362             gg(2)=yj*fac
1363             gg(3)=zj*fac
1364 #ifdef TSCSC
1365             if (bb(itypi,itypj).gt.0.0d0) then
1366               do k=1,3
1367                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1368                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1369                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1370                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1371               enddo
1372             else
1373               do k=1,3
1374                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1375                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1376                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1377                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1378               enddo
1379             endif
1380 #else
1381             do k=1,3
1382               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1383               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1384               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1385               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1386             enddo
1387 #endif
1388 cgrad            do k=i,j-1
1389 cgrad              do l=1,3
1390 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1391 cgrad              enddo
1392 cgrad            enddo
1393           enddo      ! j
1394         enddo        ! iint
1395       enddo          ! i
1396       do i=1,nct
1397         do j=1,3
1398           gvdwc(j,i)=expon*gvdwc(j,i)
1399           gvdwx(j,i)=expon*gvdwx(j,i)
1400         enddo
1401       enddo
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine ebp(evdw,evdw_p,evdw_m)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Berne-Pechukas potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       common /srutu/ icall
1422 c     double precision rrsave(maxdim)
1423       logical lprn
1424       evdw=0.0D0
1425 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1426       evdw=0.0D0
1427 c     if (icall.eq.0) then
1428 c       lprn=.true.
1429 c     else
1430         lprn=.false.
1431 c     endif
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=iabs(itype(i))
1435         itypi1=iabs(itype(i+1))
1436         xi=c(1,nres+i)
1437         yi=c(2,nres+i)
1438         zi=c(3,nres+i)
1439         dxi=dc_norm(1,nres+i)
1440         dyi=dc_norm(2,nres+i)
1441         dzi=dc_norm(3,nres+i)
1442 c        dsci_inv=dsc_inv(itypi)
1443         dsci_inv=vbld_inv(i+nres)
1444 C
1445 C Calculate SC interaction energy.
1446 C
1447         do iint=1,nint_gr(i)
1448           do j=istart(i,iint),iend(i,iint)
1449             ind=ind+1
1450             itypj=iabs(itype(j))
1451 c            dscj_inv=dsc_inv(itypj)
1452             dscj_inv=vbld_inv(j+nres)
1453             chi1=chi(itypi,itypj)
1454             chi2=chi(itypj,itypi)
1455             chi12=chi1*chi2
1456             chip1=chip(itypi)
1457             chip2=chip(itypj)
1458             chip12=chip1*chip2
1459             alf1=alp(itypi)
1460             alf2=alp(itypj)
1461             alf12=0.5D0*(alf1+alf2)
1462 C For diagnostics only!!!
1463 c           chi1=0.0D0
1464 c           chi2=0.0D0
1465 c           chi12=0.0D0
1466 c           chip1=0.0D0
1467 c           chip2=0.0D0
1468 c           chip12=0.0D0
1469 c           alf1=0.0D0
1470 c           alf2=0.0D0
1471 c           alf12=0.0D0
1472             xj=c(1,nres+j)-xi
1473             yj=c(2,nres+j)-yi
1474             zj=c(3,nres+j)-zi
1475             dxj=dc_norm(1,nres+j)
1476             dyj=dc_norm(2,nres+j)
1477             dzj=dc_norm(3,nres+j)
1478             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1479 cd          if (icall.eq.0) then
1480 cd            rrsave(ind)=rrij
1481 cd          else
1482 cd            rrij=rrsave(ind)
1483 cd          endif
1484             rij=dsqrt(rrij)
1485 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1486             call sc_angular
1487 C Calculate whole angle-dependent part of epsilon and contributions
1488 C to its derivatives
1489             fac=(rrij*sigsq)**expon2
1490             e1=fac*fac*aa(itypi,itypj)
1491             e2=fac*bb(itypi,itypj)
1492             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1493             eps2der=evdwij*eps3rt
1494             eps3der=evdwij*eps2rt
1495             evdwij=evdwij*eps2rt*eps3rt
1496 #ifdef TSCSC
1497             if (bb(itypi,itypj).gt.0) then
1498                evdw_p=evdw_p+evdwij
1499             else
1500                evdw_m=evdw_m+evdwij
1501             endif
1502 #else
1503             evdw=evdw+evdwij
1504 #endif
1505             if (lprn) then
1506             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1507             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1508 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1509 cd     &        restyp(itypi),i,restyp(itypj),j,
1510 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1511 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1512 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1513 cd     &        evdwij
1514             endif
1515 C Calculate gradient components.
1516             e1=e1*eps1*eps2rt**2*eps3rt**2
1517             fac=-expon*(e1+evdwij)
1518             sigder=fac/sigsq
1519             fac=rrij*fac
1520 C Calculate radial part of the gradient
1521             gg(1)=xj*fac
1522             gg(2)=yj*fac
1523             gg(3)=zj*fac
1524 C Calculate the angular part of the gradient and sum add the contributions
1525 C to the appropriate components of the Cartesian gradient.
1526 #ifdef TSCSC
1527             if (bb(itypi,itypj).gt.0) then
1528                call sc_grad
1529             else
1530                call sc_grad_T
1531             endif
1532 #else
1533             call sc_grad
1534 #endif
1535           enddo      ! j
1536         enddo        ! iint
1537       enddo          ! i
1538 c     stop
1539       return
1540       end
1541 C-----------------------------------------------------------------------------
1542       subroutine egb(evdw,evdw_p,evdw_m)
1543 C
1544 C This subroutine calculates the interaction energy of nonbonded side chains
1545 C assuming the Gay-Berne potential of interaction.
1546 C
1547       implicit real*8 (a-h,o-z)
1548       include 'DIMENSIONS'
1549       include 'COMMON.GEO'
1550       include 'COMMON.VAR'
1551       include 'COMMON.LOCAL'
1552       include 'COMMON.CHAIN'
1553       include 'COMMON.DERIV'
1554       include 'COMMON.NAMES'
1555       include 'COMMON.INTERACT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.CALC'
1558       include 'COMMON.CONTROL'
1559       logical lprn
1560       evdw=0.0D0
1561 ccccc      energy_dec=.false.
1562 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1563       evdw=0.0D0
1564       evdw_p=0.0D0
1565       evdw_m=0.0D0
1566       lprn=.false.
1567 c     if (icall.eq.0) lprn=.false.
1568       ind=0
1569       do i=iatsc_s,iatsc_e
1570         itypi=iabs(itype(i))
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1581 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1582 C
1583 C Calculate SC interaction energy.
1584 C
1585         do iint=1,nint_gr(i)
1586           do j=istart(i,iint),iend(i,iint)
1587             ind=ind+1
1588             itypj=iabs(itype(j))
1589 c            dscj_inv=dsc_inv(itypj)
1590             dscj_inv=vbld_inv(j+nres)
1591 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1592 c     &       1.0d0/vbld(j+nres)
1593 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1594             sig0ij=sigma(itypi,itypj)
1595             chi1=chi(itypi,itypj)
1596             chi2=chi(itypj,itypi)
1597             chi12=chi1*chi2
1598             chip1=chip(itypi)
1599             chip2=chip(itypj)
1600             chip12=chip1*chip2
1601             alf1=alp(itypi)
1602             alf2=alp(itypj)
1603             alf12=0.5D0*(alf1+alf2)
1604 C For diagnostics only!!!
1605 c           chi1=0.0D0
1606 c           chi2=0.0D0
1607 c           chi12=0.0D0
1608 c           chip1=0.0D0
1609 c           chip2=0.0D0
1610 c           chip12=0.0D0
1611 c           alf1=0.0D0
1612 c           alf2=0.0D0
1613 c           alf12=0.0D0
1614             xj=c(1,nres+j)-xi
1615             yj=c(2,nres+j)-yi
1616             zj=c(3,nres+j)-zi
1617             dxj=dc_norm(1,nres+j)
1618             dyj=dc_norm(2,nres+j)
1619             dzj=dc_norm(3,nres+j)
1620 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1621 c            write (iout,*) "j",j," dc_norm",
1622 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1623             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1624             rij=dsqrt(rrij)
1625 C Calculate angle-dependent terms of energy and contributions to their
1626 C derivatives.
1627             call sc_angular
1628             sigsq=1.0D0/sigsq
1629             sig=sig0ij*dsqrt(sigsq)
1630             rij_shift=1.0D0/rij-sig+sig0ij
1631 c for diagnostics; uncomment
1632 c            rij_shift=1.2*sig0ij
1633 C I hate to put IF's in the loops, but here don't have another choice!!!!
1634             if (rij_shift.le.0.0D0) then
1635               evdw=1.0D20
1636 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1637 cd     &        restyp(itypi),i,restyp(itypj),j,
1638 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1639               return
1640             endif
1641             sigder=-sig*sigsq
1642 c---------------------------------------------------------------
1643             rij_shift=1.0D0/rij_shift
1644             fac=rij_shift**expon
1645             e1=fac*fac*aa(itypi,itypj)
1646             e2=fac*bb(itypi,itypj)
1647             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1648             eps2der=evdwij*eps3rt
1649             eps3der=evdwij*eps2rt
1650 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1651 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1652             evdwij=evdwij*eps2rt*eps3rt
1653 #ifdef TSCSC
1654             if (bb(itypi,itypj).gt.0) then
1655                evdw_p=evdw_p+evdwij
1656             else
1657                evdw_m=evdw_m+evdwij
1658             endif
1659 #else
1660             evdw=evdw+evdwij
1661 #endif
1662             if (lprn) then
1663             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1664             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1665             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1666      &        restyp(itypi),i,restyp(itypj),j,
1667      &        epsi,sigm,chi1,chi2,chip1,chip2,
1668      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1669      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1670      &        evdwij
1671             endif
1672
1673             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1674      &                        'evdw',i,j,evdwij
1675
1676 C Calculate gradient components.
1677             e1=e1*eps1*eps2rt**2*eps3rt**2
1678             fac=-expon*(e1+evdwij)*rij_shift
1679             sigder=fac*sigder
1680             fac=rij*fac
1681 c            fac=0.0d0
1682 C Calculate the radial part of the gradient
1683             gg(1)=xj*fac
1684             gg(2)=yj*fac
1685             gg(3)=zj*fac
1686 C Calculate angular part of the gradient.
1687 #ifdef TSCSC
1688             if (bb(itypi,itypj).gt.0) then
1689                call sc_grad
1690             else
1691                call sc_grad_T
1692             endif
1693 #else
1694             call sc_grad
1695 #endif
1696           enddo      ! j
1697         enddo        ! iint
1698       enddo          ! i
1699 c      write (iout,*) "Number of loop steps in EGB:",ind
1700 cccc      energy_dec=.false.
1701       return
1702       end
1703 C-----------------------------------------------------------------------------
1704       subroutine egbv(evdw,evdw_p,evdw_m)
1705 C
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne-Vorobjev potential of interaction.
1708 C
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.NAMES'
1717       include 'COMMON.INTERACT'
1718       include 'COMMON.IOUNITS'
1719       include 'COMMON.CALC'
1720       common /srutu/ icall
1721       logical lprn
1722       evdw=0.0D0
1723 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1724       evdw=0.0D0
1725       lprn=.false.
1726 c     if (icall.eq.0) lprn=.true.
1727       ind=0
1728       do i=iatsc_s,iatsc_e
1729         itypi=iabs(itype(i))
1730         itypi1=iabs(itype(i+1))
1731         xi=c(1,nres+i)
1732         yi=c(2,nres+i)
1733         zi=c(3,nres+i)
1734         dxi=dc_norm(1,nres+i)
1735         dyi=dc_norm(2,nres+i)
1736         dzi=dc_norm(3,nres+i)
1737 c        dsci_inv=dsc_inv(itypi)
1738         dsci_inv=vbld_inv(i+nres)
1739 C
1740 C Calculate SC interaction energy.
1741 C
1742         do iint=1,nint_gr(i)
1743           do j=istart(i,iint),iend(i,iint)
1744             ind=ind+1
1745             itypj=iabs(itype(j))
1746 c            dscj_inv=dsc_inv(itypj)
1747             dscj_inv=vbld_inv(j+nres)
1748             sig0ij=sigma(itypi,itypj)
1749             r0ij=r0(itypi,itypj)
1750             chi1=chi(itypi,itypj)
1751             chi2=chi(itypj,itypi)
1752             chi12=chi1*chi2
1753             chip1=chip(itypi)
1754             chip2=chip(itypj)
1755             chip12=chip1*chip2
1756             alf1=alp(itypi)
1757             alf2=alp(itypj)
1758             alf12=0.5D0*(alf1+alf2)
1759 C For diagnostics only!!!
1760 c           chi1=0.0D0
1761 c           chi2=0.0D0
1762 c           chi12=0.0D0
1763 c           chip1=0.0D0
1764 c           chip2=0.0D0
1765 c           chip12=0.0D0
1766 c           alf1=0.0D0
1767 c           alf2=0.0D0
1768 c           alf12=0.0D0
1769             xj=c(1,nres+j)-xi
1770             yj=c(2,nres+j)-yi
1771             zj=c(3,nres+j)-zi
1772             dxj=dc_norm(1,nres+j)
1773             dyj=dc_norm(2,nres+j)
1774             dzj=dc_norm(3,nres+j)
1775             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1776             rij=dsqrt(rrij)
1777 C Calculate angle-dependent terms of energy and contributions to their
1778 C derivatives.
1779             call sc_angular
1780             sigsq=1.0D0/sigsq
1781             sig=sig0ij*dsqrt(sigsq)
1782             rij_shift=1.0D0/rij-sig+r0ij
1783 C I hate to put IF's in the loops, but here don't have another choice!!!!
1784             if (rij_shift.le.0.0D0) then
1785               evdw=1.0D20
1786               return
1787             endif
1788             sigder=-sig*sigsq
1789 c---------------------------------------------------------------
1790             rij_shift=1.0D0/rij_shift
1791             fac=rij_shift**expon
1792             e1=fac*fac*aa(itypi,itypj)
1793             e2=fac*bb(itypi,itypj)
1794             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1795             eps2der=evdwij*eps3rt
1796             eps3der=evdwij*eps2rt
1797             fac_augm=rrij**expon
1798             e_augm=augm(itypi,itypj)*fac_augm
1799             evdwij=evdwij*eps2rt*eps3rt
1800 #ifdef TSCSC
1801             if (bb(itypi,itypj).gt.0) then
1802                evdw_p=evdw_p+evdwij+e_augm
1803             else
1804                evdw_m=evdw_m+evdwij+e_augm
1805             endif
1806 #else
1807             evdw=evdw+evdwij+e_augm
1808 #endif
1809             if (lprn) then
1810             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1811             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1812             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813      &        restyp(itypi),i,restyp(itypj),j,
1814      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1815      &        chi1,chi2,chip1,chip2,
1816      &        eps1,eps2rt**2,eps3rt**2,
1817      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1818      &        evdwij+e_augm
1819             endif
1820 C Calculate gradient components.
1821             e1=e1*eps1*eps2rt**2*eps3rt**2
1822             fac=-expon*(e1+evdwij)*rij_shift
1823             sigder=fac*sigder
1824             fac=rij*fac-2*expon*rrij*e_augm
1825 C Calculate the radial part of the gradient
1826             gg(1)=xj*fac
1827             gg(2)=yj*fac
1828             gg(3)=zj*fac
1829 C Calculate angular part of the gradient.
1830 #ifdef TSCSC
1831             if (bb(itypi,itypj).gt.0) then
1832                call sc_grad
1833             else
1834                call sc_grad_T
1835             endif
1836 #else
1837             call sc_grad
1838 #endif
1839           enddo      ! j
1840         enddo        ! iint
1841       enddo          ! i
1842       end
1843 C-----------------------------------------------------------------------------
1844       subroutine sc_angular
1845 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1846 C om12. Called by ebp, egb, and egbv.
1847       implicit none
1848       include 'COMMON.CALC'
1849       include 'COMMON.IOUNITS'
1850       erij(1)=xj*rij
1851       erij(2)=yj*rij
1852       erij(3)=zj*rij
1853       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1854       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1855       om12=dxi*dxj+dyi*dyj+dzi*dzj
1856       chiom12=chi12*om12
1857 C Calculate eps1(om12) and its derivative in om12
1858       faceps1=1.0D0-om12*chiom12
1859       faceps1_inv=1.0D0/faceps1
1860       eps1=dsqrt(faceps1_inv)
1861 C Following variable is eps1*deps1/dom12
1862       eps1_om12=faceps1_inv*chiom12
1863 c diagnostics only
1864 c      faceps1_inv=om12
1865 c      eps1=om12
1866 c      eps1_om12=1.0d0
1867 c      write (iout,*) "om12",om12," eps1",eps1
1868 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1869 C and om12.
1870       om1om2=om1*om2
1871       chiom1=chi1*om1
1872       chiom2=chi2*om2
1873       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1874       sigsq=1.0D0-facsig*faceps1_inv
1875       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1876       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1877       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1878 c diagnostics only
1879 c      sigsq=1.0d0
1880 c      sigsq_om1=0.0d0
1881 c      sigsq_om2=0.0d0
1882 c      sigsq_om12=0.0d0
1883 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1884 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1885 c     &    " eps1",eps1
1886 C Calculate eps2 and its derivatives in om1, om2, and om12.
1887       chipom1=chip1*om1
1888       chipom2=chip2*om2
1889       chipom12=chip12*om12
1890       facp=1.0D0-om12*chipom12
1891       facp_inv=1.0D0/facp
1892       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1893 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1894 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1895 C Following variable is the square root of eps2
1896       eps2rt=1.0D0-facp1*facp_inv
1897 C Following three variables are the derivatives of the square root of eps
1898 C in om1, om2, and om12.
1899       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1900       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1901       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1902 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1903       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1904 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1905 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1906 c     &  " eps2rt_om12",eps2rt_om12
1907 C Calculate whole angle-dependent part of epsilon and contributions
1908 C to its derivatives
1909       return
1910       end
1911
1912 C----------------------------------------------------------------------------
1913       subroutine sc_grad_T
1914       implicit real*8 (a-h,o-z)
1915       include 'DIMENSIONS'
1916       include 'COMMON.CHAIN'
1917       include 'COMMON.DERIV'
1918       include 'COMMON.CALC'
1919       include 'COMMON.IOUNITS'
1920       double precision dcosom1(3),dcosom2(3)
1921       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1922       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1923       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1924      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1925 c diagnostics only
1926 c      eom1=0.0d0
1927 c      eom2=0.0d0
1928 c      eom12=evdwij*eps1_om12
1929 c end diagnostics
1930 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1931 c     &  " sigder",sigder
1932 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1933 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1934       do k=1,3
1935         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1936         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1937       enddo
1938       do k=1,3
1939         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1940       enddo
1941 c      write (iout,*) "gg",(gg(k),k=1,3)
1942       do k=1,3
1943         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1944      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1945      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1946         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1947      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1948      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1949 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1950 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1951 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1952 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1953       enddo
1954 C
1955 C Calculate the components of the gradient in DC and X
1956 C
1957 cgrad      do k=i,j-1
1958 cgrad        do l=1,3
1959 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1960 cgrad        enddo
1961 cgrad      enddo
1962       do l=1,3
1963         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1964         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1965       enddo
1966       return
1967       end
1968
1969 C----------------------------------------------------------------------------
1970       subroutine sc_grad
1971       implicit real*8 (a-h,o-z)
1972       include 'DIMENSIONS'
1973       include 'COMMON.CHAIN'
1974       include 'COMMON.DERIV'
1975       include 'COMMON.CALC'
1976       include 'COMMON.IOUNITS'
1977       double precision dcosom1(3),dcosom2(3)
1978       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1979       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1980       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1981      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1982 c diagnostics only
1983 c      eom1=0.0d0
1984 c      eom2=0.0d0
1985 c      eom12=evdwij*eps1_om12
1986 c end diagnostics
1987 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1988 c     &  " sigder",sigder
1989 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1990 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1991       do k=1,3
1992         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1993         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1994       enddo
1995       do k=1,3
1996         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1997       enddo
1998 c      write (iout,*) "gg",(gg(k),k=1,3)
1999       do k=1,3
2000         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2001      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2002      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2003         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2004      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2005      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2006 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2007 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2008 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2009 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2010       enddo
2011 C
2012 C Calculate the components of the gradient in DC and X
2013 C
2014 cgrad      do k=i,j-1
2015 cgrad        do l=1,3
2016 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2017 cgrad        enddo
2018 cgrad      enddo
2019       do l=1,3
2020         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2021         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2022       enddo
2023       return
2024       end
2025 C-----------------------------------------------------------------------
2026       subroutine e_softsphere(evdw)
2027 C
2028 C This subroutine calculates the interaction energy of nonbonded side chains
2029 C assuming the LJ potential of interaction.
2030 C
2031       implicit real*8 (a-h,o-z)
2032       include 'DIMENSIONS'
2033       parameter (accur=1.0d-10)
2034       include 'COMMON.GEO'
2035       include 'COMMON.VAR'
2036       include 'COMMON.LOCAL'
2037       include 'COMMON.CHAIN'
2038       include 'COMMON.DERIV'
2039       include 'COMMON.INTERACT'
2040       include 'COMMON.TORSION'
2041       include 'COMMON.SBRIDGE'
2042       include 'COMMON.NAMES'
2043       include 'COMMON.IOUNITS'
2044       include 'COMMON.CONTACTS'
2045       dimension gg(3)
2046 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2047       evdw=0.0D0
2048       do i=iatsc_s,iatsc_e
2049         itypi=iabs(itype(i))
2050         itypi1=iabs(itype(i+1))
2051         xi=c(1,nres+i)
2052         yi=c(2,nres+i)
2053         zi=c(3,nres+i)
2054 C
2055 C Calculate SC interaction energy.
2056 C
2057         do iint=1,nint_gr(i)
2058 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2059 cd   &                  'iend=',iend(i,iint)
2060           do j=istart(i,iint),iend(i,iint)
2061             itypj=iabs(itype(j))
2062             xj=c(1,nres+j)-xi
2063             yj=c(2,nres+j)-yi
2064             zj=c(3,nres+j)-zi
2065             rij=xj*xj+yj*yj+zj*zj
2066 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2067             r0ij=r0(itypi,itypj)
2068             r0ijsq=r0ij*r0ij
2069 c            print *,i,j,r0ij,dsqrt(rij)
2070             if (rij.lt.r0ijsq) then
2071               evdwij=0.25d0*(rij-r0ijsq)**2
2072               fac=rij-r0ijsq
2073             else
2074               evdwij=0.0d0
2075               fac=0.0d0
2076             endif
2077             evdw=evdw+evdwij
2078 C
2079 C Calculate the components of the gradient in DC and X
2080 C
2081             gg(1)=xj*fac
2082             gg(2)=yj*fac
2083             gg(3)=zj*fac
2084             do k=1,3
2085               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2086               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2087               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2088               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2089             enddo
2090 cgrad            do k=i,j-1
2091 cgrad              do l=1,3
2092 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2093 cgrad              enddo
2094 cgrad            enddo
2095           enddo ! j
2096         enddo ! iint
2097       enddo ! i
2098       return
2099       end
2100 C--------------------------------------------------------------------------
2101       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2102      &              eello_turn4)
2103 C
2104 C Soft-sphere potential of p-p interaction
2105 C
2106       implicit real*8 (a-h,o-z)
2107       include 'DIMENSIONS'
2108       include 'COMMON.CONTROL'
2109       include 'COMMON.IOUNITS'
2110       include 'COMMON.GEO'
2111       include 'COMMON.VAR'
2112       include 'COMMON.LOCAL'
2113       include 'COMMON.CHAIN'
2114       include 'COMMON.DERIV'
2115       include 'COMMON.INTERACT'
2116       include 'COMMON.CONTACTS'
2117       include 'COMMON.TORSION'
2118       include 'COMMON.VECTORS'
2119       include 'COMMON.FFIELD'
2120       dimension ggg(3)
2121 cd      write(iout,*) 'In EELEC_soft_sphere'
2122       ees=0.0D0
2123       evdw1=0.0D0
2124       eel_loc=0.0d0
2125       eello_turn3=0.0d0
2126       eello_turn4=0.0d0
2127       ind=0
2128       do i=iatel_s,iatel_e
2129         dxi=dc(1,i)
2130         dyi=dc(2,i)
2131         dzi=dc(3,i)
2132         xmedi=c(1,i)+0.5d0*dxi
2133         ymedi=c(2,i)+0.5d0*dyi
2134         zmedi=c(3,i)+0.5d0*dzi
2135         num_conti=0
2136 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2137         do j=ielstart(i),ielend(i)
2138           ind=ind+1
2139           iteli=itel(i)
2140           itelj=itel(j)
2141           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2142           r0ij=rpp(iteli,itelj)
2143           r0ijsq=r0ij*r0ij
2144           dxj=dc(1,j)
2145           dyj=dc(2,j)
2146           dzj=dc(3,j)
2147           xj=c(1,j)+0.5D0*dxj-xmedi
2148           yj=c(2,j)+0.5D0*dyj-ymedi
2149           zj=c(3,j)+0.5D0*dzj-zmedi
2150           rij=xj*xj+yj*yj+zj*zj
2151           if (rij.lt.r0ijsq) then
2152             evdw1ij=0.25d0*(rij-r0ijsq)**2
2153             fac=rij-r0ijsq
2154           else
2155             evdw1ij=0.0d0
2156             fac=0.0d0
2157           endif
2158           evdw1=evdw1+evdw1ij
2159 C
2160 C Calculate contributions to the Cartesian gradient.
2161 C
2162           ggg(1)=fac*xj
2163           ggg(2)=fac*yj
2164           ggg(3)=fac*zj
2165           do k=1,3
2166             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2167             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2168           enddo
2169 *
2170 * Loop over residues i+1 thru j-1.
2171 *
2172 cgrad          do k=i+1,j-1
2173 cgrad            do l=1,3
2174 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2175 cgrad            enddo
2176 cgrad          enddo
2177         enddo ! j
2178       enddo   ! i
2179 cgrad      do i=nnt,nct-1
2180 cgrad        do k=1,3
2181 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2182 cgrad        enddo
2183 cgrad        do j=i+1,nct-1
2184 cgrad          do k=1,3
2185 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2186 cgrad          enddo
2187 cgrad        enddo
2188 cgrad      enddo
2189       return
2190       end
2191 c------------------------------------------------------------------------------
2192       subroutine vec_and_deriv
2193       implicit real*8 (a-h,o-z)
2194       include 'DIMENSIONS'
2195 #ifdef MPI
2196       include 'mpif.h'
2197 #endif
2198       include 'COMMON.IOUNITS'
2199       include 'COMMON.GEO'
2200       include 'COMMON.VAR'
2201       include 'COMMON.LOCAL'
2202       include 'COMMON.CHAIN'
2203       include 'COMMON.VECTORS'
2204       include 'COMMON.SETUP'
2205       include 'COMMON.TIME1'
2206       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2207 C Compute the local reference systems. For reference system (i), the
2208 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2209 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2210 #ifdef PARVEC
2211       do i=ivec_start,ivec_end
2212 #else
2213       do i=1,nres-1
2214 #endif
2215           if (i.eq.nres-1) then
2216 C Case of the last full residue
2217 C Compute the Z-axis
2218             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2219             costh=dcos(pi-theta(nres))
2220             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2221             do k=1,3
2222               uz(k,i)=fac*uz(k,i)
2223             enddo
2224 C Compute the derivatives of uz
2225             uzder(1,1,1)= 0.0d0
2226             uzder(2,1,1)=-dc_norm(3,i-1)
2227             uzder(3,1,1)= dc_norm(2,i-1)
2228             uzder(1,2,1)= dc_norm(3,i-1)
2229             uzder(2,2,1)= 0.0d0
2230             uzder(3,2,1)=-dc_norm(1,i-1)
2231             uzder(1,3,1)=-dc_norm(2,i-1)
2232             uzder(2,3,1)= dc_norm(1,i-1)
2233             uzder(3,3,1)= 0.0d0
2234             uzder(1,1,2)= 0.0d0
2235             uzder(2,1,2)= dc_norm(3,i)
2236             uzder(3,1,2)=-dc_norm(2,i)
2237             uzder(1,2,2)=-dc_norm(3,i)
2238             uzder(2,2,2)= 0.0d0
2239             uzder(3,2,2)= dc_norm(1,i)
2240             uzder(1,3,2)= dc_norm(2,i)
2241             uzder(2,3,2)=-dc_norm(1,i)
2242             uzder(3,3,2)= 0.0d0
2243 C Compute the Y-axis
2244             facy=fac
2245             do k=1,3
2246               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2247             enddo
2248 C Compute the derivatives of uy
2249             do j=1,3
2250               do k=1,3
2251                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2252      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2253                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2254               enddo
2255               uyder(j,j,1)=uyder(j,j,1)-costh
2256               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2257             enddo
2258             do j=1,2
2259               do k=1,3
2260                 do l=1,3
2261                   uygrad(l,k,j,i)=uyder(l,k,j)
2262                   uzgrad(l,k,j,i)=uzder(l,k,j)
2263                 enddo
2264               enddo
2265             enddo
2266             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2267             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2268             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2269             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2270           else
2271 C Other residues
2272 C Compute the Z-axis
2273             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2274             costh=dcos(pi-theta(i+2))
2275             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2276             do k=1,3
2277               uz(k,i)=fac*uz(k,i)
2278             enddo
2279 C Compute the derivatives of uz
2280             uzder(1,1,1)= 0.0d0
2281             uzder(2,1,1)=-dc_norm(3,i+1)
2282             uzder(3,1,1)= dc_norm(2,i+1)
2283             uzder(1,2,1)= dc_norm(3,i+1)
2284             uzder(2,2,1)= 0.0d0
2285             uzder(3,2,1)=-dc_norm(1,i+1)
2286             uzder(1,3,1)=-dc_norm(2,i+1)
2287             uzder(2,3,1)= dc_norm(1,i+1)
2288             uzder(3,3,1)= 0.0d0
2289             uzder(1,1,2)= 0.0d0
2290             uzder(2,1,2)= dc_norm(3,i)
2291             uzder(3,1,2)=-dc_norm(2,i)
2292             uzder(1,2,2)=-dc_norm(3,i)
2293             uzder(2,2,2)= 0.0d0
2294             uzder(3,2,2)= dc_norm(1,i)
2295             uzder(1,3,2)= dc_norm(2,i)
2296             uzder(2,3,2)=-dc_norm(1,i)
2297             uzder(3,3,2)= 0.0d0
2298 C Compute the Y-axis
2299             facy=fac
2300             do k=1,3
2301               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2302             enddo
2303 C Compute the derivatives of uy
2304             do j=1,3
2305               do k=1,3
2306                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2307      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2308                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2309               enddo
2310               uyder(j,j,1)=uyder(j,j,1)-costh
2311               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2312             enddo
2313             do j=1,2
2314               do k=1,3
2315                 do l=1,3
2316                   uygrad(l,k,j,i)=uyder(l,k,j)
2317                   uzgrad(l,k,j,i)=uzder(l,k,j)
2318                 enddo
2319               enddo
2320             enddo
2321             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2322             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2323             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2324             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2325           endif
2326       enddo
2327       do i=1,nres-1
2328         vbld_inv_temp(1)=vbld_inv(i+1)
2329         if (i.lt.nres-1) then
2330           vbld_inv_temp(2)=vbld_inv(i+2)
2331           else
2332           vbld_inv_temp(2)=vbld_inv(i)
2333           endif
2334         do j=1,2
2335           do k=1,3
2336             do l=1,3
2337               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2338               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2339             enddo
2340           enddo
2341         enddo
2342       enddo
2343 #if defined(PARVEC) && defined(MPI)
2344       if (nfgtasks1.gt.1) then
2345         time00=MPI_Wtime()
2346 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2347 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2348 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2349         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2350      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2351      &   FG_COMM1,IERR)
2352         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2353      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2354      &   FG_COMM1,IERR)
2355         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2356      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2357      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2358         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2359      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2360      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2361         time_gather=time_gather+MPI_Wtime()-time00
2362       endif
2363 c      if (fg_rank.eq.0) then
2364 c        write (iout,*) "Arrays UY and UZ"
2365 c        do i=1,nres-1
2366 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2367 c     &     (uz(k,i),k=1,3)
2368 c        enddo
2369 c      endif
2370 #endif
2371       return
2372       end
2373 C-----------------------------------------------------------------------------
2374       subroutine check_vecgrad
2375       implicit real*8 (a-h,o-z)
2376       include 'DIMENSIONS'
2377       include 'COMMON.IOUNITS'
2378       include 'COMMON.GEO'
2379       include 'COMMON.VAR'
2380       include 'COMMON.LOCAL'
2381       include 'COMMON.CHAIN'
2382       include 'COMMON.VECTORS'
2383       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2384       dimension uyt(3,maxres),uzt(3,maxres)
2385       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2386       double precision delta /1.0d-7/
2387       call vec_and_deriv
2388 cd      do i=1,nres
2389 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2390 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2391 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2392 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2393 cd     &     (dc_norm(if90,i),if90=1,3)
2394 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2395 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2396 cd          write(iout,'(a)')
2397 cd      enddo
2398       do i=1,nres
2399         do j=1,2
2400           do k=1,3
2401             do l=1,3
2402               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2403               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2404             enddo
2405           enddo
2406         enddo
2407       enddo
2408       call vec_and_deriv
2409       do i=1,nres
2410         do j=1,3
2411           uyt(j,i)=uy(j,i)
2412           uzt(j,i)=uz(j,i)
2413         enddo
2414       enddo
2415       do i=1,nres
2416 cd        write (iout,*) 'i=',i
2417         do k=1,3
2418           erij(k)=dc_norm(k,i)
2419         enddo
2420         do j=1,3
2421           do k=1,3
2422             dc_norm(k,i)=erij(k)
2423           enddo
2424           dc_norm(j,i)=dc_norm(j,i)+delta
2425 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2426 c          do k=1,3
2427 c            dc_norm(k,i)=dc_norm(k,i)/fac
2428 c          enddo
2429 c          write (iout,*) (dc_norm(k,i),k=1,3)
2430 c          write (iout,*) (erij(k),k=1,3)
2431           call vec_and_deriv
2432           do k=1,3
2433             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2434             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2435             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2436             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2437           enddo
2438 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2439 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2440 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2441         enddo
2442         do k=1,3
2443           dc_norm(k,i)=erij(k)
2444         enddo
2445 cd        do k=1,3
2446 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2447 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2448 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2449 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2451 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2452 cd          write (iout,'(a)')
2453 cd        enddo
2454       enddo
2455       return
2456       end
2457 C--------------------------------------------------------------------------
2458       subroutine set_matrices
2459       implicit real*8 (a-h,o-z)
2460       include 'DIMENSIONS'
2461 #ifdef MPI
2462       include "mpif.h"
2463       include "COMMON.SETUP"
2464       integer IERR
2465       integer status(MPI_STATUS_SIZE)
2466 #endif
2467       include 'COMMON.IOUNITS'
2468       include 'COMMON.GEO'
2469       include 'COMMON.VAR'
2470       include 'COMMON.LOCAL'
2471       include 'COMMON.CHAIN'
2472       include 'COMMON.DERIV'
2473       include 'COMMON.INTERACT'
2474       include 'COMMON.CONTACTS'
2475       include 'COMMON.TORSION'
2476       include 'COMMON.VECTORS'
2477       include 'COMMON.FFIELD'
2478       double precision auxvec(2),auxmat(2,2)
2479 C
2480 C Compute the virtual-bond-torsional-angle dependent quantities needed
2481 C to calculate the el-loc multibody terms of various order.
2482 C
2483 #ifdef PARMAT
2484       do i=ivec_start+2,ivec_end+2
2485 #else
2486       do i=3,nres+1
2487 #endif
2488         if (i .lt. nres+1) then
2489           sin1=dsin(phi(i))
2490           cos1=dcos(phi(i))
2491           sintab(i-2)=sin1
2492           costab(i-2)=cos1
2493           obrot(1,i-2)=cos1
2494           obrot(2,i-2)=sin1
2495           sin2=dsin(2*phi(i))
2496           cos2=dcos(2*phi(i))
2497           sintab2(i-2)=sin2
2498           costab2(i-2)=cos2
2499           obrot2(1,i-2)=cos2
2500           obrot2(2,i-2)=sin2
2501           Ug(1,1,i-2)=-cos1
2502           Ug(1,2,i-2)=-sin1
2503           Ug(2,1,i-2)=-sin1
2504           Ug(2,2,i-2)= cos1
2505           Ug2(1,1,i-2)=-cos2
2506           Ug2(1,2,i-2)=-sin2
2507           Ug2(2,1,i-2)=-sin2
2508           Ug2(2,2,i-2)= cos2
2509         else
2510           costab(i-2)=1.0d0
2511           sintab(i-2)=0.0d0
2512           obrot(1,i-2)=1.0d0
2513           obrot(2,i-2)=0.0d0
2514           obrot2(1,i-2)=0.0d0
2515           obrot2(2,i-2)=0.0d0
2516           Ug(1,1,i-2)=1.0d0
2517           Ug(1,2,i-2)=0.0d0
2518           Ug(2,1,i-2)=0.0d0
2519           Ug(2,2,i-2)=1.0d0
2520           Ug2(1,1,i-2)=0.0d0
2521           Ug2(1,2,i-2)=0.0d0
2522           Ug2(2,1,i-2)=0.0d0
2523           Ug2(2,2,i-2)=0.0d0
2524         endif
2525         if (i .gt. 3 .and. i .lt. nres+1) then
2526           obrot_der(1,i-2)=-sin1
2527           obrot_der(2,i-2)= cos1
2528           Ugder(1,1,i-2)= sin1
2529           Ugder(1,2,i-2)=-cos1
2530           Ugder(2,1,i-2)=-cos1
2531           Ugder(2,2,i-2)=-sin1
2532           dwacos2=cos2+cos2
2533           dwasin2=sin2+sin2
2534           obrot2_der(1,i-2)=-dwasin2
2535           obrot2_der(2,i-2)= dwacos2
2536           Ug2der(1,1,i-2)= dwasin2
2537           Ug2der(1,2,i-2)=-dwacos2
2538           Ug2der(2,1,i-2)=-dwacos2
2539           Ug2der(2,2,i-2)=-dwasin2
2540         else
2541           obrot_der(1,i-2)=0.0d0
2542           obrot_der(2,i-2)=0.0d0
2543           Ugder(1,1,i-2)=0.0d0
2544           Ugder(1,2,i-2)=0.0d0
2545           Ugder(2,1,i-2)=0.0d0
2546           Ugder(2,2,i-2)=0.0d0
2547           obrot2_der(1,i-2)=0.0d0
2548           obrot2_der(2,i-2)=0.0d0
2549           Ug2der(1,1,i-2)=0.0d0
2550           Ug2der(1,2,i-2)=0.0d0
2551           Ug2der(2,1,i-2)=0.0d0
2552           Ug2der(2,2,i-2)=0.0d0
2553         endif
2554 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2555         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2556           iti = itortyp(itype(i-2))
2557         else
2558           iti=ntortyp+1
2559         endif
2560 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2561         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2562           iti1 = itortyp(itype(i-1))
2563         else
2564           iti1=ntortyp+1
2565         endif
2566 cd        write (iout,*) '*******i',i,' iti1',iti
2567 cd        write (iout,*) 'b1',b1(:,iti)
2568 cd        write (iout,*) 'b2',b2(:,iti)
2569 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2570 c        if (i .gt. iatel_s+2) then
2571         if (i .gt. nnt+2) then
2572           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2573           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2574           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2575      &    then
2576           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2577           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2578           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2579           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2580           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2581           endif
2582         else
2583           do k=1,2
2584             Ub2(k,i-2)=0.0d0
2585             Ctobr(k,i-2)=0.0d0
2586             Dtobr2(k,i-2)=0.0d0
2587             do l=1,2
2588               EUg(l,k,i-2)=0.0d0
2589               CUg(l,k,i-2)=0.0d0
2590               DUg(l,k,i-2)=0.0d0
2591               DtUg2(l,k,i-2)=0.0d0
2592             enddo
2593           enddo
2594         endif
2595         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2596         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2597         do k=1,2
2598           muder(k,i-2)=Ub2der(k,i-2)
2599         enddo
2600 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2601         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2602           iti1 = itortyp(itype(i-1))
2603         else
2604           iti1=ntortyp+1
2605         endif
2606         do k=1,2
2607           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2608         enddo
2609 cd        write (iout,*) 'mu ',mu(:,i-2)
2610 cd        write (iout,*) 'mu1',mu1(:,i-2)
2611 cd        write (iout,*) 'mu2',mu2(:,i-2)
2612         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2613      &  then
2614         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2615         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2616         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2617         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2618         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2619 C Vectors and matrices dependent on a single virtual-bond dihedral.
2620         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2621         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2622         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2623         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2624         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2625         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2626         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2627         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2628         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2629         endif
2630       enddo
2631 C Matrices dependent on two consecutive virtual-bond dihedrals.
2632 C The order of matrices is from left to right.
2633       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2634      &then
2635 c      do i=max0(ivec_start,2),ivec_end
2636       do i=2,nres-1
2637         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2638         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2639         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2640         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2641         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2642         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2643         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2644         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2645       enddo
2646       endif
2647 #if defined(MPI) && defined(PARMAT)
2648 #ifdef DEBUG
2649 c      if (fg_rank.eq.0) then
2650         write (iout,*) "Arrays UG and UGDER before GATHER"
2651         do i=1,nres-1
2652           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2653      &     ((ug(l,k,i),l=1,2),k=1,2),
2654      &     ((ugder(l,k,i),l=1,2),k=1,2)
2655         enddo
2656         write (iout,*) "Arrays UG2 and UG2DER"
2657         do i=1,nres-1
2658           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2659      &     ((ug2(l,k,i),l=1,2),k=1,2),
2660      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2661         enddo
2662         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2663         do i=1,nres-1
2664           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2665      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2666      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2667         enddo
2668         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2669         do i=1,nres-1
2670           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2671      &     costab(i),sintab(i),costab2(i),sintab2(i)
2672         enddo
2673         write (iout,*) "Array MUDER"
2674         do i=1,nres-1
2675           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2676         enddo
2677 c      endif
2678 #endif
2679       if (nfgtasks.gt.1) then
2680         time00=MPI_Wtime()
2681 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2682 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2683 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2684 #ifdef MATGATHER
2685         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2689      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2690      &   FG_COMM1,IERR)
2691         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2692      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2693      &   FG_COMM1,IERR)
2694         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2704      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2705      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2706         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2707      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2708      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2709         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2710      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2711      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2712         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2713      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2714      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2715         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2716      &  then
2717         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2718      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2719      &   FG_COMM1,IERR)
2720         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2721      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2722      &   FG_COMM1,IERR)
2723         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2724      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2725      &   FG_COMM1,IERR)
2726        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2733      &   ivec_count(fg_rank1),
2734      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2758      &   ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2769      &   FG_COMM1,IERR)
2770        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2774      &   ivec_count(fg_rank1),
2775      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2778      &   ivec_count(fg_rank1),
2779      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2782      &   ivec_count(fg_rank1),
2783      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2784      &   MPI_MAT2,FG_COMM1,IERR)
2785         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2786      &   ivec_count(fg_rank1),
2787      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2788      &   MPI_MAT2,FG_COMM1,IERR)
2789         endif
2790 #else
2791 c Passes matrix info through the ring
2792       isend=fg_rank1
2793       irecv=fg_rank1-1
2794       if (irecv.lt.0) irecv=nfgtasks1-1
2795       iprev=irecv
2796       inext=fg_rank1+1
2797       if (inext.ge.nfgtasks1) inext=0
2798       do i=1,nfgtasks1-1
2799 c        write (iout,*) "isend",isend," irecv",irecv
2800 c        call flush(iout)
2801         lensend=lentyp(isend)
2802         lenrecv=lentyp(irecv)
2803 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2804 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2805 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2806 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2807 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2808 c        write (iout,*) "Gather ROTAT1"
2809 c        call flush(iout)
2810 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2811 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2812 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2813 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather ROTAT2"
2815 c        call flush(iout)
2816         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2817      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2818      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2819      &   iprev,4400+irecv,FG_COMM,status,IERR)
2820 c        write (iout,*) "Gather ROTAT_OLD"
2821 c        call flush(iout)
2822         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2823      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2824      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2825      &   iprev,5500+irecv,FG_COMM,status,IERR)
2826 c        write (iout,*) "Gather PRECOMP11"
2827 c        call flush(iout)
2828         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2829      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2830      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2831      &   iprev,6600+irecv,FG_COMM,status,IERR)
2832 c        write (iout,*) "Gather PRECOMP12"
2833 c        call flush(iout)
2834         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2835      &  then
2836         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2837      &   MPI_ROTAT2(lensend),inext,7700+isend,
2838      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2839      &   iprev,7700+irecv,FG_COMM,status,IERR)
2840 c        write (iout,*) "Gather PRECOMP21"
2841 c        call flush(iout)
2842         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2843      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2844      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2845      &   iprev,8800+irecv,FG_COMM,status,IERR)
2846 c        write (iout,*) "Gather PRECOMP22"
2847 c        call flush(iout)
2848         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2849      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2850      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2851      &   MPI_PRECOMP23(lenrecv),
2852      &   iprev,9900+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather PRECOMP23"
2854 c        call flush(iout)
2855         endif
2856         isend=irecv
2857         irecv=irecv-1
2858         if (irecv.lt.0) irecv=nfgtasks1-1
2859       enddo
2860 #endif
2861         time_gather=time_gather+MPI_Wtime()-time00
2862       endif
2863 #ifdef DEBUG
2864 c      if (fg_rank.eq.0) then
2865         write (iout,*) "Arrays UG and UGDER"
2866         do i=1,nres-1
2867           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2868      &     ((ug(l,k,i),l=1,2),k=1,2),
2869      &     ((ugder(l,k,i),l=1,2),k=1,2)
2870         enddo
2871         write (iout,*) "Arrays UG2 and UG2DER"
2872         do i=1,nres-1
2873           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2874      &     ((ug2(l,k,i),l=1,2),k=1,2),
2875      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2876         enddo
2877         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2878         do i=1,nres-1
2879           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2880      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2881      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2882         enddo
2883         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2884         do i=1,nres-1
2885           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2886      &     costab(i),sintab(i),costab2(i),sintab2(i)
2887         enddo
2888         write (iout,*) "Array MUDER"
2889         do i=1,nres-1
2890           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2891         enddo
2892 c      endif
2893 #endif
2894 #endif
2895 cd      do i=1,nres
2896 cd        iti = itortyp(itype(i))
2897 cd        write (iout,*) i
2898 cd        do j=1,2
2899 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2900 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2901 cd        enddo
2902 cd      enddo
2903       return
2904       end
2905 C--------------------------------------------------------------------------
2906       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2907 C
2908 C This subroutine calculates the average interaction energy and its gradient
2909 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2910 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2911 C The potential depends both on the distance of peptide-group centers and on
2912 C the orientation of the CA-CA virtual bonds.
2913 C
2914       implicit real*8 (a-h,o-z)
2915 #ifdef MPI
2916       include 'mpif.h'
2917 #endif
2918       include 'DIMENSIONS'
2919       include 'COMMON.CONTROL'
2920       include 'COMMON.SETUP'
2921       include 'COMMON.IOUNITS'
2922       include 'COMMON.GEO'
2923       include 'COMMON.VAR'
2924       include 'COMMON.LOCAL'
2925       include 'COMMON.CHAIN'
2926       include 'COMMON.DERIV'
2927       include 'COMMON.INTERACT'
2928       include 'COMMON.CONTACTS'
2929       include 'COMMON.TORSION'
2930       include 'COMMON.VECTORS'
2931       include 'COMMON.FFIELD'
2932       include 'COMMON.TIME1'
2933       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2934      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2935       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2936      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2937       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2938      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2939      &    num_conti,j1,j2
2940 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2941 #ifdef MOMENT
2942       double precision scal_el /1.0d0/
2943 #else
2944       double precision scal_el /0.5d0/
2945 #endif
2946 C 12/13/98
2947 C 13-go grudnia roku pamietnego...
2948       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2949      &                   0.0d0,1.0d0,0.0d0,
2950      &                   0.0d0,0.0d0,1.0d0/
2951 cd      write(iout,*) 'In EELEC'
2952 cd      do i=1,nloctyp
2953 cd        write(iout,*) 'Type',i
2954 cd        write(iout,*) 'B1',B1(:,i)
2955 cd        write(iout,*) 'B2',B2(:,i)
2956 cd        write(iout,*) 'CC',CC(:,:,i)
2957 cd        write(iout,*) 'DD',DD(:,:,i)
2958 cd        write(iout,*) 'EE',EE(:,:,i)
2959 cd      enddo
2960 cd      call check_vecgrad
2961 cd      stop
2962       if (icheckgrad.eq.1) then
2963         do i=1,nres-1
2964           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2965           do k=1,3
2966             dc_norm(k,i)=dc(k,i)*fac
2967           enddo
2968 c          write (iout,*) 'i',i,' fac',fac
2969         enddo
2970       endif
2971       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2972      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2973      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2974 c        call vec_and_deriv
2975 #ifdef TIMING
2976         time01=MPI_Wtime()
2977 #endif
2978         call set_matrices
2979 #ifdef TIMING
2980         time_mat=time_mat+MPI_Wtime()-time01
2981 #endif
2982       endif
2983 cd      do i=1,nres-1
2984 cd        write (iout,*) 'i=',i
2985 cd        do k=1,3
2986 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2987 cd        enddo
2988 cd        do k=1,3
2989 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2990 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2991 cd        enddo
2992 cd      enddo
2993       t_eelecij=0.0d0
2994       ees=0.0D0
2995       evdw1=0.0D0
2996       eel_loc=0.0d0
2997       eello_turn3=0.0d0
2998       eello_turn4=0.0d0
2999       ind=0
3000       do i=1,nres
3001         num_cont_hb(i)=0
3002       enddo
3003 cd      print '(a)','Enter EELEC'
3004 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3005       do i=1,nres
3006         gel_loc_loc(i)=0.0d0
3007         gcorr_loc(i)=0.0d0
3008       enddo
3009 c
3010 c
3011 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3012 C
3013 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3014 C
3015       do i=iturn3_start,iturn3_end
3016         dxi=dc(1,i)
3017         dyi=dc(2,i)
3018         dzi=dc(3,i)
3019         dx_normi=dc_norm(1,i)
3020         dy_normi=dc_norm(2,i)
3021         dz_normi=dc_norm(3,i)
3022         xmedi=c(1,i)+0.5d0*dxi
3023         ymedi=c(2,i)+0.5d0*dyi
3024         zmedi=c(3,i)+0.5d0*dzi
3025         num_conti=0
3026         call eelecij(i,i+2,ees,evdw1,eel_loc)
3027         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3028         num_cont_hb(i)=num_conti
3029       enddo
3030       do i=iturn4_start,iturn4_end
3031         dxi=dc(1,i)
3032         dyi=dc(2,i)
3033         dzi=dc(3,i)
3034         dx_normi=dc_norm(1,i)
3035         dy_normi=dc_norm(2,i)
3036         dz_normi=dc_norm(3,i)
3037         xmedi=c(1,i)+0.5d0*dxi
3038         ymedi=c(2,i)+0.5d0*dyi
3039         zmedi=c(3,i)+0.5d0*dzi
3040         num_conti=num_cont_hb(i)
3041         call eelecij(i,i+3,ees,evdw1,eel_loc)
3042         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3043         num_cont_hb(i)=num_conti
3044       enddo   ! i
3045 c
3046 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3047 c
3048       do i=iatel_s,iatel_e
3049         dxi=dc(1,i)
3050         dyi=dc(2,i)
3051         dzi=dc(3,i)
3052         dx_normi=dc_norm(1,i)
3053         dy_normi=dc_norm(2,i)
3054         dz_normi=dc_norm(3,i)
3055         xmedi=c(1,i)+0.5d0*dxi
3056         ymedi=c(2,i)+0.5d0*dyi
3057         zmedi=c(3,i)+0.5d0*dzi
3058 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3059         num_conti=num_cont_hb(i)
3060         do j=ielstart(i),ielend(i)
3061           call eelecij(i,j,ees,evdw1,eel_loc)
3062         enddo ! j
3063         num_cont_hb(i)=num_conti
3064       enddo   ! i
3065 c      write (iout,*) "Number of loop steps in EELEC:",ind
3066 cd      do i=1,nres
3067 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3068 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3069 cd      enddo
3070 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3071 ccc      eel_loc=eel_loc+eello_turn3
3072 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3073       return
3074       end
3075 C-------------------------------------------------------------------------------
3076       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3077       implicit real*8 (a-h,o-z)
3078       include 'DIMENSIONS'
3079 #ifdef MPI
3080       include "mpif.h"
3081 #endif
3082       include 'COMMON.CONTROL'
3083       include 'COMMON.IOUNITS'
3084       include 'COMMON.GEO'
3085       include 'COMMON.VAR'
3086       include 'COMMON.LOCAL'
3087       include 'COMMON.CHAIN'
3088       include 'COMMON.DERIV'
3089       include 'COMMON.INTERACT'
3090       include 'COMMON.CONTACTS'
3091       include 'COMMON.TORSION'
3092       include 'COMMON.VECTORS'
3093       include 'COMMON.FFIELD'
3094       include 'COMMON.TIME1'
3095       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3096      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3097       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3098      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3099       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3100      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3101      &    num_conti,j1,j2
3102 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3103 #ifdef MOMENT
3104       double precision scal_el /1.0d0/
3105 #else
3106       double precision scal_el /0.5d0/
3107 #endif
3108 C 12/13/98
3109 C 13-go grudnia roku pamietnego...
3110       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3111      &                   0.0d0,1.0d0,0.0d0,
3112      &                   0.0d0,0.0d0,1.0d0/
3113 c          time00=MPI_Wtime()
3114 cd      write (iout,*) "eelecij",i,j
3115 c          ind=ind+1
3116           iteli=itel(i)
3117           itelj=itel(j)
3118           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3119           aaa=app(iteli,itelj)
3120           bbb=bpp(iteli,itelj)
3121           ael6i=ael6(iteli,itelj)
3122           ael3i=ael3(iteli,itelj)
3123           dxj=dc(1,j)
3124           dyj=dc(2,j)
3125           dzj=dc(3,j)
3126           dx_normj=dc_norm(1,j)
3127           dy_normj=dc_norm(2,j)
3128           dz_normj=dc_norm(3,j)
3129           xj=c(1,j)+0.5D0*dxj-xmedi
3130           yj=c(2,j)+0.5D0*dyj-ymedi
3131           zj=c(3,j)+0.5D0*dzj-zmedi
3132           rij=xj*xj+yj*yj+zj*zj
3133           rrmij=1.0D0/rij
3134           rij=dsqrt(rij)
3135           rmij=1.0D0/rij
3136           r3ij=rrmij*rmij
3137           r6ij=r3ij*r3ij
3138           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3139           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3140           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3141           fac=cosa-3.0D0*cosb*cosg
3142           ev1=aaa*r6ij*r6ij
3143 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3144           if (j.eq.i+2) ev1=scal_el*ev1
3145           ev2=bbb*r6ij
3146           fac3=ael6i*r6ij
3147           fac4=ael3i*r3ij
3148           evdwij=ev1+ev2
3149           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3150           el2=fac4*fac
3151           eesij=el1+el2
3152 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3153           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3154           ees=ees+eesij
3155           evdw1=evdw1+evdwij
3156 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3157 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3158 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3159 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3160
3161           if (energy_dec) then
3162               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3163               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3164           endif
3165
3166 C
3167 C Calculate contributions to the Cartesian gradient.
3168 C
3169 #ifdef SPLITELE
3170           facvdw=-6*rrmij*(ev1+evdwij)
3171           facel=-3*rrmij*(el1+eesij)
3172           fac1=fac
3173           erij(1)=xj*rmij
3174           erij(2)=yj*rmij
3175           erij(3)=zj*rmij
3176 *
3177 * Radial derivatives. First process both termini of the fragment (i,j)
3178 *
3179           ggg(1)=facel*xj
3180           ggg(2)=facel*yj
3181           ggg(3)=facel*zj
3182 c          do k=1,3
3183 c            ghalf=0.5D0*ggg(k)
3184 c            gelc(k,i)=gelc(k,i)+ghalf
3185 c            gelc(k,j)=gelc(k,j)+ghalf
3186 c          enddo
3187 c 9/28/08 AL Gradient compotents will be summed only at the end
3188           do k=1,3
3189             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3190             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3191           enddo
3192 *
3193 * Loop over residues i+1 thru j-1.
3194 *
3195 cgrad          do k=i+1,j-1
3196 cgrad            do l=1,3
3197 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3198 cgrad            enddo
3199 cgrad          enddo
3200           ggg(1)=facvdw*xj
3201           ggg(2)=facvdw*yj
3202           ggg(3)=facvdw*zj
3203 c          do k=1,3
3204 c            ghalf=0.5D0*ggg(k)
3205 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3206 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3207 c          enddo
3208 c 9/28/08 AL Gradient compotents will be summed only at the end
3209           do k=1,3
3210             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3211             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3212           enddo
3213 *
3214 * Loop over residues i+1 thru j-1.
3215 *
3216 cgrad          do k=i+1,j-1
3217 cgrad            do l=1,3
3218 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3219 cgrad            enddo
3220 cgrad          enddo
3221 #else
3222           facvdw=ev1+evdwij
3223           facel=el1+eesij
3224           fac1=fac
3225           fac=-3*rrmij*(facvdw+facvdw+facel)
3226           erij(1)=xj*rmij
3227           erij(2)=yj*rmij
3228           erij(3)=zj*rmij
3229 *
3230 * Radial derivatives. First process both termini of the fragment (i,j)
3231 *
3232           ggg(1)=fac*xj
3233           ggg(2)=fac*yj
3234           ggg(3)=fac*zj
3235 c          do k=1,3
3236 c            ghalf=0.5D0*ggg(k)
3237 c            gelc(k,i)=gelc(k,i)+ghalf
3238 c            gelc(k,j)=gelc(k,j)+ghalf
3239 c          enddo
3240 c 9/28/08 AL Gradient compotents will be summed only at the end
3241           do k=1,3
3242             gelc_long(k,j)=gelc(k,j)+ggg(k)
3243             gelc_long(k,i)=gelc(k,i)-ggg(k)
3244           enddo
3245 *
3246 * Loop over residues i+1 thru j-1.
3247 *
3248 cgrad          do k=i+1,j-1
3249 cgrad            do l=1,3
3250 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3251 cgrad            enddo
3252 cgrad          enddo
3253 c 9/28/08 AL Gradient compotents will be summed only at the end
3254           ggg(1)=facvdw*xj
3255           ggg(2)=facvdw*yj
3256           ggg(3)=facvdw*zj
3257           do k=1,3
3258             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3259             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3260           enddo
3261 #endif
3262 *
3263 * Angular part
3264 *
3265           ecosa=2.0D0*fac3*fac1+fac4
3266           fac4=-3.0D0*fac4
3267           fac3=-6.0D0*fac3
3268           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3269           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3270           do k=1,3
3271             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3272             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3273           enddo
3274 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3275 cd   &          (dcosg(k),k=1,3)
3276           do k=1,3
3277             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3278           enddo
3279 c          do k=1,3
3280 c            ghalf=0.5D0*ggg(k)
3281 c            gelc(k,i)=gelc(k,i)+ghalf
3282 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3283 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3284 c            gelc(k,j)=gelc(k,j)+ghalf
3285 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3286 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3287 c          enddo
3288 cgrad          do k=i+1,j-1
3289 cgrad            do l=1,3
3290 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3291 cgrad            enddo
3292 cgrad          enddo
3293           do k=1,3
3294             gelc(k,i)=gelc(k,i)
3295      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3296      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3297             gelc(k,j)=gelc(k,j)
3298      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3299      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3300             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3301             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3302           enddo
3303           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3304      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3305      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3306 C
3307 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3308 C   energy of a peptide unit is assumed in the form of a second-order
3309 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3310 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3311 C   are computed for EVERY pair of non-contiguous peptide groups.
3312 C
3313           if (j.lt.nres-1) then
3314             j1=j+1
3315             j2=j-1
3316           else
3317             j1=j-1
3318             j2=j-2
3319           endif
3320           kkk=0
3321           do k=1,2
3322             do l=1,2
3323               kkk=kkk+1
3324               muij(kkk)=mu(k,i)*mu(l,j)
3325             enddo
3326           enddo
3327 cd         write (iout,*) 'EELEC: i',i,' j',j
3328 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3329 cd          write(iout,*) 'muij',muij
3330           ury=scalar(uy(1,i),erij)
3331           urz=scalar(uz(1,i),erij)
3332           vry=scalar(uy(1,j),erij)
3333           vrz=scalar(uz(1,j),erij)
3334           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3335           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3336           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3337           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3338           fac=dsqrt(-ael6i)*r3ij
3339           a22=a22*fac
3340           a23=a23*fac
3341           a32=a32*fac
3342           a33=a33*fac
3343 cd          write (iout,'(4i5,4f10.5)')
3344 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3345 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3346 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3347 cd     &      uy(:,j),uz(:,j)
3348 cd          write (iout,'(4f10.5)')
3349 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3350 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3351 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3352 cd           write (iout,'(9f10.5/)')
3353 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3354 C Derivatives of the elements of A in virtual-bond vectors
3355           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3356           do k=1,3
3357             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3358             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3359             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3360             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3361             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3362             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3363             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3364             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3365             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3366             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3367             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3368             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3369           enddo
3370 C Compute radial contributions to the gradient
3371           facr=-3.0d0*rrmij
3372           a22der=a22*facr
3373           a23der=a23*facr
3374           a32der=a32*facr
3375           a33der=a33*facr
3376           agg(1,1)=a22der*xj
3377           agg(2,1)=a22der*yj
3378           agg(3,1)=a22der*zj
3379           agg(1,2)=a23der*xj
3380           agg(2,2)=a23der*yj
3381           agg(3,2)=a23der*zj
3382           agg(1,3)=a32der*xj
3383           agg(2,3)=a32der*yj
3384           agg(3,3)=a32der*zj
3385           agg(1,4)=a33der*xj
3386           agg(2,4)=a33der*yj
3387           agg(3,4)=a33der*zj
3388 C Add the contributions coming from er
3389           fac3=-3.0d0*fac
3390           do k=1,3
3391             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3392             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3393             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3394             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3395           enddo
3396           do k=1,3
3397 C Derivatives in DC(i)
3398 cgrad            ghalf1=0.5d0*agg(k,1)
3399 cgrad            ghalf2=0.5d0*agg(k,2)
3400 cgrad            ghalf3=0.5d0*agg(k,3)
3401 cgrad            ghalf4=0.5d0*agg(k,4)
3402             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3403      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3404             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3405      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3406             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3407      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3408             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3409      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3410 C Derivatives in DC(i+1)
3411             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3412      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3413             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3414      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3415             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3416      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3417             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3418      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3419 C Derivatives in DC(j)
3420             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3421      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3422             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3423      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3424             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3425      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3426             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3427      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3428 C Derivatives in DC(j+1) or DC(nres-1)
3429             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3430      &      -3.0d0*vryg(k,3)*ury)
3431             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3432      &      -3.0d0*vrzg(k,3)*ury)
3433             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3434      &      -3.0d0*vryg(k,3)*urz)
3435             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3436      &      -3.0d0*vrzg(k,3)*urz)
3437 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3438 cgrad              do l=1,4
3439 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3440 cgrad              enddo
3441 cgrad            endif
3442           enddo
3443           acipa(1,1)=a22
3444           acipa(1,2)=a23
3445           acipa(2,1)=a32
3446           acipa(2,2)=a33
3447           a22=-a22
3448           a23=-a23
3449           do l=1,2
3450             do k=1,3
3451               agg(k,l)=-agg(k,l)
3452               aggi(k,l)=-aggi(k,l)
3453               aggi1(k,l)=-aggi1(k,l)
3454               aggj(k,l)=-aggj(k,l)
3455               aggj1(k,l)=-aggj1(k,l)
3456             enddo
3457           enddo
3458           if (j.lt.nres-1) then
3459             a22=-a22
3460             a32=-a32
3461             do l=1,3,2
3462               do k=1,3
3463                 agg(k,l)=-agg(k,l)
3464                 aggi(k,l)=-aggi(k,l)
3465                 aggi1(k,l)=-aggi1(k,l)
3466                 aggj(k,l)=-aggj(k,l)
3467                 aggj1(k,l)=-aggj1(k,l)
3468               enddo
3469             enddo
3470           else
3471             a22=-a22
3472             a23=-a23
3473             a32=-a32
3474             a33=-a33
3475             do l=1,4
3476               do k=1,3
3477                 agg(k,l)=-agg(k,l)
3478                 aggi(k,l)=-aggi(k,l)
3479                 aggi1(k,l)=-aggi1(k,l)
3480                 aggj(k,l)=-aggj(k,l)
3481                 aggj1(k,l)=-aggj1(k,l)
3482               enddo
3483             enddo
3484           endif
3485           ENDIF ! WCORR
3486           IF (wel_loc.gt.0.0d0) THEN
3487 C Contribution to the local-electrostatic energy coming from the i-j pair
3488           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3489      &     +a33*muij(4)
3490 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3491
3492           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3493      &            'eelloc',i,j,eel_loc_ij
3494
3495           eel_loc=eel_loc+eel_loc_ij
3496 C Partial derivatives in virtual-bond dihedral angles gamma
3497           if (i.gt.1)
3498      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3499      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3500      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3501           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3502      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3503      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3504 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3505           do l=1,3
3506             ggg(l)=agg(l,1)*muij(1)+
3507      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3508             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3509             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3510 cgrad            ghalf=0.5d0*ggg(l)
3511 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3512 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3513           enddo
3514 cgrad          do k=i+1,j2
3515 cgrad            do l=1,3
3516 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3517 cgrad            enddo
3518 cgrad          enddo
3519 C Remaining derivatives of eello
3520           do l=1,3
3521             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3522      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3523             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3524      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3525             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3526      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3527             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3528      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3529           enddo
3530           ENDIF
3531 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3532 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3533           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3534      &       .and. num_conti.le.maxconts) then
3535 c            write (iout,*) i,j," entered corr"
3536 C
3537 C Calculate the contact function. The ith column of the array JCONT will
3538 C contain the numbers of atoms that make contacts with the atom I (of numbers
3539 C greater than I). The arrays FACONT and GACONT will contain the values of
3540 C the contact function and its derivative.
3541 c           r0ij=1.02D0*rpp(iteli,itelj)
3542 c           r0ij=1.11D0*rpp(iteli,itelj)
3543             r0ij=2.20D0*rpp(iteli,itelj)
3544 c           r0ij=1.55D0*rpp(iteli,itelj)
3545             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3546             if (fcont.gt.0.0D0) then
3547               num_conti=num_conti+1
3548               if (num_conti.gt.maxconts) then
3549                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3550      &                         ' will skip next contacts for this conf.'
3551               else
3552                 jcont_hb(num_conti,i)=j
3553 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3554 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3555                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3556      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3557 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3558 C  terms.
3559                 d_cont(num_conti,i)=rij
3560 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3561 C     --- Electrostatic-interaction matrix ---
3562                 a_chuj(1,1,num_conti,i)=a22
3563                 a_chuj(1,2,num_conti,i)=a23
3564                 a_chuj(2,1,num_conti,i)=a32
3565                 a_chuj(2,2,num_conti,i)=a33
3566 C     --- Gradient of rij
3567                 do kkk=1,3
3568                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3569                 enddo
3570                 kkll=0
3571                 do k=1,2
3572                   do l=1,2
3573                     kkll=kkll+1
3574                     do m=1,3
3575                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3576                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3577                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3578                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3579                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3580                     enddo
3581                   enddo
3582                 enddo
3583                 ENDIF
3584                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3585 C Calculate contact energies
3586                 cosa4=4.0D0*cosa
3587                 wij=cosa-3.0D0*cosb*cosg
3588                 cosbg1=cosb+cosg
3589                 cosbg2=cosb-cosg
3590 c               fac3=dsqrt(-ael6i)/r0ij**3
3591                 fac3=dsqrt(-ael6i)*r3ij
3592 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3593                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3594                 if (ees0tmp.gt.0) then
3595                   ees0pij=dsqrt(ees0tmp)
3596                 else
3597                   ees0pij=0
3598                 endif
3599 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3600                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3601                 if (ees0tmp.gt.0) then
3602                   ees0mij=dsqrt(ees0tmp)
3603                 else
3604                   ees0mij=0
3605                 endif
3606 c               ees0mij=0.0D0
3607                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3608                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3609 C Diagnostics. Comment out or remove after debugging!
3610 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3611 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3612 c               ees0m(num_conti,i)=0.0D0
3613 C End diagnostics.
3614 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3615 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3616 C Angular derivatives of the contact function
3617                 ees0pij1=fac3/ees0pij
3618                 ees0mij1=fac3/ees0mij
3619                 fac3p=-3.0D0*fac3*rrmij
3620                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3621                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3622 c               ees0mij1=0.0D0
3623                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3624                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3625                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3626                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3627                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3628                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3629                 ecosap=ecosa1+ecosa2
3630                 ecosbp=ecosb1+ecosb2
3631                 ecosgp=ecosg1+ecosg2
3632                 ecosam=ecosa1-ecosa2
3633                 ecosbm=ecosb1-ecosb2
3634                 ecosgm=ecosg1-ecosg2
3635 C Diagnostics
3636 c               ecosap=ecosa1
3637 c               ecosbp=ecosb1
3638 c               ecosgp=ecosg1
3639 c               ecosam=0.0D0
3640 c               ecosbm=0.0D0
3641 c               ecosgm=0.0D0
3642 C End diagnostics
3643                 facont_hb(num_conti,i)=fcont
3644                 fprimcont=fprimcont/rij
3645 cd              facont_hb(num_conti,i)=1.0D0
3646 C Following line is for diagnostics.
3647 cd              fprimcont=0.0D0
3648                 do k=1,3
3649                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3650                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3651                 enddo
3652                 do k=1,3
3653                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3654                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3655                 enddo
3656                 gggp(1)=gggp(1)+ees0pijp*xj
3657                 gggp(2)=gggp(2)+ees0pijp*yj
3658                 gggp(3)=gggp(3)+ees0pijp*zj
3659                 gggm(1)=gggm(1)+ees0mijp*xj
3660                 gggm(2)=gggm(2)+ees0mijp*yj
3661                 gggm(3)=gggm(3)+ees0mijp*zj
3662 C Derivatives due to the contact function
3663                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3664                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3665                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3666                 do k=1,3
3667 c
3668 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3669 c          following the change of gradient-summation algorithm.
3670 c
3671 cgrad                  ghalfp=0.5D0*gggp(k)
3672 cgrad                  ghalfm=0.5D0*gggm(k)
3673                   gacontp_hb1(k,num_conti,i)=!ghalfp
3674      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3675      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3676                   gacontp_hb2(k,num_conti,i)=!ghalfp
3677      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3678      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3679                   gacontp_hb3(k,num_conti,i)=gggp(k)
3680                   gacontm_hb1(k,num_conti,i)=!ghalfm
3681      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3682      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3683                   gacontm_hb2(k,num_conti,i)=!ghalfm
3684      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3685      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3686                   gacontm_hb3(k,num_conti,i)=gggm(k)
3687                 enddo
3688 C Diagnostics. Comment out or remove after debugging!
3689 cdiag           do k=1,3
3690 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3691 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3692 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3693 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3694 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3695 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3696 cdiag           enddo
3697               ENDIF ! wcorr
3698               endif  ! num_conti.le.maxconts
3699             endif  ! fcont.gt.0
3700           endif    ! j.gt.i+1
3701           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3702             do k=1,4
3703               do l=1,3
3704                 ghalf=0.5d0*agg(l,k)
3705                 aggi(l,k)=aggi(l,k)+ghalf
3706                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3707                 aggj(l,k)=aggj(l,k)+ghalf
3708               enddo
3709             enddo
3710             if (j.eq.nres-1 .and. i.lt.j-2) then
3711               do k=1,4
3712                 do l=1,3
3713                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3714                 enddo
3715               enddo
3716             endif
3717           endif
3718 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3719       return
3720       end
3721 C-----------------------------------------------------------------------------
3722       subroutine eturn3(i,eello_turn3)
3723 C Third- and fourth-order contributions from turns
3724       implicit real*8 (a-h,o-z)
3725       include 'DIMENSIONS'
3726       include 'COMMON.IOUNITS'
3727       include 'COMMON.GEO'
3728       include 'COMMON.VAR'
3729       include 'COMMON.LOCAL'
3730       include 'COMMON.CHAIN'
3731       include 'COMMON.DERIV'
3732       include 'COMMON.INTERACT'
3733       include 'COMMON.CONTACTS'
3734       include 'COMMON.TORSION'
3735       include 'COMMON.VECTORS'
3736       include 'COMMON.FFIELD'
3737       include 'COMMON.CONTROL'
3738       dimension ggg(3)
3739       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3740      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3741      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3742       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3743      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3744       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3745      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3746      &    num_conti,j1,j2
3747       j=i+2
3748 c      write (iout,*) "eturn3",i,j,j1,j2
3749       a_temp(1,1)=a22
3750       a_temp(1,2)=a23
3751       a_temp(2,1)=a32
3752       a_temp(2,2)=a33
3753 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3754 C
3755 C               Third-order contributions
3756 C
3757 C                 (i+2)o----(i+3)
3758 C                      | |
3759 C                      | |
3760 C                 (i+1)o----i
3761 C
3762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3763 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3764         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3765         call transpose2(auxmat(1,1),auxmat1(1,1))
3766         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3767         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3768         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3769      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3770 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3771 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3772 cd     &    ' eello_turn3_num',4*eello_turn3_num
3773 C Derivatives in gamma(i)
3774         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3775         call transpose2(auxmat2(1,1),auxmat3(1,1))
3776         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3777         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3778 C Derivatives in gamma(i+1)
3779         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3780         call transpose2(auxmat2(1,1),auxmat3(1,1))
3781         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3782         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3783      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3784 C Cartesian derivatives
3785         do l=1,3
3786 c            ghalf1=0.5d0*agg(l,1)
3787 c            ghalf2=0.5d0*agg(l,2)
3788 c            ghalf3=0.5d0*agg(l,3)
3789 c            ghalf4=0.5d0*agg(l,4)
3790           a_temp(1,1)=aggi(l,1)!+ghalf1
3791           a_temp(1,2)=aggi(l,2)!+ghalf2
3792           a_temp(2,1)=aggi(l,3)!+ghalf3
3793           a_temp(2,2)=aggi(l,4)!+ghalf4
3794           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3795           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3796      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3797           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3798           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3799           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3800           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3802           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3804           a_temp(1,1)=aggj(l,1)!+ghalf1
3805           a_temp(1,2)=aggj(l,2)!+ghalf2
3806           a_temp(2,1)=aggj(l,3)!+ghalf3
3807           a_temp(2,2)=aggj(l,4)!+ghalf4
3808           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3809           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3810      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3811           a_temp(1,1)=aggj1(l,1)
3812           a_temp(1,2)=aggj1(l,2)
3813           a_temp(2,1)=aggj1(l,3)
3814           a_temp(2,2)=aggj1(l,4)
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818         enddo
3819       return
3820       end
3821 C-------------------------------------------------------------------------------
3822       subroutine eturn4(i,eello_turn4)
3823 C Third- and fourth-order contributions from turns
3824       implicit real*8 (a-h,o-z)
3825       include 'DIMENSIONS'
3826       include 'COMMON.IOUNITS'
3827       include 'COMMON.GEO'
3828       include 'COMMON.VAR'
3829       include 'COMMON.LOCAL'
3830       include 'COMMON.CHAIN'
3831       include 'COMMON.DERIV'
3832       include 'COMMON.INTERACT'
3833       include 'COMMON.CONTACTS'
3834       include 'COMMON.TORSION'
3835       include 'COMMON.VECTORS'
3836       include 'COMMON.FFIELD'
3837       include 'COMMON.CONTROL'
3838       dimension ggg(3)
3839       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3840      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3841      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3842       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3843      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3844       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3845      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3846      &    num_conti,j1,j2
3847       j=i+3
3848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3849 C
3850 C               Fourth-order contributions
3851 C
3852 C                 (i+3)o----(i+4)
3853 C                     /  |
3854 C               (i+2)o   |
3855 C                     \  |
3856 C                 (i+1)o----i
3857 C
3858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3859 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3860 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3861         a_temp(1,1)=a22
3862         a_temp(1,2)=a23
3863         a_temp(2,1)=a32
3864         a_temp(2,2)=a33
3865         iti1=itortyp(itype(i+1))
3866         iti2=itortyp(itype(i+2))
3867         iti3=itortyp(itype(i+3))
3868 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3869         call transpose2(EUg(1,1,i+1),e1t(1,1))
3870         call transpose2(Eug(1,1,i+2),e2t(1,1))
3871         call transpose2(Eug(1,1,i+3),e3t(1,1))
3872         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3873         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3874         s1=scalar2(b1(1,iti2),auxvec(1))
3875         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3876         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3877         s2=scalar2(b1(1,iti1),auxvec(1))
3878         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3879         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3880         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3881         eello_turn4=eello_turn4-(s1+s2+s3)
3882         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3883      &      'eturn4',i,j,-(s1+s2+s3)
3884 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3885 cd     &    ' eello_turn4_num',8*eello_turn4_num
3886 C Derivatives in gamma(i)
3887         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3888         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3889         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3890         s1=scalar2(b1(1,iti2),auxvec(1))
3891         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3892         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3893         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3894 C Derivatives in gamma(i+1)
3895         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3896         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3897         s2=scalar2(b1(1,iti1),auxvec(1))
3898         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3899         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3900         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3901         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3902 C Derivatives in gamma(i+2)
3903         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3904         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3905         s1=scalar2(b1(1,iti2),auxvec(1))
3906         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3907         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3908         s2=scalar2(b1(1,iti1),auxvec(1))
3909         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3910         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3913 C Cartesian derivatives
3914 C Derivatives of this turn contributions in DC(i+2)
3915         if (j.lt.nres-1) then
3916           do l=1,3
3917             a_temp(1,1)=agg(l,1)
3918             a_temp(1,2)=agg(l,2)
3919             a_temp(2,1)=agg(l,3)
3920             a_temp(2,2)=agg(l,4)
3921             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3922             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3923             s1=scalar2(b1(1,iti2),auxvec(1))
3924             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3925             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3926             s2=scalar2(b1(1,iti1),auxvec(1))
3927             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3928             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3929             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3930             ggg(l)=-(s1+s2+s3)
3931             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3932           enddo
3933         endif
3934 C Remaining derivatives of this turn contribution
3935         do l=1,3
3936           a_temp(1,1)=aggi(l,1)
3937           a_temp(1,2)=aggi(l,2)
3938           a_temp(2,1)=aggi(l,3)
3939           a_temp(2,2)=aggi(l,4)
3940           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3941           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3942           s1=scalar2(b1(1,iti2),auxvec(1))
3943           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3944           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3945           s2=scalar2(b1(1,iti1),auxvec(1))
3946           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3947           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3948           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3949           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3950           a_temp(1,1)=aggi1(l,1)
3951           a_temp(1,2)=aggi1(l,2)
3952           a_temp(2,1)=aggi1(l,3)
3953           a_temp(2,2)=aggi1(l,4)
3954           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3955           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3956           s1=scalar2(b1(1,iti2),auxvec(1))
3957           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3958           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3959           s2=scalar2(b1(1,iti1),auxvec(1))
3960           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3961           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3962           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3963           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3964           a_temp(1,1)=aggj(l,1)
3965           a_temp(1,2)=aggj(l,2)
3966           a_temp(2,1)=aggj(l,3)
3967           a_temp(2,2)=aggj(l,4)
3968           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3969           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3970           s1=scalar2(b1(1,iti2),auxvec(1))
3971           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3972           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3973           s2=scalar2(b1(1,iti1),auxvec(1))
3974           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3975           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3976           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3977           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3978           a_temp(1,1)=aggj1(l,1)
3979           a_temp(1,2)=aggj1(l,2)
3980           a_temp(2,1)=aggj1(l,3)
3981           a_temp(2,2)=aggj1(l,4)
3982           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3983           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3984           s1=scalar2(b1(1,iti2),auxvec(1))
3985           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3986           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3987           s2=scalar2(b1(1,iti1),auxvec(1))
3988           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3989           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3990           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3991 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3992           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3993         enddo
3994       return
3995       end
3996 C-----------------------------------------------------------------------------
3997       subroutine vecpr(u,v,w)
3998       implicit real*8(a-h,o-z)
3999       dimension u(3),v(3),w(3)
4000       w(1)=u(2)*v(3)-u(3)*v(2)
4001       w(2)=-u(1)*v(3)+u(3)*v(1)
4002       w(3)=u(1)*v(2)-u(2)*v(1)
4003       return
4004       end
4005 C-----------------------------------------------------------------------------
4006       subroutine unormderiv(u,ugrad,unorm,ungrad)
4007 C This subroutine computes the derivatives of a normalized vector u, given
4008 C the derivatives computed without normalization conditions, ugrad. Returns
4009 C ungrad.
4010       implicit none
4011       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4012       double precision vec(3)
4013       double precision scalar
4014       integer i,j
4015 c      write (2,*) 'ugrad',ugrad
4016 c      write (2,*) 'u',u
4017       do i=1,3
4018         vec(i)=scalar(ugrad(1,i),u(1))
4019       enddo
4020 c      write (2,*) 'vec',vec
4021       do i=1,3
4022         do j=1,3
4023           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4024         enddo
4025       enddo
4026 c      write (2,*) 'ungrad',ungrad
4027       return
4028       end
4029 C-----------------------------------------------------------------------------
4030       subroutine escp_soft_sphere(evdw2,evdw2_14)
4031 C
4032 C This subroutine calculates the excluded-volume interaction energy between
4033 C peptide-group centers and side chains and its gradient in virtual-bond and
4034 C side-chain vectors.
4035 C
4036       implicit real*8 (a-h,o-z)
4037       include 'DIMENSIONS'
4038       include 'COMMON.GEO'
4039       include 'COMMON.VAR'
4040       include 'COMMON.LOCAL'
4041       include 'COMMON.CHAIN'
4042       include 'COMMON.DERIV'
4043       include 'COMMON.INTERACT'
4044       include 'COMMON.FFIELD'
4045       include 'COMMON.IOUNITS'
4046       include 'COMMON.CONTROL'
4047       dimension ggg(3)
4048       evdw2=0.0D0
4049       evdw2_14=0.0d0
4050       r0_scp=4.5d0
4051 cd    print '(a)','Enter ESCP'
4052 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4053       do i=iatscp_s,iatscp_e
4054         iteli=itel(i)
4055         xi=0.5D0*(c(1,i)+c(1,i+1))
4056         yi=0.5D0*(c(2,i)+c(2,i+1))
4057         zi=0.5D0*(c(3,i)+c(3,i+1))
4058
4059         do iint=1,nscp_gr(i)
4060
4061         do j=iscpstart(i,iint),iscpend(i,iint)
4062           itypj=iabs(itype(j))
4063 C Uncomment following three lines for SC-p interactions
4064 c         xj=c(1,nres+j)-xi
4065 c         yj=c(2,nres+j)-yi
4066 c         zj=c(3,nres+j)-zi
4067 C Uncomment following three lines for Ca-p interactions
4068           xj=c(1,j)-xi
4069           yj=c(2,j)-yi
4070           zj=c(3,j)-zi
4071           rij=xj*xj+yj*yj+zj*zj
4072           r0ij=r0_scp
4073           r0ijsq=r0ij*r0ij
4074           if (rij.lt.r0ijsq) then
4075             evdwij=0.25d0*(rij-r0ijsq)**2
4076             fac=rij-r0ijsq
4077           else
4078             evdwij=0.0d0
4079             fac=0.0d0
4080           endif
4081           evdw2=evdw2+evdwij
4082 C
4083 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4084 C
4085           ggg(1)=xj*fac
4086           ggg(2)=yj*fac
4087           ggg(3)=zj*fac
4088 cgrad          if (j.lt.i) then
4089 cd          write (iout,*) 'j<i'
4090 C Uncomment following three lines for SC-p interactions
4091 c           do k=1,3
4092 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4093 c           enddo
4094 cgrad          else
4095 cd          write (iout,*) 'j>i'
4096 cgrad            do k=1,3
4097 cgrad              ggg(k)=-ggg(k)
4098 C Uncomment following line for SC-p interactions
4099 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4100 cgrad            enddo
4101 cgrad          endif
4102 cgrad          do k=1,3
4103 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4104 cgrad          enddo
4105 cgrad          kstart=min0(i+1,j)
4106 cgrad          kend=max0(i-1,j-1)
4107 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4108 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4109 cgrad          do k=kstart,kend
4110 cgrad            do l=1,3
4111 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4112 cgrad            enddo
4113 cgrad          enddo
4114           do k=1,3
4115             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4116             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4117           enddo
4118         enddo
4119
4120         enddo ! iint
4121       enddo ! i
4122       return
4123       end
4124 C-----------------------------------------------------------------------------
4125       subroutine escp(evdw2,evdw2_14)
4126 C
4127 C This subroutine calculates the excluded-volume interaction energy between
4128 C peptide-group centers and side chains and its gradient in virtual-bond and
4129 C side-chain vectors.
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.GEO'
4134       include 'COMMON.VAR'
4135       include 'COMMON.LOCAL'
4136       include 'COMMON.CHAIN'
4137       include 'COMMON.DERIV'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.FFIELD'
4140       include 'COMMON.IOUNITS'
4141       include 'COMMON.CONTROL'
4142       dimension ggg(3)
4143       evdw2=0.0D0
4144       evdw2_14=0.0d0
4145 cd    print '(a)','Enter ESCP'
4146 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4147       do i=iatscp_s,iatscp_e
4148         iteli=itel(i)
4149         xi=0.5D0*(c(1,i)+c(1,i+1))
4150         yi=0.5D0*(c(2,i)+c(2,i+1))
4151         zi=0.5D0*(c(3,i)+c(3,i+1))
4152
4153         do iint=1,nscp_gr(i)
4154
4155         do j=iscpstart(i,iint),iscpend(i,iint)
4156           itypj=iabs(itype(j))
4157 C Uncomment following three lines for SC-p interactions
4158 c         xj=c(1,nres+j)-xi
4159 c         yj=c(2,nres+j)-yi
4160 c         zj=c(3,nres+j)-zi
4161 C Uncomment following three lines for Ca-p interactions
4162           xj=c(1,j)-xi
4163           yj=c(2,j)-yi
4164           zj=c(3,j)-zi
4165           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4166           fac=rrij**expon2
4167           e1=fac*fac*aad(itypj,iteli)
4168           e2=fac*bad(itypj,iteli)
4169           if (iabs(j-i) .le. 2) then
4170             e1=scal14*e1
4171             e2=scal14*e2
4172             evdw2_14=evdw2_14+e1+e2
4173           endif
4174           evdwij=e1+e2
4175           evdw2=evdw2+evdwij
4176           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4177      &        'evdw2',i,j,evdwij
4178 C
4179 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4180 C
4181           fac=-(evdwij+e1)*rrij
4182           ggg(1)=xj*fac
4183           ggg(2)=yj*fac
4184           ggg(3)=zj*fac
4185 cgrad          if (j.lt.i) then
4186 cd          write (iout,*) 'j<i'
4187 C Uncomment following three lines for SC-p interactions
4188 c           do k=1,3
4189 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4190 c           enddo
4191 cgrad          else
4192 cd          write (iout,*) 'j>i'
4193 cgrad            do k=1,3
4194 cgrad              ggg(k)=-ggg(k)
4195 C Uncomment following line for SC-p interactions
4196 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4197 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4198 cgrad            enddo
4199 cgrad          endif
4200 cgrad          do k=1,3
4201 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4202 cgrad          enddo
4203 cgrad          kstart=min0(i+1,j)
4204 cgrad          kend=max0(i-1,j-1)
4205 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4206 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4207 cgrad          do k=kstart,kend
4208 cgrad            do l=1,3
4209 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4210 cgrad            enddo
4211 cgrad          enddo
4212           do k=1,3
4213             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4214             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4215           enddo
4216         enddo
4217
4218         enddo ! iint
4219       enddo ! i
4220       do i=1,nct
4221         do j=1,3
4222           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4223           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4224           gradx_scp(j,i)=expon*gradx_scp(j,i)
4225         enddo
4226       enddo
4227 C******************************************************************************
4228 C
4229 C                              N O T E !!!
4230 C
4231 C To save time the factor EXPON has been extracted from ALL components
4232 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4233 C use!
4234 C
4235 C******************************************************************************
4236       return
4237       end
4238 C--------------------------------------------------------------------------
4239       subroutine edis(ehpb)
4240 C
4241 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4242 C
4243       implicit real*8 (a-h,o-z)
4244       include 'DIMENSIONS'
4245       include 'COMMON.SBRIDGE'
4246       include 'COMMON.CHAIN'
4247       include 'COMMON.DERIV'
4248       include 'COMMON.VAR'
4249       include 'COMMON.INTERACT'
4250       include 'COMMON.IOUNITS'
4251       dimension ggg(3)
4252       ehpb=0.0D0
4253 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4254 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4255       if (link_end.eq.0) return
4256       do i=link_start,link_end
4257 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4258 C CA-CA distance used in regularization of structure.
4259         ii=ihpb(i)
4260         jj=jhpb(i)
4261 C iii and jjj point to the residues for which the distance is assigned.
4262         if (ii.gt.nres) then
4263           iii=ii-nres
4264           jjj=jj-nres
4265         else
4266           iii=ii
4267           jjj=jj
4268         endif
4269 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4270 c     &    dhpb(i),dhpb1(i),forcon(i)
4271 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4272 C    distance and angle dependent SS bond potential.
4273         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. iabs(itype(jjj
4274      &)).eq.1) then
4275           call ssbond_ene(iii,jjj,eij)
4276           ehpb=ehpb+2*eij
4277 cd          write (iout,*) "eij",eij
4278         else if (ii.gt.nres .and. jj.gt.nres) then
4279 c Restraints from contact prediction
4280           dd=dist(ii,jj)
4281           if (dhpb1(i).gt.0.0d0) then
4282             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4283             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4284 c            write (iout,*) "beta nmr",
4285 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4286           else
4287             dd=dist(ii,jj)
4288             rdis=dd-dhpb(i)
4289 C Get the force constant corresponding to this distance.
4290             waga=forcon(i)
4291 C Calculate the contribution to energy.
4292             ehpb=ehpb+waga*rdis*rdis
4293 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4294 C
4295 C Evaluate gradient.
4296 C
4297             fac=waga*rdis/dd
4298           endif
4299           do j=1,3
4300             ggg(j)=fac*(c(j,jj)-c(j,ii))
4301           enddo
4302           do j=1,3
4303             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4304             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4305           enddo
4306           do k=1,3
4307             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4308             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4309           enddo
4310         else
4311 C Calculate the distance between the two points and its difference from the
4312 C target distance.
4313           dd=dist(ii,jj)
4314           if (dhpb1(i).gt.0.0d0) then
4315             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4316             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4317 c            write (iout,*) "alph nmr",
4318 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4319           else
4320             rdis=dd-dhpb(i)
4321 C Get the force constant corresponding to this distance.
4322             waga=forcon(i)
4323 C Calculate the contribution to energy.
4324             ehpb=ehpb+waga*rdis*rdis
4325 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4326 C
4327 C Evaluate gradient.
4328 C
4329             fac=waga*rdis/dd
4330           endif
4331 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4332 cd   &   ' waga=',waga,' fac=',fac
4333             do j=1,3
4334               ggg(j)=fac*(c(j,jj)-c(j,ii))
4335             enddo
4336 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4337 C If this is a SC-SC distance, we need to calculate the contributions to the
4338 C Cartesian gradient in the SC vectors (ghpbx).
4339           if (iii.lt.ii) then
4340           do j=1,3
4341             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4342             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4343           enddo
4344           endif
4345 cgrad        do j=iii,jjj-1
4346 cgrad          do k=1,3
4347 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4348 cgrad          enddo
4349 cgrad        enddo
4350           do k=1,3
4351             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4352             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4353           enddo
4354         endif
4355       enddo
4356       ehpb=0.5D0*ehpb
4357       return
4358       end
4359 C--------------------------------------------------------------------------
4360       subroutine ssbond_ene(i,j,eij)
4361 C
4362 C Calculate the distance and angle dependent SS-bond potential energy
4363 C using a free-energy function derived based on RHF/6-31G** ab initio
4364 C calculations of diethyl disulfide.
4365 C
4366 C A. Liwo and U. Kozlowska, 11/24/03
4367 C
4368       implicit real*8 (a-h,o-z)
4369       include 'DIMENSIONS'
4370       include 'COMMON.SBRIDGE'
4371       include 'COMMON.CHAIN'
4372       include 'COMMON.DERIV'
4373       include 'COMMON.LOCAL'
4374       include 'COMMON.INTERACT'
4375       include 'COMMON.VAR'
4376       include 'COMMON.IOUNITS'
4377       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4378       itypi=iabs(itype(i))
4379       xi=c(1,nres+i)
4380       yi=c(2,nres+i)
4381       zi=c(3,nres+i)
4382       dxi=dc_norm(1,nres+i)
4383       dyi=dc_norm(2,nres+i)
4384       dzi=dc_norm(3,nres+i)
4385 c      dsci_inv=dsc_inv(itypi)
4386       dsci_inv=vbld_inv(nres+i)
4387       itypj=iabs(itype(j))
4388 c      dscj_inv=dsc_inv(itypj)
4389       dscj_inv=vbld_inv(nres+j)
4390       xj=c(1,nres+j)-xi
4391       yj=c(2,nres+j)-yi
4392       zj=c(3,nres+j)-zi
4393       dxj=dc_norm(1,nres+j)
4394       dyj=dc_norm(2,nres+j)
4395       dzj=dc_norm(3,nres+j)
4396       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4397       rij=dsqrt(rrij)
4398       erij(1)=xj*rij
4399       erij(2)=yj*rij
4400       erij(3)=zj*rij
4401       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4402       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4403       om12=dxi*dxj+dyi*dyj+dzi*dzj
4404       do k=1,3
4405         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4406         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4407       enddo
4408       rij=1.0d0/rij
4409       deltad=rij-d0cm
4410       deltat1=1.0d0-om1
4411       deltat2=1.0d0+om2
4412       deltat12=om2-om1+2.0d0
4413       cosphi=om12-om1*om2
4414       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4415      &  +akct*deltad*deltat12
4416      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4417 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4418 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4419 c     &  " deltat12",deltat12," eij",eij
4420       ed=2*akcm*deltad+akct*deltat12
4421       pom1=akct*deltad
4422       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4423       eom1=-2*akth*deltat1-pom1-om2*pom2
4424       eom2= 2*akth*deltat2+pom1-om1*pom2
4425       eom12=pom2
4426       do k=1,3
4427         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4428         ghpbx(k,i)=ghpbx(k,i)-ggk
4429      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4430      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4431         ghpbx(k,j)=ghpbx(k,j)+ggk
4432      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4433      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4434         ghpbc(k,i)=ghpbc(k,i)-ggk
4435         ghpbc(k,j)=ghpbc(k,j)+ggk
4436       enddo
4437 C
4438 C Calculate the components of the gradient in DC and X
4439 C
4440 cgrad      do k=i,j-1
4441 cgrad        do l=1,3
4442 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4443 cgrad        enddo
4444 cgrad      enddo
4445       return
4446       end
4447 C--------------------------------------------------------------------------
4448       subroutine ebond(estr)
4449 c
4450 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4451 c
4452       implicit real*8 (a-h,o-z)
4453       include 'DIMENSIONS'
4454       include 'COMMON.LOCAL'
4455       include 'COMMON.GEO'
4456       include 'COMMON.INTERACT'
4457       include 'COMMON.DERIV'
4458       include 'COMMON.VAR'
4459       include 'COMMON.CHAIN'
4460       include 'COMMON.IOUNITS'
4461       include 'COMMON.NAMES'
4462       include 'COMMON.FFIELD'
4463       include 'COMMON.CONTROL'
4464       include 'COMMON.SETUP'
4465       double precision u(3),ud(3)
4466       estr=0.0d0
4467       do i=ibondp_start,ibondp_end
4468         diff = vbld(i)-vbldp0
4469 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4470         estr=estr+diff*diff
4471         do j=1,3
4472           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4473         enddo
4474 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4475       enddo
4476       estr=0.5d0*AKP*estr
4477 c
4478 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4479 c
4480       do i=ibond_start,ibond_end
4481         iti=iabs(itype(i))
4482         if (iti.ne.10) then
4483           nbi=nbondterm(iti)
4484           if (nbi.eq.1) then
4485             diff=vbld(i+nres)-vbldsc0(1,iti)
4486 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4487 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4488             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4489             do j=1,3
4490               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4491             enddo
4492           else
4493             do j=1,nbi
4494               diff=vbld(i+nres)-vbldsc0(j,iti)
4495               ud(j)=aksc(j,iti)*diff
4496               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4497             enddo
4498             uprod=u(1)
4499             do j=2,nbi
4500               uprod=uprod*u(j)
4501             enddo
4502             usum=0.0d0
4503             usumsqder=0.0d0
4504             do j=1,nbi
4505               uprod1=1.0d0
4506               uprod2=1.0d0
4507               do k=1,nbi
4508                 if (k.ne.j) then
4509                   uprod1=uprod1*u(k)
4510                   uprod2=uprod2*u(k)*u(k)
4511                 endif
4512               enddo
4513               usum=usum+uprod1
4514               usumsqder=usumsqder+ud(j)*uprod2
4515             enddo
4516             estr=estr+uprod/usum
4517             do j=1,3
4518              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4519             enddo
4520           endif
4521         endif
4522       enddo
4523       return
4524       end
4525 #ifdef CRYST_THETA
4526 C--------------------------------------------------------------------------
4527       subroutine ebend(etheta)
4528 C
4529 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4530 C angles gamma and its derivatives in consecutive thetas and gammas.
4531 C
4532       implicit real*8 (a-h,o-z)
4533       include 'DIMENSIONS'
4534       include 'COMMON.LOCAL'
4535       include 'COMMON.GEO'
4536       include 'COMMON.INTERACT'
4537       include 'COMMON.DERIV'
4538       include 'COMMON.VAR'
4539       include 'COMMON.CHAIN'
4540       include 'COMMON.IOUNITS'
4541       include 'COMMON.NAMES'
4542       include 'COMMON.FFIELD'
4543       include 'COMMON.CONTROL'
4544       common /calcthet/ term1,term2,termm,diffak,ratak,
4545      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4546      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4547       double precision y(2),z(2)
4548       delta=0.02d0*pi
4549 c      time11=dexp(-2*time)
4550 c      time12=1.0d0
4551       etheta=0.0D0
4552 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4553       do i=ithet_start,ithet_end
4554 C Zero the energy function and its derivative at 0 or pi.
4555         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4556         it=(itype(i-1))
4557         ichir1=isign(1,itype(i-2))
4558         ichir2=isign(1,itype(i))
4559         if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4560         if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4561         if (itype(i-1).eq.10) then
4562          itype1=isign(10,itype(i-2))
4563          ichir11=isign(1,itype(i-2))
4564          ichir12=isign(1,itype(i-2))
4565          itype2=isign(10,itype(i))
4566          ichir21=isign(1,itype(i))
4567          ichir22=isign(1,itype(i))
4568         endif
4569         if (i.gt.3) then
4570 #ifdef OSF
4571           phii=phi(i)
4572           if (phii.ne.phii) phii=150.0
4573 #else
4574           phii=phi(i)
4575 #endif
4576           y(1)=dcos(phii)
4577           y(2)=dsin(phii)
4578         else
4579           y(1)=0.0D0
4580           y(2)=0.0D0
4581         endif
4582         if (i.lt.nres) then
4583 #ifdef OSF
4584           phii1=phi(i+1)
4585           if (phii1.ne.phii1) phii1=150.0
4586           phii1=pinorm(phii1)
4587           z(1)=cos(phii1)
4588 #else
4589           phii1=phi(i+1)
4590           z(1)=dcos(phii1)
4591 #endif
4592           z(2)=dsin(phii1)
4593         else
4594           z(1)=0.0D0
4595           z(2)=0.0D0
4596         endif
4597 C Calculate the "mean" value of theta from the part of the distribution
4598 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4599 C In following comments this theta will be referred to as t_c.
4600         thet_pred_mean=0.0d0
4601         do k=1,2
4602           athetk=athet(k,it,ichir1,ichir2)
4603           bthetk=bthet(k,it,ichir1,ichir2)
4604         if (it.eq.10) then
4605            athetk=athet(k,itype1,ichir11,ichir12)
4606            bthetk=bthet(k,itype2,ichir21,ichir22)
4607         endif
4608           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4609         enddo
4610         dthett=thet_pred_mean*ssd
4611         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4612 C Derivatives of the "mean" values in gamma1 and gamma2.
4613         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4614      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4615         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4616      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4617         if (it.eq.10) then
4618       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4619      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4620         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4621      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4622         endif
4623         if (theta(i).gt.pi-delta) then
4624           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4625      &         E_tc0)
4626           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4627           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4628           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4629      &        E_theta)
4630           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4631      &        E_tc)
4632         else if (theta(i).lt.delta) then
4633           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4634           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4635           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4636      &        E_theta)
4637           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4638           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4639      &        E_tc)
4640         else
4641           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4642      &        E_theta,E_tc)
4643         endif
4644         etheta=etheta+ethetai
4645         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4646      &      'ebend',i,ethetai
4647         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4648         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4649         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4650       enddo
4651 C Ufff.... We've done all this!!!
4652       return
4653       end
4654 C---------------------------------------------------------------------------
4655       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4656      &     E_tc)
4657       implicit real*8 (a-h,o-z)
4658       include 'DIMENSIONS'
4659       include 'COMMON.LOCAL'
4660       include 'COMMON.IOUNITS'
4661       common /calcthet/ term1,term2,termm,diffak,ratak,
4662      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4663      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4664 C Calculate the contributions to both Gaussian lobes.
4665 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4666 C The "polynomial part" of the "standard deviation" of this part of
4667 C the distribution.
4668         sig=polthet(3,it)
4669         do j=2,0,-1
4670           sig=sig*thet_pred_mean+polthet(j,it)
4671         enddo
4672 C Derivative of the "interior part" of the "standard deviation of the"
4673 C gamma-dependent Gaussian lobe in t_c.
4674         sigtc=3*polthet(3,it)
4675         do j=2,1,-1
4676           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4677         enddo
4678         sigtc=sig*sigtc
4679 C Set the parameters of both Gaussian lobes of the distribution.
4680 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4681         fac=sig*sig+sigc0(it)
4682         sigcsq=fac+fac
4683         sigc=1.0D0/sigcsq
4684 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4685         sigsqtc=-4.0D0*sigcsq*sigtc
4686 c       print *,i,sig,sigtc,sigsqtc
4687 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4688         sigtc=-sigtc/(fac*fac)
4689 C Following variable is sigma(t_c)**(-2)
4690         sigcsq=sigcsq*sigcsq
4691         sig0i=sig0(it)
4692         sig0inv=1.0D0/sig0i**2
4693         delthec=thetai-thet_pred_mean
4694         delthe0=thetai-theta0i
4695         term1=-0.5D0*sigcsq*delthec*delthec
4696         term2=-0.5D0*sig0inv*delthe0*delthe0
4697 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4698 C NaNs in taking the logarithm. We extract the largest exponent which is added
4699 C to the energy (this being the log of the distribution) at the end of energy
4700 C term evaluation for this virtual-bond angle.
4701         if (term1.gt.term2) then
4702           termm=term1
4703           term2=dexp(term2-termm)
4704           term1=1.0d0
4705         else
4706           termm=term2
4707           term1=dexp(term1-termm)
4708           term2=1.0d0
4709         endif
4710 C The ratio between the gamma-independent and gamma-dependent lobes of
4711 C the distribution is a Gaussian function of thet_pred_mean too.
4712         diffak=gthet(2,it)-thet_pred_mean
4713         ratak=diffak/gthet(3,it)**2
4714         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4715 C Let's differentiate it in thet_pred_mean NOW.
4716         aktc=ak*ratak
4717 C Now put together the distribution terms to make complete distribution.
4718         termexp=term1+ak*term2
4719         termpre=sigc+ak*sig0i
4720 C Contribution of the bending energy from this theta is just the -log of
4721 C the sum of the contributions from the two lobes and the pre-exponential
4722 C factor. Simple enough, isn't it?
4723         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4724 C NOW the derivatives!!!
4725 C 6/6/97 Take into account the deformation.
4726         E_theta=(delthec*sigcsq*term1
4727      &       +ak*delthe0*sig0inv*term2)/termexp
4728         E_tc=((sigtc+aktc*sig0i)/termpre
4729      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4730      &       aktc*term2)/termexp)
4731       return
4732       end
4733 c-----------------------------------------------------------------------------
4734       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4735       implicit real*8 (a-h,o-z)
4736       include 'DIMENSIONS'
4737       include 'COMMON.LOCAL'
4738       include 'COMMON.IOUNITS'
4739       common /calcthet/ term1,term2,termm,diffak,ratak,
4740      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4741      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4742       delthec=thetai-thet_pred_mean
4743       delthe0=thetai-theta0i
4744 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4745       t3 = thetai-thet_pred_mean
4746       t6 = t3**2
4747       t9 = term1
4748       t12 = t3*sigcsq
4749       t14 = t12+t6*sigsqtc
4750       t16 = 1.0d0
4751       t21 = thetai-theta0i
4752       t23 = t21**2
4753       t26 = term2
4754       t27 = t21*t26
4755       t32 = termexp
4756       t40 = t32**2
4757       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4758      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4759      & *(-t12*t9-ak*sig0inv*t27)
4760       return
4761       end
4762 #else
4763 C--------------------------------------------------------------------------
4764       subroutine ebend(etheta)
4765 C
4766 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4767 C angles gamma and its derivatives in consecutive thetas and gammas.
4768 C ab initio-derived potentials from
4769 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4770 C
4771       implicit real*8 (a-h,o-z)
4772       include 'DIMENSIONS'
4773       include 'COMMON.LOCAL'
4774       include 'COMMON.GEO'
4775       include 'COMMON.INTERACT'
4776       include 'COMMON.DERIV'
4777       include 'COMMON.VAR'
4778       include 'COMMON.CHAIN'
4779       include 'COMMON.IOUNITS'
4780       include 'COMMON.NAMES'
4781       include 'COMMON.FFIELD'
4782       include 'COMMON.CONTROL'
4783       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4784      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4785      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4786      & sinph1ph2(maxdouble,maxdouble)
4787       logical lprn /.false./, lprn1 /.false./
4788       etheta=0.0D0
4789       do i=ithet_start,ithet_end
4790         dethetai=0.0d0
4791         dephii=0.0d0
4792         dephii1=0.0d0
4793         theti2=0.5d0*theta(i)
4794         ityp2=ithetyp(itype(i-1))
4795         do k=1,nntheterm
4796           coskt(k)=dcos(k*theti2)
4797           sinkt(k)=dsin(k*theti2)
4798         enddo
4799         if (i.gt.3) then
4800 #ifdef OSF
4801           phii=phi(i)
4802           if (phii.ne.phii) phii=150.0
4803 #else
4804           phii=phi(i)
4805 #endif
4806           ityp1=ithetyp(itype(i-2))
4807           do k=1,nsingle
4808             cosph1(k)=dcos(k*phii)
4809             sinph1(k)=dsin(k*phii)
4810           enddo
4811         else
4812           phii=0.0d0
4813           ityp1=nthetyp+1
4814           do k=1,nsingle
4815             cosph1(k)=0.0d0
4816             sinph1(k)=0.0d0
4817           enddo
4818         endif
4819         if (i.lt.nres) then
4820
4821         if (iabs(itype(i+1)).eq.20) iblock=2
4822         if (iabs(itype(i+1)).ne.20) iblock=1
4823 #ifdef OSF
4824           phii1=phi(i+1)
4825           if (phii1.ne.phii1) phii1=150.0
4826           phii1=pinorm(phii1)
4827 #else
4828           phii1=phi(i+1)
4829 #endif
4830           ityp3=ithetyp(itype(i))
4831           do k=1,nsingle
4832             cosph2(k)=dcos(k*phii1)
4833             sinph2(k)=dsin(k*phii1)
4834           enddo
4835         else
4836           phii1=0.0d0
4837           ityp3=nthetyp+1
4838           do k=1,nsingle
4839             cosph2(k)=0.0d0
4840             sinph2(k)=0.0d0
4841           enddo
4842         endif
4843          ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4844         do k=1,ndouble
4845           do l=1,k-1
4846             ccl=cosph1(l)*cosph2(k-l)
4847             ssl=sinph1(l)*sinph2(k-l)
4848             scl=sinph1(l)*cosph2(k-l)
4849             csl=cosph1(l)*sinph2(k-l)
4850             cosph1ph2(l,k)=ccl-ssl
4851             cosph1ph2(k,l)=ccl+ssl
4852             sinph1ph2(l,k)=scl+csl
4853             sinph1ph2(k,l)=scl-csl
4854           enddo
4855         enddo
4856         if (lprn) then
4857         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4858      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4859         write (iout,*) "coskt and sinkt"
4860         do k=1,nntheterm
4861           write (iout,*) k,coskt(k),sinkt(k)
4862         enddo
4863         endif
4864         do k=1,ntheterm
4865           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4866           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4867      &      *coskt(k)
4868           if (lprn)
4869      &    write (iout,*) "k",k,
4870      &    "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4871      &     " ethetai",ethetai
4872         enddo
4873         if (lprn) then
4874         write (iout,*) "cosph and sinph"
4875         do k=1,nsingle
4876           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4877         enddo
4878         write (iout,*) "cosph1ph2 and sinph2ph2"
4879         do k=2,ndouble
4880           do l=1,k-1
4881             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4882      &         sinph1ph2(l,k),sinph1ph2(k,l)
4883           enddo
4884         enddo
4885         write(iout,*) "ethetai",ethetai
4886         endif
4887         do m=1,ntheterm2
4888           do k=1,nsingle
4889             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4890      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4891      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4892      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4893             ethetai=ethetai+sinkt(m)*aux
4894             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4895             dephii=dephii+k*sinkt(m)*(
4896      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4897      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4898             dephii1=dephii1+k*sinkt(m)*(
4899      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4900      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4901             if (lprn)
4902      &      write (iout,*) "m",m," k",k," bbthet",
4903      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4904      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4905      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4906      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4907           enddo
4908         enddo
4909         if (lprn)
4910      &  write(iout,*) "ethetai",ethetai
4911         do m=1,ntheterm3
4912           do k=2,ndouble
4913             do l=1,k-1
4914        aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4915      & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4916      & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4917      & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4918
4919               ethetai=ethetai+sinkt(m)*aux
4920               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4921               dephii=dephii+l*sinkt(m)*(
4922      & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4923      &  ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4924      &  ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4925      &  ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4926
4927               dephii1=dephii1+(k-l)*sinkt(m)*(
4928      &-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4929      & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4930      & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4931      & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4932
4933               if (lprn) then
4934               write (iout,*) "m",m," k",k," l",l," ffthet",
4935      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4936      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4937      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4938      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4939      &            " ethetai",ethetai
4940
4941               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4942      &            cosph1ph2(k,l)*sinkt(m),
4943      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4944               endif
4945             enddo
4946           enddo
4947         enddo
4948 10      continue
4949         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4950      &   i,theta(i)*rad2deg,phii*rad2deg,
4951      &   phii1*rad2deg,ethetai
4952         etheta=etheta+ethetai
4953         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4954         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4955         gloc(nphi+i-2,icg)=wang*dethetai
4956       enddo
4957       return
4958       end
4959 #endif
4960 #ifdef CRYST_SC
4961 c-----------------------------------------------------------------------------
4962       subroutine esc(escloc)
4963 C Calculate the local energy of a side chain and its derivatives in the
4964 C corresponding virtual-bond valence angles THETA and the spherical angles
4965 C ALPHA and OMEGA.
4966       implicit real*8 (a-h,o-z)
4967       include 'DIMENSIONS'
4968       include 'COMMON.GEO'
4969       include 'COMMON.LOCAL'
4970       include 'COMMON.VAR'
4971       include 'COMMON.INTERACT'
4972       include 'COMMON.DERIV'
4973       include 'COMMON.CHAIN'
4974       include 'COMMON.IOUNITS'
4975       include 'COMMON.NAMES'
4976       include 'COMMON.FFIELD'
4977       include 'COMMON.CONTROL'
4978       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4979      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4980       common /sccalc/ time11,time12,time112,theti,it,nlobit
4981       delta=0.02d0*pi
4982       escloc=0.0D0
4983 c     write (iout,'(a)') 'ESC'
4984       do i=loc_start,loc_end
4985         it=itype(i)
4986         if (it.eq.10) goto 1
4987         nlobit=nlob(iabs(it))
4988 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4989 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4990         theti=theta(i+1)-pipol
4991         x(1)=dtan(theti)
4992         x(2)=alph(i)
4993         x(3)=omeg(i)
4994
4995         if (x(2).gt.pi-delta) then
4996           xtemp(1)=x(1)
4997           xtemp(2)=pi-delta
4998           xtemp(3)=x(3)
4999           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5000           xtemp(2)=pi
5001           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5002           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5003      &        escloci,dersc(2))
5004           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5005      &        ddersc0(1),dersc(1))
5006           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5007      &        ddersc0(3),dersc(3))
5008           xtemp(2)=pi-delta
5009           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5010           xtemp(2)=pi
5011           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5012           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5013      &            dersc0(2),esclocbi,dersc02)
5014           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5015      &            dersc12,dersc01)
5016           call splinthet(x(2),0.5d0*delta,ss,ssd)
5017           dersc0(1)=dersc01
5018           dersc0(2)=dersc02
5019           dersc0(3)=0.0d0
5020           do k=1,3
5021             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5022           enddo
5023           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5024 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5025 c    &             esclocbi,ss,ssd
5026           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5027 c         escloci=esclocbi
5028 c         write (iout,*) escloci
5029         else if (x(2).lt.delta) then
5030           xtemp(1)=x(1)
5031           xtemp(2)=delta
5032           xtemp(3)=x(3)
5033           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5034           xtemp(2)=0.0d0
5035           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5036           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5037      &        escloci,dersc(2))
5038           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5039      &        ddersc0(1),dersc(1))
5040           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5041      &        ddersc0(3),dersc(3))
5042           xtemp(2)=delta
5043           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5044           xtemp(2)=0.0d0
5045           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5046           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5047      &            dersc0(2),esclocbi,dersc02)
5048           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5049      &            dersc12,dersc01)
5050           dersc0(1)=dersc01
5051           dersc0(2)=dersc02
5052           dersc0(3)=0.0d0
5053           call splinthet(x(2),0.5d0*delta,ss,ssd)
5054           do k=1,3
5055             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5056           enddo
5057           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5058 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5059 c    &             esclocbi,ss,ssd
5060           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5061 c         write (iout,*) escloci
5062         else
5063           call enesc(x,escloci,dersc,ddummy,.false.)
5064         endif
5065
5066         escloc=escloc+escloci
5067         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5068      &     'escloc',i,escloci
5069 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5070
5071         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5072      &   wscloc*dersc(1)
5073         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5074         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5075     1   continue
5076       enddo
5077       return
5078       end
5079 C---------------------------------------------------------------------------
5080       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5081       implicit real*8 (a-h,o-z)
5082       include 'DIMENSIONS'
5083       include 'COMMON.GEO'
5084       include 'COMMON.LOCAL'
5085       include 'COMMON.IOUNITS'
5086       common /sccalc/ time11,time12,time112,theti,it,nlobit
5087       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5088       double precision contr(maxlob,-1:1)
5089       logical mixed
5090 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5091         escloc_i=0.0D0
5092         do j=1,3
5093           dersc(j)=0.0D0
5094           if (mixed) ddersc(j)=0.0d0
5095         enddo
5096         x3=x(3)
5097
5098 C Because of periodicity of the dependence of the SC energy in omega we have
5099 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5100 C To avoid underflows, first compute & store the exponents.
5101
5102         do iii=-1,1
5103
5104           x(3)=x3+iii*dwapi
5105
5106           do j=1,nlobit
5107             do k=1,3
5108               z(k)=x(k)-censc(k,j,it)
5109             enddo
5110             do k=1,3
5111               Axk=0.0D0
5112               do l=1,3
5113                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5114               enddo
5115               Ax(k,j,iii)=Axk
5116             enddo
5117             expfac=0.0D0
5118             do k=1,3
5119               expfac=expfac+Ax(k,j,iii)*z(k)
5120             enddo
5121             contr(j,iii)=expfac
5122           enddo ! j
5123
5124         enddo ! iii
5125
5126         x(3)=x3
5127 C As in the case of ebend, we want to avoid underflows in exponentiation and
5128 C subsequent NaNs and INFs in energy calculation.
5129 C Find the largest exponent
5130         emin=contr(1,-1)
5131         do iii=-1,1
5132           do j=1,nlobit
5133             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5134           enddo
5135         enddo
5136         emin=0.5D0*emin
5137 cd      print *,'it=',it,' emin=',emin
5138
5139 C Compute the contribution to SC energy and derivatives
5140         do iii=-1,1
5141
5142           do j=1,nlobit
5143 #ifdef OSF
5144             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5145             if(adexp.ne.adexp) adexp=1.0
5146             expfac=dexp(adexp)
5147 #else
5148             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5149 #endif
5150 cd          print *,'j=',j,' expfac=',expfac
5151             escloc_i=escloc_i+expfac
5152             do k=1,3
5153               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5154             enddo
5155             if (mixed) then
5156               do k=1,3,2
5157                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5158      &            +gaussc(k,2,j,it))*expfac
5159               enddo
5160             endif
5161           enddo
5162
5163         enddo ! iii
5164
5165         dersc(1)=dersc(1)/cos(theti)**2
5166         ddersc(1)=ddersc(1)/cos(theti)**2
5167         ddersc(3)=ddersc(3)
5168
5169         escloci=-(dlog(escloc_i)-emin)
5170         do j=1,3
5171           dersc(j)=dersc(j)/escloc_i
5172         enddo
5173         if (mixed) then
5174           do j=1,3,2
5175             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5176           enddo
5177         endif
5178       return
5179       end
5180 C------------------------------------------------------------------------------
5181       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5182       implicit real*8 (a-h,o-z)
5183       include 'DIMENSIONS'
5184       include 'COMMON.GEO'
5185       include 'COMMON.LOCAL'
5186       include 'COMMON.IOUNITS'
5187       common /sccalc/ time11,time12,time112,theti,it,nlobit
5188       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5189       double precision contr(maxlob)
5190       logical mixed
5191
5192       escloc_i=0.0D0
5193
5194       do j=1,3
5195         dersc(j)=0.0D0
5196       enddo
5197
5198       do j=1,nlobit
5199         do k=1,2
5200           z(k)=x(k)-censc(k,j,it)
5201         enddo
5202         z(3)=dwapi
5203         do k=1,3
5204           Axk=0.0D0
5205           do l=1,3
5206             Axk=Axk+gaussc(l,k,j,it)*z(l)
5207           enddo
5208           Ax(k,j)=Axk
5209         enddo
5210         expfac=0.0D0
5211         do k=1,3
5212           expfac=expfac+Ax(k,j)*z(k)
5213         enddo
5214         contr(j)=expfac
5215       enddo ! j
5216
5217 C As in the case of ebend, we want to avoid underflows in exponentiation and
5218 C subsequent NaNs and INFs in energy calculation.
5219 C Find the largest exponent
5220       emin=contr(1)
5221       do j=1,nlobit
5222         if (emin.gt.contr(j)) emin=contr(j)
5223       enddo
5224       emin=0.5D0*emin
5225
5226 C Compute the contribution to SC energy and derivatives
5227
5228       dersc12=0.0d0
5229       do j=1,nlobit
5230         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5231         escloc_i=escloc_i+expfac
5232         do k=1,2
5233           dersc(k)=dersc(k)+Ax(k,j)*expfac
5234         enddo
5235         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5236      &            +gaussc(1,2,j,it))*expfac
5237         dersc(3)=0.0d0
5238       enddo
5239
5240       dersc(1)=dersc(1)/cos(theti)**2
5241       dersc12=dersc12/cos(theti)**2
5242       escloci=-(dlog(escloc_i)-emin)
5243       do j=1,2
5244         dersc(j)=dersc(j)/escloc_i
5245       enddo
5246       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5247       return
5248       end
5249 #else
5250 c----------------------------------------------------------------------------------
5251       subroutine esc(escloc)
5252 C Calculate the local energy of a side chain and its derivatives in the
5253 C corresponding virtual-bond valence angles THETA and the spherical angles
5254 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5255 C added by Urszula Kozlowska. 07/11/2007
5256 C
5257       implicit real*8 (a-h,o-z)
5258       include 'DIMENSIONS'
5259       include 'COMMON.GEO'
5260       include 'COMMON.LOCAL'
5261       include 'COMMON.VAR'
5262       include 'COMMON.SCROT'
5263       include 'COMMON.INTERACT'
5264       include 'COMMON.DERIV'
5265       include 'COMMON.CHAIN'
5266       include 'COMMON.IOUNITS'
5267       include 'COMMON.NAMES'
5268       include 'COMMON.FFIELD'
5269       include 'COMMON.CONTROL'
5270       include 'COMMON.VECTORS'
5271       double precision x_prime(3),y_prime(3),z_prime(3)
5272      &    , sumene,dsc_i,dp2_i,x(65),
5273      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5274      &    de_dxx,de_dyy,de_dzz,de_dt
5275       double precision s1_t,s1_6_t,s2_t,s2_6_t
5276       double precision
5277      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5278      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5279      & dt_dCi(3),dt_dCi1(3)
5280       common /sccalc/ time11,time12,time112,theti,it,nlobit
5281       delta=0.02d0*pi
5282       escloc=0.0D0
5283       do i=loc_start,loc_end
5284         costtab(i+1) =dcos(theta(i+1))
5285         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5286         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5287         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5288         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5289         cosfac=dsqrt(cosfac2)
5290         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5291         sinfac=dsqrt(sinfac2)
5292         it=iabs(itype(i))
5293         if (it.eq.10) goto 1
5294 c
5295 C  Compute the axes of tghe local cartesian coordinates system; store in
5296 c   x_prime, y_prime and z_prime
5297 c
5298         do j=1,3
5299           x_prime(j) = 0.00
5300           y_prime(j) = 0.00
5301           z_prime(j) = 0.00
5302         enddo
5303 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5304 C     &   dc_norm(3,i+nres)
5305         do j = 1,3
5306           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5307           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5308         enddo
5309         do j = 1,3
5310           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5311         enddo
5312 c       write (2,*) "i",i
5313 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5314 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5315 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5316 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5317 c      & " xy",scalar(x_prime(1),y_prime(1)),
5318 c      & " xz",scalar(x_prime(1),z_prime(1)),
5319 c      & " yy",scalar(y_prime(1),y_prime(1)),
5320 c      & " yz",scalar(y_prime(1),z_prime(1)),
5321 c      & " zz",scalar(z_prime(1),z_prime(1))
5322 c
5323 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5324 C to local coordinate system. Store in xx, yy, zz.
5325 c
5326         xx=0.0d0
5327         yy=0.0d0
5328         zz=0.0d0
5329         do j = 1,3
5330           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5331           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5332           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5333         enddo
5334
5335         xxtab(i)=xx
5336         yytab(i)=yy
5337         zztab(i)=zz
5338 C
5339 C Compute the energy of the ith side cbain
5340 C
5341 c        write (2,*) "xx",xx," yy",yy," zz",zz
5342         it=iabs(itype(i))
5343         do j = 1,65
5344           x(j) = sc_parmin(j,it)
5345         enddo
5346 #ifdef CHECK_COORD
5347 Cc diagnostics - remove later
5348         xx1 = dcos(alph(2))
5349         yy1 = dsin(alph(2))*dcos(omeg(2))
5350         zz1 = -dsign(1.0, dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5351         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5352      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5353      &    xx1,yy1,zz1
5354 C,"  --- ", xx_w,yy_w,zz_w
5355 c end diagnostics
5356 #endif
5357         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5358      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5359      &   + x(10)*yy*zz
5360         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5361      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5362      & + x(20)*yy*zz
5363         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5364      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5365      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5366      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5367      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5368      &  +x(40)*xx*yy*zz
5369         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5370      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5371      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5372      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5373      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5374      &  +x(60)*xx*yy*zz
5375         dsc_i   = 0.743d0+x(61)
5376         dp2_i   = 1.9d0+x(62)
5377         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5378      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5379         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5380      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5381         s1=(1+x(63))/(0.1d0 + dscp1)
5382         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5383         s2=(1+x(65))/(0.1d0 + dscp2)
5384         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5385         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5386      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5387 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5388 c     &   sumene4,
5389 c     &   dscp1,dscp2,sumene
5390 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5391         escloc = escloc + sumene
5392 c        write (2,*) "i",i," escloc",sumene,escloc
5393 #ifdef DEBUG
5394 C
5395 C This section to check the numerical derivatives of the energy of ith side
5396 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5397 C #define DEBUG in the code to turn it on.
5398 C
5399         write (2,*) "sumene               =",sumene
5400         aincr=1.0d-7
5401         xxsave=xx
5402         xx=xx+aincr
5403         write (2,*) xx,yy,zz
5404         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5405         de_dxx_num=(sumenep-sumene)/aincr
5406         xx=xxsave
5407         write (2,*) "xx+ sumene from enesc=",sumenep
5408         yysave=yy
5409         yy=yy+aincr
5410         write (2,*) xx,yy,zz
5411         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5412         de_dyy_num=(sumenep-sumene)/aincr
5413         yy=yysave
5414         write (2,*) "yy+ sumene from enesc=",sumenep
5415         zzsave=zz
5416         zz=zz+aincr
5417         write (2,*) xx,yy,zz
5418         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5419         de_dzz_num=(sumenep-sumene)/aincr
5420         zz=zzsave
5421         write (2,*) "zz+ sumene from enesc=",sumenep
5422         costsave=cost2tab(i+1)
5423         sintsave=sint2tab(i+1)
5424         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5425         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5426         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5427         de_dt_num=(sumenep-sumene)/aincr
5428         write (2,*) " t+ sumene from enesc=",sumenep
5429         cost2tab(i+1)=costsave
5430         sint2tab(i+1)=sintsave
5431 C End of diagnostics section.
5432 #endif
5433 C
5434 C Compute the gradient of esc
5435 C
5436         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5437         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5438         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5439         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5440         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5441         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5442         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5443         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5444         pom1=(sumene3*sint2tab(i+1)+sumene1)
5445      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5446         pom2=(sumene4*cost2tab(i+1)+sumene2)
5447      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5448         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5449         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5450      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5451      &  +x(40)*yy*zz
5452         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5453         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5454      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5455      &  +x(60)*yy*zz
5456         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5457      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5458      &        +(pom1+pom2)*pom_dx
5459 #ifdef DEBUG
5460         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5461 #endif
5462 C
5463         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5464         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5465      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5466      &  +x(40)*xx*zz
5467         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5468         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5469      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5470      &  +x(59)*zz**2 +x(60)*xx*zz
5471         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5472      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5473      &        +(pom1-pom2)*pom_dy
5474 #ifdef DEBUG
5475         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5476 #endif
5477 C
5478         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5479      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5480      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5481      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5482      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5483      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5484      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5485      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5486 #ifdef DEBUG
5487         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5488 #endif
5489 C
5490         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5491      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5492      &  +pom1*pom_dt1+pom2*pom_dt2
5493 #ifdef DEBUG
5494         write(2,*), "de_dt = ", de_dt,de_dt_num
5495 #endif
5496 c
5497 C
5498        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5499        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5500        cosfac2xx=cosfac2*xx
5501        sinfac2yy=sinfac2*yy
5502        do k = 1,3
5503          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5504      &      vbld_inv(i+1)
5505          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5506      &      vbld_inv(i)
5507          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5508          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5509 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5510 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5511 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5512 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5513          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5514          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5515          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5516          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5517          dZZ_Ci1(k)=0.0d0
5518          dZZ_Ci(k)=0.0d0
5519          do j=1,3
5520            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5521      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5522            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5523      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5524          enddo
5525
5526          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5527          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5528          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5529 c
5530          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5531          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5532        enddo
5533
5534        do k=1,3
5535          dXX_Ctab(k,i)=dXX_Ci(k)
5536          dXX_C1tab(k,i)=dXX_Ci1(k)
5537          dYY_Ctab(k,i)=dYY_Ci(k)
5538          dYY_C1tab(k,i)=dYY_Ci1(k)
5539          dZZ_Ctab(k,i)=dZZ_Ci(k)
5540          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5541          dXX_XYZtab(k,i)=dXX_XYZ(k)
5542          dYY_XYZtab(k,i)=dYY_XYZ(k)
5543          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5544        enddo
5545
5546        do k = 1,3
5547 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5548 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5549 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5550 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5551 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5552 c     &    dt_dci(k)
5553 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5554 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5555          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5556      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5557          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5558      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5559          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5560      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5561        enddo
5562 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5563 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5564
5565 C to check gradient call subroutine check_grad
5566
5567     1 continue
5568       enddo
5569       return
5570       end
5571 c------------------------------------------------------------------------------
5572       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5573       implicit none
5574       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5575      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5576       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5577      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5578      &   + x(10)*yy*zz
5579       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5580      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5581      & + x(20)*yy*zz
5582       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5583      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5584      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5585      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5586      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5587      &  +x(40)*xx*yy*zz
5588       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5589      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5590      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5591      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5592      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5593      &  +x(60)*xx*yy*zz
5594       dsc_i   = 0.743d0+x(61)
5595       dp2_i   = 1.9d0+x(62)
5596       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5597      &          *(xx*cost2+yy*sint2))
5598       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5599      &          *(xx*cost2-yy*sint2))
5600       s1=(1+x(63))/(0.1d0 + dscp1)
5601       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5602       s2=(1+x(65))/(0.1d0 + dscp2)
5603       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5604       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5605      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5606       enesc=sumene
5607       return
5608       end
5609 #endif
5610 c------------------------------------------------------------------------------
5611       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5612 C
5613 C This procedure calculates two-body contact function g(rij) and its derivative:
5614 C
5615 C           eps0ij                                     !       x < -1
5616 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5617 C            0                                         !       x > 1
5618 C
5619 C where x=(rij-r0ij)/delta
5620 C
5621 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5622 C
5623       implicit none
5624       double precision rij,r0ij,eps0ij,fcont,fprimcont
5625       double precision x,x2,x4,delta
5626 c     delta=0.02D0*r0ij
5627 c      delta=0.2D0*r0ij
5628       x=(rij-r0ij)/delta
5629       if (x.lt.-1.0D0) then
5630         fcont=eps0ij
5631         fprimcont=0.0D0
5632       else if (x.le.1.0D0) then
5633         x2=x*x
5634         x4=x2*x2
5635         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5636         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5637       else
5638         fcont=0.0D0
5639         fprimcont=0.0D0
5640       endif
5641       return
5642       end
5643 c------------------------------------------------------------------------------
5644       subroutine splinthet(theti,delta,ss,ssder)
5645       implicit real*8 (a-h,o-z)
5646       include 'DIMENSIONS'
5647       include 'COMMON.VAR'
5648       include 'COMMON.GEO'
5649       thetup=pi-delta
5650       thetlow=delta
5651       if (theti.gt.pipol) then
5652         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5653       else
5654         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5655         ssder=-ssder
5656       endif
5657       return
5658       end
5659 c------------------------------------------------------------------------------
5660       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5661       implicit none
5662       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5663       double precision ksi,ksi2,ksi3,a1,a2,a3
5664       a1=fprim0*delta/(f1-f0)
5665       a2=3.0d0-2.0d0*a1
5666       a3=a1-2.0d0
5667       ksi=(x-x0)/delta
5668       ksi2=ksi*ksi
5669       ksi3=ksi2*ksi
5670       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5671       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5672       return
5673       end
5674 c------------------------------------------------------------------------------
5675       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5676       implicit none
5677       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5678       double precision ksi,ksi2,ksi3,a1,a2,a3
5679       ksi=(x-x0)/delta
5680       ksi2=ksi*ksi
5681       ksi3=ksi2*ksi
5682       a1=fprim0x*delta
5683       a2=3*(f1x-f0x)-2*fprim0x*delta
5684       a3=fprim0x*delta-2*(f1x-f0x)
5685       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5686       return
5687       end
5688 C-----------------------------------------------------------------------------
5689 #ifdef CRYST_TOR
5690 C-----------------------------------------------------------------------------
5691       subroutine etor(etors,edihcnstr)
5692       implicit real*8 (a-h,o-z)
5693       include 'DIMENSIONS'
5694       include 'COMMON.VAR'
5695       include 'COMMON.GEO'
5696       include 'COMMON.LOCAL'
5697       include 'COMMON.TORSION'
5698       include 'COMMON.INTERACT'
5699       include 'COMMON.DERIV'
5700       include 'COMMON.CHAIN'
5701       include 'COMMON.NAMES'
5702       include 'COMMON.IOUNITS'
5703       include 'COMMON.FFIELD'
5704       include 'COMMON.TORCNSTR'
5705       include 'COMMON.CONTROL'
5706       logical lprn
5707 C Set lprn=.true. for debugging
5708       lprn=.false.
5709 c      lprn=.true.
5710       etors=0.0D0
5711       do i=iphi_start,iphi_end
5712       etors_ii=0.0D0
5713         itori=itortyp(itype(i-2))
5714         itori1=itortyp(itype(i-1))
5715         phii=phi(i)
5716         gloci=0.0D0
5717 C Proline-Proline pair is a special case...
5718         if (itori.eq.3 .and. itori1.eq.3) then
5719           if (phii.gt.-dwapi3) then
5720             cosphi=dcos(3*phii)
5721             fac=1.0D0/(1.0D0-cosphi)
5722             etorsi=v1(1,3,3)*fac
5723             etorsi=etorsi+etorsi
5724             etors=etors+etorsi-v1(1,3,3)
5725             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5726             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5727           endif
5728           do j=1,3
5729             v1ij=v1(j+1,itori,itori1)
5730             v2ij=v2(j+1,itori,itori1)
5731             cosphi=dcos(j*phii)
5732             sinphi=dsin(j*phii)
5733             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5734             if (energy_dec) etors_ii=etors_ii+
5735      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5736             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5737           enddo
5738         else
5739           do j=1,nterm_old
5740             v1ij=v1(j,itori,itori1)
5741             v2ij=v2(j,itori,itori1)
5742             cosphi=dcos(j*phii)
5743             sinphi=dsin(j*phii)
5744             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5745             if (energy_dec) etors_ii=etors_ii+
5746      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5747             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5748           enddo
5749         endif
5750         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5751      &        'etor',i,etors_ii
5752         if (lprn)
5753      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5754      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5755      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5756         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5757         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5758       enddo
5759 ! 6/20/98 - dihedral angle constraints
5760       edihcnstr=0.0d0
5761       do i=1,ndih_constr
5762         itori=idih_constr(i)
5763         phii=phi(itori)
5764         difi=phii-phi0(i)
5765         if (difi.gt.drange(i)) then
5766           difi=difi-drange(i)
5767           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5768           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5769         else if (difi.lt.-drange(i)) then
5770           difi=difi+drange(i)
5771           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5772           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5773         endif
5774 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5775 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5776       enddo
5777 !      write (iout,*) 'edihcnstr',edihcnstr
5778       return
5779       end
5780 c------------------------------------------------------------------------------
5781       subroutine etor_d(etors_d)
5782       etors_d=0.0d0
5783       return
5784       end
5785 c----------------------------------------------------------------------------
5786 #else
5787       subroutine etor(etors,edihcnstr)
5788       implicit real*8 (a-h,o-z)
5789       include 'DIMENSIONS'
5790       include 'COMMON.VAR'
5791       include 'COMMON.GEO'
5792       include 'COMMON.LOCAL'
5793       include 'COMMON.TORSION'
5794       include 'COMMON.INTERACT'
5795       include 'COMMON.DERIV'
5796       include 'COMMON.CHAIN'
5797       include 'COMMON.NAMES'
5798       include 'COMMON.IOUNITS'
5799       include 'COMMON.FFIELD'
5800       include 'COMMON.TORCNSTR'
5801       include 'COMMON.CONTROL'
5802       logical lprn
5803 C Set lprn=.true. for debugging
5804       lprn=.false.
5805 c     lprn=.true.
5806       etors=0.0D0
5807       do i=iphi_start,iphi_end
5808       etors_ii=0.0D0
5809 c        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5810 c     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5811         itori=itortyp(itype(i-2))
5812         itori1=itortyp(itype(i-1))
5813         if (iabs(itype(i)).eq.20) then
5814         iblock=2
5815         else
5816         iblock=1
5817         endif
5818         phii=phi(i)
5819         gloci=0.0D0
5820 C Regular cosine and sine terms
5821         do j=1,nterm(itori,itori1,iblock)
5822           v1ij=v1(j,itori,itori1,iblock)
5823           v2ij=v2(j,itori,itori1,iblock)
5824           cosphi=dcos(j*phii)
5825           sinphi=dsin(j*phii)
5826           etors=etors+v1ij*cosphi+v2ij*sinphi
5827           if (energy_dec) etors_ii=etors_ii+
5828      &                v1ij*cosphi+v2ij*sinphi
5829           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5830         enddo
5831 C Lorentz terms
5832 C                         v1
5833 C  E = SUM ----------------------------------- - v1
5834 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5835 C
5836         cosphi=dcos(0.5d0*phii)
5837         sinphi=dsin(0.5d0*phii)
5838         do j=1,nlor(itori,itori1,iblock)
5839           vl1ij=vlor1(j,itori,itori1)
5840           vl2ij=vlor2(j,itori,itori1)
5841           vl3ij=vlor3(j,itori,itori1)
5842           pom=vl2ij*cosphi+vl3ij*sinphi
5843           pom1=1.0d0/(pom*pom+1.0d0)
5844           etors=etors+vl1ij*pom1
5845           if (energy_dec) etors_ii=etors_ii+
5846      &                vl1ij*pom1
5847           pom=-pom*pom1*pom1
5848           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5849         enddo
5850 C Subtract the constant term
5851         etors=etors-v0(itori,itori1,iblock)
5852           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5853      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5854         if (lprn)
5855      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5856      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5857      &  (v1(j,itori,itori1,iblock),j=1,6),
5858      &  (v2(j,itori,itori1,iblock),j=1,6)
5859         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5860 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5861       enddo
5862 ! 6/20/98 - dihedral angle constraints
5863       edihcnstr=0.0d0
5864 c      do i=1,ndih_constr
5865       do i=idihconstr_start,idihconstr_end
5866         itori=idih_constr(i)
5867         phii=phi(itori)
5868         difi=pinorm(phii-phi0(i))
5869         if (difi.gt.drange(i)) then
5870           difi=difi-drange(i)
5871           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5872           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5873         else if (difi.lt.-drange(i)) then
5874           difi=difi+drange(i)
5875           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5876           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5877         else
5878           difi=0.0
5879         endif
5880 c        write (iout,*) "gloci", gloc(i-3,icg)
5881 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5882 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5883 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5884       enddo
5885 cd       write (iout,*) 'edihcnstr',edihcnstr
5886       return
5887       end
5888 c----------------------------------------------------------------------------
5889       subroutine etor_d(etors_d)
5890 C 6/23/01 Compute double torsional energy
5891       implicit real*8 (a-h,o-z)
5892       include 'DIMENSIONS'
5893       include 'COMMON.VAR'
5894       include 'COMMON.GEO'
5895       include 'COMMON.LOCAL'
5896       include 'COMMON.TORSION'
5897       include 'COMMON.INTERACT'
5898       include 'COMMON.DERIV'
5899       include 'COMMON.CHAIN'
5900       include 'COMMON.NAMES'
5901       include 'COMMON.IOUNITS'
5902       include 'COMMON.FFIELD'
5903       include 'COMMON.TORCNSTR'
5904       logical lprn
5905 C Set lprn=.true. for debugging
5906       lprn=.false.
5907 c     lprn=.true.
5908       etors_d=0.0D0
5909       do i=iphid_start,iphid_end
5910 c        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5911 c     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5912         itori=itortyp(itype(i-2))
5913         itori1=itortyp(itype(i-1))
5914         itori2=itortyp(itype(i))
5915         iblock=1
5916         if (iabs(itype(i+1)).eq.20) iblock=2
5917         phii=phi(i)
5918         phii1=phi(i+1)
5919         gloci1=0.0D0
5920         gloci2=0.0D0
5921         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5922           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5923           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5924           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5925           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5926           cosphi1=dcos(j*phii)
5927           sinphi1=dsin(j*phii)
5928           cosphi2=dcos(j*phii1)
5929           sinphi2=dsin(j*phii1)
5930           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5931      &     v2cij*cosphi2+v2sij*sinphi2
5932           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5933           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5934         enddo
5935         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5936           do l=1,k-1
5937             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5938             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5939             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5940             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5941             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5942             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5943             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5944             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5945             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5946      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5947             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5948      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5949             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5950      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5951           enddo
5952         enddo
5953         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5954         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5955 c        write (iout,*) "gloci", gloc(i-3,icg)
5956       enddo
5957       return
5958       end
5959 #endif
5960 c------------------------------------------------------------------------------
5961       subroutine eback_sc_corr(esccor)
5962 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5963 c        conformational states; temporarily implemented as differences
5964 c        between UNRES torsional potentials (dependent on three types of
5965 c        residues) and the torsional potentials dependent on all 20 types
5966 c        of residues computed from AM1  energy surfaces of terminally-blocked
5967 c        amino-acid residues.
5968       implicit real*8 (a-h,o-z)
5969       include 'DIMENSIONS'
5970       include 'COMMON.VAR'
5971       include 'COMMON.GEO'
5972       include 'COMMON.LOCAL'
5973       include 'COMMON.TORSION'
5974       include 'COMMON.SCCOR'
5975       include 'COMMON.INTERACT'
5976       include 'COMMON.DERIV'
5977       include 'COMMON.CHAIN'
5978       include 'COMMON.NAMES'
5979       include 'COMMON.IOUNITS'
5980       include 'COMMON.FFIELD'
5981       include 'COMMON.CONTROL'
5982       logical lprn
5983 C Set lprn=.true. for debugging
5984       lprn=.false.
5985 c      lprn=.true.
5986 c     write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5987       esccor=0.0D0
5988       do i=itau_start,itau_end
5989         esccor_ii=0.0D0
5990         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5991         isccori=isccortyp(itype(i-2))
5992         isccori1=isccortyp(itype(i-1))
5993         phii=phi(i)
5994 cccc  Added 9 May 2012
5995 cc Tauangle is torsional engle depending on the value of first digit
5996 c(see comment below)
5997 cc Omicron is flat angle depending on the value of first digit
5998 c(see comment below)
5999
6000
6001         do intertyp=1,3 !intertyp
6002 cc Added 09 May 2012 (Adasko)
6003 cc  Intertyp means interaction type of backbone mainchain correlation:
6004 c   1 = SC...Ca...Ca...Ca
6005 c   2 = Ca...Ca...Ca...SC
6006 c   3 = SC...Ca...Ca...SCi
6007         gloci=0.0D0
6008         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6009      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6010      &      (itype(i-1).eq.ntyp1)))
6011      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6012      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6013      &     .or.(itype(i).eq.ntyp1)))
6014      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6015      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6016      &      (itype(i-3).eq.ntyp1)))) cycle
6017         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6018         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6019      & cycle
6020         do j=1,nterm_sccor(isccori,isccori1)
6021           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6022           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6023           cosphi=dcos(j*tauangle(intertyp,i))
6024           sinphi=dsin(j*tauangle(intertyp,i))
6025           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6026           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6027         enddo
6028         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6029 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6030 c     &gloc_sc(intertyp,i-3,icg)
6031         if (lprn)
6032      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6033      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6034      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6035      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6036         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6037        enddo !intertyp
6038       enddo
6039 c        do i=1,nres
6040 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6041 c        enddo
6042       return
6043       end
6044 c----------------------------------------------------------------------------
6045       subroutine multibody(ecorr)
6046 C This subroutine calculates multi-body contributions to energy following
6047 C the idea of Skolnick et al. If side chains I and J make a contact and
6048 C at the same time side chains I+1 and J+1 make a contact, an extra
6049 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6050       implicit real*8 (a-h,o-z)
6051       include 'DIMENSIONS'
6052       include 'COMMON.IOUNITS'
6053       include 'COMMON.DERIV'
6054       include 'COMMON.INTERACT'
6055       include 'COMMON.CONTACTS'
6056       double precision gx(3),gx1(3)
6057       logical lprn
6058
6059 C Set lprn=.true. for debugging
6060       lprn=.false.
6061
6062       if (lprn) then
6063         write (iout,'(a)') 'Contact function values:'
6064         do i=nnt,nct-2
6065           write (iout,'(i2,20(1x,i2,f10.5))')
6066      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6067         enddo
6068       endif
6069       ecorr=0.0D0
6070       do i=nnt,nct
6071         do j=1,3
6072           gradcorr(j,i)=0.0D0
6073           gradxorr(j,i)=0.0D0
6074         enddo
6075       enddo
6076       do i=nnt,nct-2
6077
6078         DO ISHIFT = 3,4
6079
6080         i1=i+ishift
6081         num_conti=num_cont(i)
6082         num_conti1=num_cont(i1)
6083         do jj=1,num_conti
6084           j=jcont(jj,i)
6085           do kk=1,num_conti1
6086             j1=jcont(kk,i1)
6087             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6088 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6089 cd   &                   ' ishift=',ishift
6090 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6091 C The system gains extra energy.
6092               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6093             endif   ! j1==j+-ishift
6094           enddo     ! kk
6095         enddo       ! jj
6096
6097         ENDDO ! ISHIFT
6098
6099       enddo         ! i
6100       return
6101       end
6102 c------------------------------------------------------------------------------
6103       double precision function esccorr(i,j,k,l,jj,kk)
6104       implicit real*8 (a-h,o-z)
6105       include 'DIMENSIONS'
6106       include 'COMMON.IOUNITS'
6107       include 'COMMON.DERIV'
6108       include 'COMMON.INTERACT'
6109       include 'COMMON.CONTACTS'
6110       double precision gx(3),gx1(3)
6111       logical lprn
6112       lprn=.false.
6113       eij=facont(jj,i)
6114       ekl=facont(kk,k)
6115 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6116 C Calculate the multi-body contribution to energy.
6117 C Calculate multi-body contributions to the gradient.
6118 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6119 cd   & k,l,(gacont(m,kk,k),m=1,3)
6120       do m=1,3
6121         gx(m) =ekl*gacont(m,jj,i)
6122         gx1(m)=eij*gacont(m,kk,k)
6123         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6124         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6125         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6126         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6127       enddo
6128       do m=i,j-1
6129         do ll=1,3
6130           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6131         enddo
6132       enddo
6133       do m=k,l-1
6134         do ll=1,3
6135           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6136         enddo
6137       enddo
6138       esccorr=-eij*ekl
6139       return
6140       end
6141 c------------------------------------------------------------------------------
6142       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6143 C This subroutine calculates multi-body contributions to hydrogen-bonding
6144       implicit real*8 (a-h,o-z)
6145       include 'DIMENSIONS'
6146       include 'COMMON.IOUNITS'
6147 #ifdef MPI
6148       include "mpif.h"
6149       parameter (max_cont=maxconts)
6150       parameter (max_dim=26)
6151       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6152       double precision zapas(max_dim,maxconts,max_fg_procs),
6153      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6154       common /przechowalnia/ zapas
6155       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6156      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6157 #endif
6158       include 'COMMON.SETUP'
6159       include 'COMMON.FFIELD'
6160       include 'COMMON.DERIV'
6161       include 'COMMON.INTERACT'
6162       include 'COMMON.CONTACTS'
6163       include 'COMMON.CONTROL'
6164       include 'COMMON.LOCAL'
6165       double precision gx(3),gx1(3),time00
6166       logical lprn,ldone
6167
6168 C Set lprn=.true. for debugging
6169       lprn=.false.
6170 #ifdef MPI
6171       n_corr=0
6172       n_corr1=0
6173       if (nfgtasks.le.1) goto 30
6174       if (lprn) then
6175         write (iout,'(a)') 'Contact function values before RECEIVE:'
6176         do i=nnt,nct-2
6177           write (iout,'(2i3,50(1x,i2,f5.2))')
6178      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6179      &    j=1,num_cont_hb(i))
6180         enddo
6181       endif
6182       call flush(iout)
6183       do i=1,ntask_cont_from
6184         ncont_recv(i)=0
6185       enddo
6186       do i=1,ntask_cont_to
6187         ncont_sent(i)=0
6188       enddo
6189 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6190 c     & ntask_cont_to
6191 C Make the list of contacts to send to send to other procesors
6192 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6193 c      call flush(iout)
6194       do i=iturn3_start,iturn3_end
6195 c        write (iout,*) "make contact list turn3",i," num_cont",
6196 c     &    num_cont_hb(i)
6197         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6198       enddo
6199       do i=iturn4_start,iturn4_end
6200 c        write (iout,*) "make contact list turn4",i," num_cont",
6201 c     &   num_cont_hb(i)
6202         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6203       enddo
6204       do ii=1,nat_sent
6205         i=iat_sent(ii)
6206 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6207 c     &    num_cont_hb(i)
6208         do j=1,num_cont_hb(i)
6209         do k=1,4
6210           jjc=jcont_hb(j,i)
6211           iproc=iint_sent_local(k,jjc,ii)
6212 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6213           if (iproc.gt.0) then
6214             ncont_sent(iproc)=ncont_sent(iproc)+1
6215             nn=ncont_sent(iproc)
6216             zapas(1,nn,iproc)=i
6217             zapas(2,nn,iproc)=jjc
6218             zapas(3,nn,iproc)=facont_hb(j,i)
6219             zapas(4,nn,iproc)=ees0p(j,i)
6220             zapas(5,nn,iproc)=ees0m(j,i)
6221             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6222             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6223             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6224             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6225             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6226             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6227             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6228             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6229             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6230             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6231             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6232             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6233             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6234             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6235             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6236             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6237             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6238             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6239             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6240             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6241             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6242           endif
6243         enddo
6244         enddo
6245       enddo
6246       if (lprn) then
6247       write (iout,*)
6248      &  "Numbers of contacts to be sent to other processors",
6249      &  (ncont_sent(i),i=1,ntask_cont_to)
6250       write (iout,*) "Contacts sent"
6251       do ii=1,ntask_cont_to
6252         nn=ncont_sent(ii)
6253         iproc=itask_cont_to(ii)
6254         write (iout,*) nn," contacts to processor",iproc,
6255      &   " of CONT_TO_COMM group"
6256         do i=1,nn
6257           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6258         enddo
6259       enddo
6260       call flush(iout)
6261       endif
6262       CorrelType=477
6263       CorrelID=fg_rank+1
6264       CorrelType1=478
6265       CorrelID1=nfgtasks+fg_rank+1
6266       ireq=0
6267 C Receive the numbers of needed contacts from other processors
6268       do ii=1,ntask_cont_from
6269         iproc=itask_cont_from(ii)
6270         ireq=ireq+1
6271         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6272      &    FG_COMM,req(ireq),IERR)
6273       enddo
6274 c      write (iout,*) "IRECV ended"
6275 c      call flush(iout)
6276 C Send the number of contacts needed by other processors
6277       do ii=1,ntask_cont_to
6278         iproc=itask_cont_to(ii)
6279         ireq=ireq+1
6280         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6281      &    FG_COMM,req(ireq),IERR)
6282       enddo
6283 c      write (iout,*) "ISEND ended"
6284 c      write (iout,*) "number of requests (nn)",ireq
6285       call flush(iout)
6286       if (ireq.gt.0)
6287      &  call MPI_Waitall(ireq,req,status_array,ierr)
6288 c      write (iout,*)
6289 c     &  "Numbers of contacts to be received from other processors",
6290 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6291 c      call flush(iout)
6292 C Receive contacts
6293       ireq=0
6294       do ii=1,ntask_cont_from
6295         iproc=itask_cont_from(ii)
6296         nn=ncont_recv(ii)
6297 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6298 c     &   " of CONT_TO_COMM group"
6299         call flush(iout)
6300         if (nn.gt.0) then
6301           ireq=ireq+1
6302           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6303      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6304 c          write (iout,*) "ireq,req",ireq,req(ireq)
6305         endif
6306       enddo
6307 C Send the contacts to processors that need them
6308       do ii=1,ntask_cont_to
6309         iproc=itask_cont_to(ii)
6310         nn=ncont_sent(ii)
6311 c        write (iout,*) nn," contacts to processor",iproc,
6312 c     &   " of CONT_TO_COMM group"
6313         if (nn.gt.0) then
6314           ireq=ireq+1
6315           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6316      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6317 c          write (iout,*) "ireq,req",ireq,req(ireq)
6318 c          do i=1,nn
6319 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6320 c          enddo
6321         endif
6322       enddo
6323 c      write (iout,*) "number of requests (contacts)",ireq
6324 c      write (iout,*) "req",(req(i),i=1,4)
6325 c      call flush(iout)
6326       if (ireq.gt.0)
6327      & call MPI_Waitall(ireq,req,status_array,ierr)
6328       do iii=1,ntask_cont_from
6329         iproc=itask_cont_from(iii)
6330         nn=ncont_recv(iii)
6331         if (lprn) then
6332         write (iout,*) "Received",nn," contacts from processor",iproc,
6333      &   " of CONT_FROM_COMM group"
6334         call flush(iout)
6335         do i=1,nn
6336           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6337         enddo
6338         call flush(iout)
6339         endif
6340         do i=1,nn
6341           ii=zapas_recv(1,i,iii)
6342 c Flag the received contacts to prevent double-counting
6343           jj=-zapas_recv(2,i,iii)
6344 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6345 c          call flush(iout)
6346           nnn=num_cont_hb(ii)+1
6347           num_cont_hb(ii)=nnn
6348           jcont_hb(nnn,ii)=jj
6349           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6350           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6351           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6352           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6353           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6354           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6355           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6356           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6357           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6358           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6359           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6360           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6361           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6362           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6363           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6364           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6365           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6366           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6367           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6368           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6369           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6370           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6371           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6372           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6373         enddo
6374       enddo
6375       call flush(iout)
6376       if (lprn) then
6377         write (iout,'(a)') 'Contact function values after receive:'
6378         do i=nnt,nct-2
6379           write (iout,'(2i3,50(1x,i3,f5.2))')
6380      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6381      &    j=1,num_cont_hb(i))
6382         enddo
6383         call flush(iout)
6384       endif
6385    30 continue
6386 #endif
6387       if (lprn) then
6388         write (iout,'(a)') 'Contact function values:'
6389         do i=nnt,nct-2
6390           write (iout,'(2i3,50(1x,i3,f5.2))')
6391      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6392      &    j=1,num_cont_hb(i))
6393         enddo
6394       endif
6395       ecorr=0.0D0
6396 C Remove the loop below after debugging !!!
6397       do i=nnt,nct
6398         do j=1,3
6399           gradcorr(j,i)=0.0D0
6400           gradxorr(j,i)=0.0D0
6401         enddo
6402       enddo
6403 C Calculate the local-electrostatic correlation terms
6404       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6405         i1=i+1
6406         num_conti=num_cont_hb(i)
6407         num_conti1=num_cont_hb(i+1)
6408         do jj=1,num_conti
6409           j=jcont_hb(jj,i)
6410           jp=iabs(j)
6411           do kk=1,num_conti1
6412             j1=jcont_hb(kk,i1)
6413             jp1=iabs(j1)
6414 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6415 c     &         ' jj=',jj,' kk=',kk
6416             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6417      &          .or. j.lt.0 .and. j1.gt.0) .and.
6418      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6419 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6420 C The system gains extra energy.
6421               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6422               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6423      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6424               n_corr=n_corr+1
6425             else if (j1.eq.j) then
6426 C Contacts I-J and I-(J+1) occur simultaneously.
6427 C The system loses extra energy.
6428 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6429             endif
6430           enddo ! kk
6431           do kk=1,num_conti
6432             j1=jcont_hb(kk,i)
6433 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6434 c    &         ' jj=',jj,' kk=',kk
6435             if (j1.eq.j+1) then
6436 C Contacts I-J and (I+1)-J occur simultaneously.
6437 C The system loses extra energy.
6438 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6439             endif ! j1==j+1
6440           enddo ! kk
6441         enddo ! jj
6442       enddo ! i
6443       return
6444       end
6445 c------------------------------------------------------------------------------
6446       subroutine add_hb_contact(ii,jj,itask)
6447       implicit real*8 (a-h,o-z)
6448       include "DIMENSIONS"
6449       include "COMMON.IOUNITS"
6450       integer max_cont
6451       integer max_dim
6452       parameter (max_cont=maxconts)
6453       parameter (max_dim=26)
6454       include "COMMON.CONTACTS"
6455       double precision zapas(max_dim,maxconts,max_fg_procs),
6456      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6457       common /przechowalnia/ zapas
6458       integer i,j,ii,jj,iproc,itask(4),nn
6459 c      write (iout,*) "itask",itask
6460       do i=1,2
6461         iproc=itask(i)
6462         if (iproc.gt.0) then
6463           do j=1,num_cont_hb(ii)
6464             jjc=jcont_hb(j,ii)
6465 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6466             if (jjc.eq.jj) then
6467               ncont_sent(iproc)=ncont_sent(iproc)+1
6468               nn=ncont_sent(iproc)
6469               zapas(1,nn,iproc)=ii
6470               zapas(2,nn,iproc)=jjc
6471               zapas(3,nn,iproc)=facont_hb(j,ii)
6472               zapas(4,nn,iproc)=ees0p(j,ii)
6473               zapas(5,nn,iproc)=ees0m(j,ii)
6474               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6475               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6476               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6477               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6478               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6479               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6480               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6481               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6482               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6483               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6484               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6485               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6486               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6487               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6488               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6489               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6490               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6491               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6492               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6493               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6494               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6495               exit
6496             endif
6497           enddo
6498         endif
6499       enddo
6500       return
6501       end
6502 c------------------------------------------------------------------------------
6503       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6504      &  n_corr1)
6505 C This subroutine calculates multi-body contributions to hydrogen-bonding
6506       implicit real*8 (a-h,o-z)
6507       include 'DIMENSIONS'
6508       include 'COMMON.IOUNITS'
6509 #ifdef MPI
6510       include "mpif.h"
6511       parameter (max_cont=maxconts)
6512       parameter (max_dim=70)
6513       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6514       double precision zapas(max_dim,maxconts,max_fg_procs),
6515      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6516       common /przechowalnia/ zapas
6517       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6518      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6519 #endif
6520       include 'COMMON.SETUP'
6521       include 'COMMON.FFIELD'
6522       include 'COMMON.DERIV'
6523       include 'COMMON.LOCAL'
6524       include 'COMMON.INTERACT'
6525       include 'COMMON.CONTACTS'
6526       include 'COMMON.CHAIN'
6527       include 'COMMON.CONTROL'
6528       double precision gx(3),gx1(3)
6529       integer num_cont_hb_old(maxres)
6530       logical lprn,ldone
6531       double precision eello4,eello5,eelo6,eello_turn6
6532       external eello4,eello5,eello6,eello_turn6
6533 C Set lprn=.true. for debugging
6534       lprn=.false.
6535       eturn6=0.0d0
6536 #ifdef MPI
6537       do i=1,nres
6538         num_cont_hb_old(i)=num_cont_hb(i)
6539       enddo
6540       n_corr=0
6541       n_corr1=0
6542       if (nfgtasks.le.1) goto 30
6543       if (lprn) then
6544         write (iout,'(a)') 'Contact function values before RECEIVE:'
6545         do i=nnt,nct-2
6546           write (iout,'(2i3,50(1x,i2,f5.2))')
6547      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6548      &    j=1,num_cont_hb(i))
6549         enddo
6550       endif
6551       call flush(iout)
6552       do i=1,ntask_cont_from
6553         ncont_recv(i)=0
6554       enddo
6555       do i=1,ntask_cont_to
6556         ncont_sent(i)=0
6557       enddo
6558 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6559 c     & ntask_cont_to
6560 C Make the list of contacts to send to send to other procesors
6561       do i=iturn3_start,iturn3_end
6562 c        write (iout,*) "make contact list turn3",i," num_cont",
6563 c     &    num_cont_hb(i)
6564         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6565       enddo
6566       do i=iturn4_start,iturn4_end
6567 c        write (iout,*) "make contact list turn4",i," num_cont",
6568 c     &   num_cont_hb(i)
6569         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6570       enddo
6571       do ii=1,nat_sent
6572         i=iat_sent(ii)
6573 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6574 c     &    num_cont_hb(i)
6575         do j=1,num_cont_hb(i)
6576         do k=1,4
6577           jjc=jcont_hb(j,i)
6578           iproc=iint_sent_local(k,jjc,ii)
6579 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6580           if (iproc.ne.0) then
6581             ncont_sent(iproc)=ncont_sent(iproc)+1
6582             nn=ncont_sent(iproc)
6583             zapas(1,nn,iproc)=i
6584             zapas(2,nn,iproc)=jjc
6585             zapas(3,nn,iproc)=d_cont(j,i)
6586             ind=3
6587             do kk=1,3
6588               ind=ind+1
6589               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6590             enddo
6591             do kk=1,2
6592               do ll=1,2
6593                 ind=ind+1
6594                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6595               enddo
6596             enddo
6597             do jj=1,5
6598               do kk=1,3
6599                 do ll=1,2
6600                   do mm=1,2
6601                     ind=ind+1
6602                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6603                   enddo
6604                 enddo
6605               enddo
6606             enddo
6607           endif
6608         enddo
6609         enddo
6610       enddo
6611       if (lprn) then
6612       write (iout,*)
6613      &  "Numbers of contacts to be sent to other processors",
6614      &  (ncont_sent(i),i=1,ntask_cont_to)
6615       write (iout,*) "Contacts sent"
6616       do ii=1,ntask_cont_to
6617         nn=ncont_sent(ii)
6618         iproc=itask_cont_to(ii)
6619         write (iout,*) nn," contacts to processor",iproc,
6620      &   " of CONT_TO_COMM group"
6621         do i=1,nn
6622           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6623         enddo
6624       enddo
6625       call flush(iout)
6626       endif
6627       CorrelType=477
6628       CorrelID=fg_rank+1
6629       CorrelType1=478
6630       CorrelID1=nfgtasks+fg_rank+1
6631       ireq=0
6632 C Receive the numbers of needed contacts from other processors
6633       do ii=1,ntask_cont_from
6634         iproc=itask_cont_from(ii)
6635         ireq=ireq+1
6636         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6637      &    FG_COMM,req(ireq),IERR)
6638       enddo
6639 c      write (iout,*) "IRECV ended"
6640 c      call flush(iout)
6641 C Send the number of contacts needed by other processors
6642       do ii=1,ntask_cont_to
6643         iproc=itask_cont_to(ii)
6644         ireq=ireq+1
6645         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6646      &    FG_COMM,req(ireq),IERR)
6647       enddo
6648 c      write (iout,*) "ISEND ended"
6649 c      write (iout,*) "number of requests (nn)",ireq
6650       call flush(iout)
6651       if (ireq.gt.0)
6652      &  call MPI_Waitall(ireq,req,status_array,ierr)
6653 c      write (iout,*)
6654 c     &  "Numbers of contacts to be received from other processors",
6655 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6656 c      call flush(iout)
6657 C Receive contacts
6658       ireq=0
6659       do ii=1,ntask_cont_from
6660         iproc=itask_cont_from(ii)
6661         nn=ncont_recv(ii)
6662 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6663 c     &   " of CONT_TO_COMM group"
6664         call flush(iout)
6665         if (nn.gt.0) then
6666           ireq=ireq+1
6667           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6668      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6669 c          write (iout,*) "ireq,req",ireq,req(ireq)
6670         endif
6671       enddo
6672 C Send the contacts to processors that need them
6673       do ii=1,ntask_cont_to
6674         iproc=itask_cont_to(ii)
6675         nn=ncont_sent(ii)
6676 c        write (iout,*) nn," contacts to processor",iproc,
6677 c     &   " of CONT_TO_COMM group"
6678         if (nn.gt.0) then
6679           ireq=ireq+1
6680           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6681      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6682 c          write (iout,*) "ireq,req",ireq,req(ireq)
6683 c          do i=1,nn
6684 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6685 c          enddo
6686         endif
6687       enddo
6688 c      write (iout,*) "number of requests (contacts)",ireq
6689 c      write (iout,*) "req",(req(i),i=1,4)
6690 c      call flush(iout)
6691       if (ireq.gt.0)
6692      & call MPI_Waitall(ireq,req,status_array,ierr)
6693       do iii=1,ntask_cont_from
6694         iproc=itask_cont_from(iii)
6695         nn=ncont_recv(iii)
6696         if (lprn) then
6697         write (iout,*) "Received",nn," contacts from processor",iproc,
6698      &   " of CONT_FROM_COMM group"
6699         call flush(iout)
6700         do i=1,nn
6701           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6702         enddo
6703         call flush(iout)
6704         endif
6705         do i=1,nn
6706           ii=zapas_recv(1,i,iii)
6707 c Flag the received contacts to prevent double-counting
6708           jj=-zapas_recv(2,i,iii)
6709 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6710 c          call flush(iout)
6711           nnn=num_cont_hb(ii)+1
6712           num_cont_hb(ii)=nnn
6713           jcont_hb(nnn,ii)=jj
6714           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6715           ind=3
6716           do kk=1,3
6717             ind=ind+1
6718             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6719           enddo
6720           do kk=1,2
6721             do ll=1,2
6722               ind=ind+1
6723               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6724             enddo
6725           enddo
6726           do jj=1,5
6727             do kk=1,3
6728               do ll=1,2
6729                 do mm=1,2
6730                   ind=ind+1
6731                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6732                 enddo
6733               enddo
6734             enddo
6735           enddo
6736         enddo
6737       enddo
6738       call flush(iout)
6739       if (lprn) then
6740         write (iout,'(a)') 'Contact function values after receive:'
6741         do i=nnt,nct-2
6742           write (iout,'(2i3,50(1x,i3,5f6.3))')
6743      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6744      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6745         enddo
6746         call flush(iout)
6747       endif
6748    30 continue
6749 #endif
6750       if (lprn) then
6751         write (iout,'(a)') 'Contact function values:'
6752         do i=nnt,nct-2
6753           write (iout,'(2i3,50(1x,i2,5f6.3))')
6754      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6755      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6756         enddo
6757       endif
6758       ecorr=0.0D0
6759       ecorr5=0.0d0
6760       ecorr6=0.0d0
6761 C Remove the loop below after debugging !!!
6762       do i=nnt,nct
6763         do j=1,3
6764           gradcorr(j,i)=0.0D0
6765           gradxorr(j,i)=0.0D0
6766         enddo
6767       enddo
6768 C Calculate the dipole-dipole interaction energies
6769       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6770       do i=iatel_s,iatel_e+1
6771         num_conti=num_cont_hb(i)
6772         do jj=1,num_conti
6773           j=jcont_hb(jj,i)
6774 #ifdef MOMENT
6775           call dipole(i,j,jj)
6776 #endif
6777         enddo
6778       enddo
6779       endif
6780 C Calculate the local-electrostatic correlation terms
6781 c                write (iout,*) "gradcorr5 in eello5 before loop"
6782 c                do iii=1,nres
6783 c                  write (iout,'(i5,3f10.5)')
6784 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6785 c                enddo
6786       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6787 c        write (iout,*) "corr loop i",i
6788         i1=i+1
6789         num_conti=num_cont_hb(i)
6790         num_conti1=num_cont_hb(i+1)
6791         do jj=1,num_conti
6792           j=jcont_hb(jj,i)
6793           jp=iabs(j)
6794           do kk=1,num_conti1
6795             j1=jcont_hb(kk,i1)
6796             jp1=iabs(j1)
6797 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6798 c     &         ' jj=',jj,' kk=',kk
6799 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6800             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6801      &          .or. j.lt.0 .and. j1.gt.0) .and.
6802      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6803 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6804 C The system gains extra energy.
6805               n_corr=n_corr+1
6806               sqd1=dsqrt(d_cont(jj,i))
6807               sqd2=dsqrt(d_cont(kk,i1))
6808               sred_geom = sqd1*sqd2
6809               IF (sred_geom.lt.cutoff_corr) THEN
6810                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6811      &            ekont,fprimcont)
6812 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6813 cd     &         ' jj=',jj,' kk=',kk
6814                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6815                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6816                 do l=1,3
6817                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6818                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6819                 enddo
6820                 n_corr1=n_corr1+1
6821 cd               write (iout,*) 'sred_geom=',sred_geom,
6822 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6823 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6824 cd               write (iout,*) "g_contij",g_contij
6825 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6826 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6827                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6828                 if (wcorr4.gt.0.0d0)
6829      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6830                   if (energy_dec.and.wcorr4.gt.0.0d0)
6831      1                 write (iout,'(a6,4i5,0pf7.3)')
6832      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6833 c                write (iout,*) "gradcorr5 before eello5"
6834 c                do iii=1,nres
6835 c                  write (iout,'(i5,3f10.5)')
6836 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6837 c                enddo
6838                 if (wcorr5.gt.0.0d0)
6839      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6840 c                write (iout,*) "gradcorr5 after eello5"
6841 c                do iii=1,nres
6842 c                  write (iout,'(i5,3f10.5)')
6843 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6844 c                enddo
6845                   if (energy_dec.and.wcorr5.gt.0.0d0)
6846      1                 write (iout,'(a6,4i5,0pf7.3)')
6847      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6848 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6849 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6850                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6851      &               .or. wturn6.eq.0.0d0))then
6852 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6853                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6854                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6855      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6856 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6857 cd     &            'ecorr6=',ecorr6
6858 cd                write (iout,'(4e15.5)') sred_geom,
6859 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6860 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6861 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6862                 else if (wturn6.gt.0.0d0
6863      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6864 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6865                   eturn6=eturn6+eello_turn6(i,jj,kk)
6866                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6867      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6868 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6869                 endif
6870               ENDIF
6871 1111          continue
6872             endif
6873           enddo ! kk
6874         enddo ! jj
6875       enddo ! i
6876       do i=1,nres
6877         num_cont_hb(i)=num_cont_hb_old(i)
6878       enddo
6879 c                write (iout,*) "gradcorr5 in eello5"
6880 c                do iii=1,nres
6881 c                  write (iout,'(i5,3f10.5)')
6882 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6883 c                enddo
6884       return
6885       end
6886 c------------------------------------------------------------------------------
6887       subroutine add_hb_contact_eello(ii,jj,itask)
6888       implicit real*8 (a-h,o-z)
6889       include "DIMENSIONS"
6890       include "COMMON.IOUNITS"
6891       integer max_cont
6892       integer max_dim
6893       parameter (max_cont=maxconts)
6894       parameter (max_dim=70)
6895       include "COMMON.CONTACTS"
6896       double precision zapas(max_dim,maxconts,max_fg_procs),
6897      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6898       common /przechowalnia/ zapas
6899       integer i,j,ii,jj,iproc,itask(4),nn
6900 c      write (iout,*) "itask",itask
6901       do i=1,2
6902         iproc=itask(i)
6903         if (iproc.gt.0) then
6904           do j=1,num_cont_hb(ii)
6905             jjc=jcont_hb(j,ii)
6906 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6907             if (jjc.eq.jj) then
6908               ncont_sent(iproc)=ncont_sent(iproc)+1
6909               nn=ncont_sent(iproc)
6910               zapas(1,nn,iproc)=ii
6911               zapas(2,nn,iproc)=jjc
6912               zapas(3,nn,iproc)=d_cont(j,ii)
6913               ind=3
6914               do kk=1,3
6915                 ind=ind+1
6916                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6917               enddo
6918               do kk=1,2
6919                 do ll=1,2
6920                   ind=ind+1
6921                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6922                 enddo
6923               enddo
6924               do jj=1,5
6925                 do kk=1,3
6926                   do ll=1,2
6927                     do mm=1,2
6928                       ind=ind+1
6929                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6930                     enddo
6931                   enddo
6932                 enddo
6933               enddo
6934               exit
6935             endif
6936           enddo
6937         endif
6938       enddo
6939       return
6940       end
6941 c------------------------------------------------------------------------------
6942       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6943       implicit real*8 (a-h,o-z)
6944       include 'DIMENSIONS'
6945       include 'COMMON.IOUNITS'
6946       include 'COMMON.DERIV'
6947       include 'COMMON.INTERACT'
6948       include 'COMMON.CONTACTS'
6949       double precision gx(3),gx1(3)
6950       logical lprn
6951       lprn=.false.
6952       eij=facont_hb(jj,i)
6953       ekl=facont_hb(kk,k)
6954       ees0pij=ees0p(jj,i)
6955       ees0pkl=ees0p(kk,k)
6956       ees0mij=ees0m(jj,i)
6957       ees0mkl=ees0m(kk,k)
6958       ekont=eij*ekl
6959       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6960 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6961 C Following 4 lines for diagnostics.
6962 cd    ees0pkl=0.0D0
6963 cd    ees0pij=1.0D0
6964 cd    ees0mkl=0.0D0
6965 cd    ees0mij=1.0D0
6966 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6967 c     & 'Contacts ',i,j,
6968 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6969 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6970 c     & 'gradcorr_long'
6971 C Calculate the multi-body contribution to energy.
6972 c      ecorr=ecorr+ekont*ees
6973 C Calculate multi-body contributions to the gradient.
6974       coeffpees0pij=coeffp*ees0pij
6975       coeffmees0mij=coeffm*ees0mij
6976       coeffpees0pkl=coeffp*ees0pkl
6977       coeffmees0mkl=coeffm*ees0mkl
6978       do ll=1,3
6979 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6980         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6981      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6982      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6983         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6984      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6985      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6986 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6987         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6988      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6989      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6990         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6991      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6992      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6993         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6994      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6995      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6996         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6997         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6998         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6999      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7000      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7001         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7002         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7003 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7004       enddo
7005 c      write (iout,*)
7006 cgrad      do m=i+1,j-1
7007 cgrad        do ll=1,3
7008 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7009 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7010 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7011 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7012 cgrad        enddo
7013 cgrad      enddo
7014 cgrad      do m=k+1,l-1
7015 cgrad        do ll=1,3
7016 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7017 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7018 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7019 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7020 cgrad        enddo
7021 cgrad      enddo
7022 c      write (iout,*) "ehbcorr",ekont*ees
7023       ehbcorr=ekont*ees
7024       return
7025       end
7026 #ifdef MOMENT
7027 C---------------------------------------------------------------------------
7028       subroutine dipole(i,j,jj)
7029       implicit real*8 (a-h,o-z)
7030       include 'DIMENSIONS'
7031       include 'COMMON.IOUNITS'
7032       include 'COMMON.CHAIN'
7033       include 'COMMON.FFIELD'
7034       include 'COMMON.DERIV'
7035       include 'COMMON.INTERACT'
7036       include 'COMMON.CONTACTS'
7037       include 'COMMON.TORSION'
7038       include 'COMMON.VAR'
7039       include 'COMMON.GEO'
7040       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7041      &  auxmat(2,2)
7042       iti1 = itortyp(itype(i+1))
7043       if (j.lt.nres-1) then
7044         itj1 = itortyp(itype(j+1))
7045       else
7046         itj1=ntortyp+1
7047       endif
7048       do iii=1,2
7049         dipi(iii,1)=Ub2(iii,i)
7050         dipderi(iii)=Ub2der(iii,i)
7051         dipi(iii,2)=b1(iii,iti1)
7052         dipj(iii,1)=Ub2(iii,j)
7053         dipderj(iii)=Ub2der(iii,j)
7054         dipj(iii,2)=b1(iii,itj1)
7055       enddo
7056       kkk=0
7057       do iii=1,2
7058         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7059         do jjj=1,2
7060           kkk=kkk+1
7061           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7062         enddo
7063       enddo
7064       do kkk=1,5
7065         do lll=1,3
7066           mmm=0
7067           do iii=1,2
7068             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7069      &        auxvec(1))
7070             do jjj=1,2
7071               mmm=mmm+1
7072               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7073             enddo
7074           enddo
7075         enddo
7076       enddo
7077       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7078       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7079       do iii=1,2
7080         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7081       enddo
7082       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7083       do iii=1,2
7084         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7085       enddo
7086       return
7087       end
7088 #endif
7089 C---------------------------------------------------------------------------
7090       subroutine calc_eello(i,j,k,l,jj,kk)
7091 C
7092 C This subroutine computes matrices and vectors needed to calculate
7093 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7094 C
7095       implicit real*8 (a-h,o-z)
7096       include 'DIMENSIONS'
7097       include 'COMMON.IOUNITS'
7098       include 'COMMON.CHAIN'
7099       include 'COMMON.DERIV'
7100       include 'COMMON.INTERACT'
7101       include 'COMMON.CONTACTS'
7102       include 'COMMON.TORSION'
7103       include 'COMMON.VAR'
7104       include 'COMMON.GEO'
7105       include 'COMMON.FFIELD'
7106       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7107      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7108       logical lprn
7109       common /kutas/ lprn
7110 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7111 cd     & ' jj=',jj,' kk=',kk
7112 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7113 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7114 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7115       do iii=1,2
7116         do jjj=1,2
7117           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7118           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7119         enddo
7120       enddo
7121       call transpose2(aa1(1,1),aa1t(1,1))
7122       call transpose2(aa2(1,1),aa2t(1,1))
7123       do kkk=1,5
7124         do lll=1,3
7125           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7126      &      aa1tder(1,1,lll,kkk))
7127           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7128      &      aa2tder(1,1,lll,kkk))
7129         enddo
7130       enddo
7131       if (l.eq.j+1) then
7132 C parallel orientation of the two CA-CA-CA frames.
7133         if (i.gt.1) then
7134           iti=itortyp(itype(i))
7135         else
7136           iti=ntortyp+1
7137         endif
7138         itk1=itortyp(itype(k+1))
7139         itj=itortyp(itype(j))
7140         if (l.lt.nres-1) then
7141           itl1=itortyp(itype(l+1))
7142         else
7143           itl1=ntortyp+1
7144         endif
7145 C A1 kernel(j+1) A2T
7146 cd        do iii=1,2
7147 cd          write (iout,'(3f10.5,5x,3f10.5)')
7148 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7149 cd        enddo
7150         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7151      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7152      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7153 C Following matrices are needed only for 6-th order cumulants
7154         IF (wcorr6.gt.0.0d0) THEN
7155         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7156      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7157      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7158         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7159      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7160      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7161      &   ADtEAderx(1,1,1,1,1,1))
7162         lprn=.false.
7163         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7164      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7165      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7166      &   ADtEA1derx(1,1,1,1,1,1))
7167         ENDIF
7168 C End 6-th order cumulants
7169 cd        lprn=.false.
7170 cd        if (lprn) then
7171 cd        write (2,*) 'In calc_eello6'
7172 cd        do iii=1,2
7173 cd          write (2,*) 'iii=',iii
7174 cd          do kkk=1,5
7175 cd            write (2,*) 'kkk=',kkk
7176 cd            do jjj=1,2
7177 cd              write (2,'(3(2f10.5),5x)')
7178 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7179 cd            enddo
7180 cd          enddo
7181 cd        enddo
7182 cd        endif
7183         call transpose2(EUgder(1,1,k),auxmat(1,1))
7184         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7185         call transpose2(EUg(1,1,k),auxmat(1,1))
7186         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7187         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7188         do iii=1,2
7189           do kkk=1,5
7190             do lll=1,3
7191               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7192      &          EAEAderx(1,1,lll,kkk,iii,1))
7193             enddo
7194           enddo
7195         enddo
7196 C A1T kernel(i+1) A2
7197         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7198      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7199      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7200 C Following matrices are needed only for 6-th order cumulants
7201         IF (wcorr6.gt.0.0d0) THEN
7202         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7203      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7204      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7205         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7206      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7207      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7208      &   ADtEAderx(1,1,1,1,1,2))
7209         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7210      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7211      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7212      &   ADtEA1derx(1,1,1,1,1,2))
7213         ENDIF
7214 C End 6-th order cumulants
7215         call transpose2(EUgder(1,1,l),auxmat(1,1))
7216         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7217         call transpose2(EUg(1,1,l),auxmat(1,1))
7218         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7219         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7220         do iii=1,2
7221           do kkk=1,5
7222             do lll=1,3
7223               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7224      &          EAEAderx(1,1,lll,kkk,iii,2))
7225             enddo
7226           enddo
7227         enddo
7228 C AEAb1 and AEAb2
7229 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7230 C They are needed only when the fifth- or the sixth-order cumulants are
7231 C indluded.
7232         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7233         call transpose2(AEA(1,1,1),auxmat(1,1))
7234         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7235         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7236         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7237         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7238         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7239         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7240         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7241         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7242         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7243         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7244         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7245         call transpose2(AEA(1,1,2),auxmat(1,1))
7246         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7247         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7248         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7249         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7250         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7251         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7252         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7253         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7254         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7255         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7256         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7257 C Calculate the Cartesian derivatives of the vectors.
7258         do iii=1,2
7259           do kkk=1,5
7260             do lll=1,3
7261               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7262               call matvec2(auxmat(1,1),b1(1,iti),
7263      &          AEAb1derx(1,lll,kkk,iii,1,1))
7264               call matvec2(auxmat(1,1),Ub2(1,i),
7265      &          AEAb2derx(1,lll,kkk,iii,1,1))
7266               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7267      &          AEAb1derx(1,lll,kkk,iii,2,1))
7268               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7269      &          AEAb2derx(1,lll,kkk,iii,2,1))
7270               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7271               call matvec2(auxmat(1,1),b1(1,itj),
7272      &          AEAb1derx(1,lll,kkk,iii,1,2))
7273               call matvec2(auxmat(1,1),Ub2(1,j),
7274      &          AEAb2derx(1,lll,kkk,iii,1,2))
7275               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7276      &          AEAb1derx(1,lll,kkk,iii,2,2))
7277               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7278      &          AEAb2derx(1,lll,kkk,iii,2,2))
7279             enddo
7280           enddo
7281         enddo
7282         ENDIF
7283 C End vectors
7284       else
7285 C Antiparallel orientation of the two CA-CA-CA frames.
7286         if (i.gt.1) then
7287           iti=itortyp(itype(i))
7288         else
7289           iti=ntortyp+1
7290         endif
7291         itk1=itortyp(itype(k+1))
7292         itl=itortyp(itype(l))
7293         itj=itortyp(itype(j))
7294         if (j.lt.nres-1) then
7295           itj1=itortyp(itype(j+1))
7296         else
7297           itj1=ntortyp+1
7298         endif
7299 C A2 kernel(j-1)T A1T
7300         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7301      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7302      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7303 C Following matrices are needed only for 6-th order cumulants
7304         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7305      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7306         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7307      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7308      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7309         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7310      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7311      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7312      &   ADtEAderx(1,1,1,1,1,1))
7313         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7314      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7315      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7316      &   ADtEA1derx(1,1,1,1,1,1))
7317         ENDIF
7318 C End 6-th order cumulants
7319         call transpose2(EUgder(1,1,k),auxmat(1,1))
7320         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7321         call transpose2(EUg(1,1,k),auxmat(1,1))
7322         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7323         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7324         do iii=1,2
7325           do kkk=1,5
7326             do lll=1,3
7327               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7328      &          EAEAderx(1,1,lll,kkk,iii,1))
7329             enddo
7330           enddo
7331         enddo
7332 C A2T kernel(i+1)T A1
7333         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7334      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7335      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7336 C Following matrices are needed only for 6-th order cumulants
7337         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7338      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7339         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7340      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7341      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7342         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7343      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7344      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7345      &   ADtEAderx(1,1,1,1,1,2))
7346         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7347      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7348      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7349      &   ADtEA1derx(1,1,1,1,1,2))
7350         ENDIF
7351 C End 6-th order cumulants
7352         call transpose2(EUgder(1,1,j),auxmat(1,1))
7353         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7354         call transpose2(EUg(1,1,j),auxmat(1,1))
7355         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7356         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7357         do iii=1,2
7358           do kkk=1,5
7359             do lll=1,3
7360               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7361      &          EAEAderx(1,1,lll,kkk,iii,2))
7362             enddo
7363           enddo
7364         enddo
7365 C AEAb1 and AEAb2
7366 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7367 C They are needed only when the fifth- or the sixth-order cumulants are
7368 C indluded.
7369         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7370      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7371         call transpose2(AEA(1,1,1),auxmat(1,1))
7372         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7373         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7374         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7375         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7376         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7377         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7378         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7379         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7380         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7381         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7382         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7383         call transpose2(AEA(1,1,2),auxmat(1,1))
7384         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7385         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7386         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7387         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7388         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7389         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7390         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7391         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7392         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7393         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7394         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7395 C Calculate the Cartesian derivatives of the vectors.
7396         do iii=1,2
7397           do kkk=1,5
7398             do lll=1,3
7399               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7400               call matvec2(auxmat(1,1),b1(1,iti),
7401      &          AEAb1derx(1,lll,kkk,iii,1,1))
7402               call matvec2(auxmat(1,1),Ub2(1,i),
7403      &          AEAb2derx(1,lll,kkk,iii,1,1))
7404               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7405      &          AEAb1derx(1,lll,kkk,iii,2,1))
7406               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7407      &          AEAb2derx(1,lll,kkk,iii,2,1))
7408               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7409               call matvec2(auxmat(1,1),b1(1,itl),
7410      &          AEAb1derx(1,lll,kkk,iii,1,2))
7411               call matvec2(auxmat(1,1),Ub2(1,l),
7412      &          AEAb2derx(1,lll,kkk,iii,1,2))
7413               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7414      &          AEAb1derx(1,lll,kkk,iii,2,2))
7415               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7416      &          AEAb2derx(1,lll,kkk,iii,2,2))
7417             enddo
7418           enddo
7419         enddo
7420         ENDIF
7421 C End vectors
7422       endif
7423       return
7424       end
7425 C---------------------------------------------------------------------------
7426       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7427      &  KK,KKderg,AKA,AKAderg,AKAderx)
7428       implicit none
7429       integer nderg
7430       logical transp
7431       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7432      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7433      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7434       integer iii,kkk,lll
7435       integer jjj,mmm
7436       logical lprn
7437       common /kutas/ lprn
7438       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7439       do iii=1,nderg
7440         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7441      &    AKAderg(1,1,iii))
7442       enddo
7443 cd      if (lprn) write (2,*) 'In kernel'
7444       do kkk=1,5
7445 cd        if (lprn) write (2,*) 'kkk=',kkk
7446         do lll=1,3
7447           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7448      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7449 cd          if (lprn) then
7450 cd            write (2,*) 'lll=',lll
7451 cd            write (2,*) 'iii=1'
7452 cd            do jjj=1,2
7453 cd              write (2,'(3(2f10.5),5x)')
7454 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7455 cd            enddo
7456 cd          endif
7457           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7458      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7459 cd          if (lprn) then
7460 cd            write (2,*) 'lll=',lll
7461 cd            write (2,*) 'iii=2'
7462 cd            do jjj=1,2
7463 cd              write (2,'(3(2f10.5),5x)')
7464 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7465 cd            enddo
7466 cd          endif
7467         enddo
7468       enddo
7469       return
7470       end
7471 C---------------------------------------------------------------------------
7472       double precision function eello4(i,j,k,l,jj,kk)
7473       implicit real*8 (a-h,o-z)
7474       include 'DIMENSIONS'
7475       include 'COMMON.IOUNITS'
7476       include 'COMMON.CHAIN'
7477       include 'COMMON.DERIV'
7478       include 'COMMON.INTERACT'
7479       include 'COMMON.CONTACTS'
7480       include 'COMMON.TORSION'
7481       include 'COMMON.VAR'
7482       include 'COMMON.GEO'
7483       double precision pizda(2,2),ggg1(3),ggg2(3)
7484 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7485 cd        eello4=0.0d0
7486 cd        return
7487 cd      endif
7488 cd      print *,'eello4:',i,j,k,l,jj,kk
7489 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7490 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7491 cold      eij=facont_hb(jj,i)
7492 cold      ekl=facont_hb(kk,k)
7493 cold      ekont=eij*ekl
7494       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7495 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7496       gcorr_loc(k-1)=gcorr_loc(k-1)
7497      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7498       if (l.eq.j+1) then
7499         gcorr_loc(l-1)=gcorr_loc(l-1)
7500      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7501       else
7502         gcorr_loc(j-1)=gcorr_loc(j-1)
7503      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7504       endif
7505       do iii=1,2
7506         do kkk=1,5
7507           do lll=1,3
7508             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7509      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7510 cd            derx(lll,kkk,iii)=0.0d0
7511           enddo
7512         enddo
7513       enddo
7514 cd      gcorr_loc(l-1)=0.0d0
7515 cd      gcorr_loc(j-1)=0.0d0
7516 cd      gcorr_loc(k-1)=0.0d0
7517 cd      eel4=1.0d0
7518 cd      write (iout,*)'Contacts have occurred for peptide groups',
7519 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7520 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7521       if (j.lt.nres-1) then
7522         j1=j+1
7523         j2=j-1
7524       else
7525         j1=j-1
7526         j2=j-2
7527       endif
7528       if (l.lt.nres-1) then
7529         l1=l+1
7530         l2=l-1
7531       else
7532         l1=l-1
7533         l2=l-2
7534       endif
7535       do ll=1,3
7536 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7537 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7538         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7539         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7540 cgrad        ghalf=0.5d0*ggg1(ll)
7541         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7542         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7543         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7544         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7545         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7546         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7547 cgrad        ghalf=0.5d0*ggg2(ll)
7548         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7549         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7550         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7551         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7552         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7553         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7554       enddo
7555 cgrad      do m=i+1,j-1
7556 cgrad        do ll=1,3
7557 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7558 cgrad        enddo
7559 cgrad      enddo
7560 cgrad      do m=k+1,l-1
7561 cgrad        do ll=1,3
7562 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7563 cgrad        enddo
7564 cgrad      enddo
7565 cgrad      do m=i+2,j2
7566 cgrad        do ll=1,3
7567 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7568 cgrad        enddo
7569 cgrad      enddo
7570 cgrad      do m=k+2,l2
7571 cgrad        do ll=1,3
7572 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7573 cgrad        enddo
7574 cgrad      enddo
7575 cd      do iii=1,nres-3
7576 cd        write (2,*) iii,gcorr_loc(iii)
7577 cd      enddo
7578       eello4=ekont*eel4
7579 cd      write (2,*) 'ekont',ekont
7580 cd      write (iout,*) 'eello4',ekont*eel4
7581       return
7582       end
7583 C---------------------------------------------------------------------------
7584       double precision function eello5(i,j,k,l,jj,kk)
7585       implicit real*8 (a-h,o-z)
7586       include 'DIMENSIONS'
7587       include 'COMMON.IOUNITS'
7588       include 'COMMON.CHAIN'
7589       include 'COMMON.DERIV'
7590       include 'COMMON.INTERACT'
7591       include 'COMMON.CONTACTS'
7592       include 'COMMON.TORSION'
7593       include 'COMMON.VAR'
7594       include 'COMMON.GEO'
7595       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7596       double precision ggg1(3),ggg2(3)
7597 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7598 C                                                                              C
7599 C                            Parallel chains                                   C
7600 C                                                                              C
7601 C          o             o                   o             o                   C
7602 C         /l\           / \             \   / \           / \   /              C
7603 C        /   \         /   \             \ /   \         /   \ /               C
7604 C       j| o |l1       | o |              o| o |         | o |o                C
7605 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7606 C      \i/   \         /   \ /             /   \         /   \                 C
7607 C       o    k1             o                                                  C
7608 C         (I)          (II)                (III)          (IV)                 C
7609 C                                                                              C
7610 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7611 C                                                                              C
7612 C                            Antiparallel chains                               C
7613 C                                                                              C
7614 C          o             o                   o             o                   C
7615 C         /j\           / \             \   / \           / \   /              C
7616 C        /   \         /   \             \ /   \         /   \ /               C
7617 C      j1| o |l        | o |              o| o |         | o |o                C
7618 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7619 C      \i/   \         /   \ /             /   \         /   \                 C
7620 C       o     k1            o                                                  C
7621 C         (I)          (II)                (III)          (IV)                 C
7622 C                                                                              C
7623 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7624 C                                                                              C
7625 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7626 C                                                                              C
7627 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7628 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7629 cd        eello5=0.0d0
7630 cd        return
7631 cd      endif
7632 cd      write (iout,*)
7633 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7634 cd     &   ' and',k,l
7635       itk=itortyp(itype(k))
7636       itl=itortyp(itype(l))
7637       itj=itortyp(itype(j))
7638       eello5_1=0.0d0
7639       eello5_2=0.0d0
7640       eello5_3=0.0d0
7641       eello5_4=0.0d0
7642 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7643 cd     &   eel5_3_num,eel5_4_num)
7644       do iii=1,2
7645         do kkk=1,5
7646           do lll=1,3
7647             derx(lll,kkk,iii)=0.0d0
7648           enddo
7649         enddo
7650       enddo
7651 cd      eij=facont_hb(jj,i)
7652 cd      ekl=facont_hb(kk,k)
7653 cd      ekont=eij*ekl
7654 cd      write (iout,*)'Contacts have occurred for peptide groups',
7655 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7656 cd      goto 1111
7657 C Contribution from the graph I.
7658 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7659 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7660       call transpose2(EUg(1,1,k),auxmat(1,1))
7661       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7662       vv(1)=pizda(1,1)-pizda(2,2)
7663       vv(2)=pizda(1,2)+pizda(2,1)
7664       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7665      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7666 C Explicit gradient in virtual-dihedral angles.
7667       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7668      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7669      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7670       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7671       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7672       vv(1)=pizda(1,1)-pizda(2,2)
7673       vv(2)=pizda(1,2)+pizda(2,1)
7674       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7675      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7676      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7677       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7678       vv(1)=pizda(1,1)-pizda(2,2)
7679       vv(2)=pizda(1,2)+pizda(2,1)
7680       if (l.eq.j+1) then
7681         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7682      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7683      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7684       else
7685         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7686      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7687      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7688       endif
7689 C Cartesian gradient
7690       do iii=1,2
7691         do kkk=1,5
7692           do lll=1,3
7693             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7694      &        pizda(1,1))
7695             vv(1)=pizda(1,1)-pizda(2,2)
7696             vv(2)=pizda(1,2)+pizda(2,1)
7697             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7698      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7699      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7700           enddo
7701         enddo
7702       enddo
7703 c      goto 1112
7704 c1111  continue
7705 C Contribution from graph II
7706       call transpose2(EE(1,1,itk),auxmat(1,1))
7707       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7708       vv(1)=pizda(1,1)+pizda(2,2)
7709       vv(2)=pizda(2,1)-pizda(1,2)
7710       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7711      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7712 C Explicit gradient in virtual-dihedral angles.
7713       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7714      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7715       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7716       vv(1)=pizda(1,1)+pizda(2,2)
7717       vv(2)=pizda(2,1)-pizda(1,2)
7718       if (l.eq.j+1) then
7719         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7720      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7721      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7722       else
7723         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7724      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7725      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7726       endif
7727 C Cartesian gradient
7728       do iii=1,2
7729         do kkk=1,5
7730           do lll=1,3
7731             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7732      &        pizda(1,1))
7733             vv(1)=pizda(1,1)+pizda(2,2)
7734             vv(2)=pizda(2,1)-pizda(1,2)
7735             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7736      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7737      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7738           enddo
7739         enddo
7740       enddo
7741 cd      goto 1112
7742 cd1111  continue
7743       if (l.eq.j+1) then
7744 cd        goto 1110
7745 C Parallel orientation
7746 C Contribution from graph III
7747         call transpose2(EUg(1,1,l),auxmat(1,1))
7748         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7749         vv(1)=pizda(1,1)-pizda(2,2)
7750         vv(2)=pizda(1,2)+pizda(2,1)
7751         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7752      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7753 C Explicit gradient in virtual-dihedral angles.
7754         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7755      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7756      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7757         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7758         vv(1)=pizda(1,1)-pizda(2,2)
7759         vv(2)=pizda(1,2)+pizda(2,1)
7760         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7761      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7762      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7763         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7764         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7765         vv(1)=pizda(1,1)-pizda(2,2)
7766         vv(2)=pizda(1,2)+pizda(2,1)
7767         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7768      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7769      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7770 C Cartesian gradient
7771         do iii=1,2
7772           do kkk=1,5
7773             do lll=1,3
7774               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7775      &          pizda(1,1))
7776               vv(1)=pizda(1,1)-pizda(2,2)
7777               vv(2)=pizda(1,2)+pizda(2,1)
7778               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7779      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7780      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7781             enddo
7782           enddo
7783         enddo
7784 cd        goto 1112
7785 C Contribution from graph IV
7786 cd1110    continue
7787         call transpose2(EE(1,1,itl),auxmat(1,1))
7788         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7789         vv(1)=pizda(1,1)+pizda(2,2)
7790         vv(2)=pizda(2,1)-pizda(1,2)
7791         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7792      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7793 C Explicit gradient in virtual-dihedral angles.
7794         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7795      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7796         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7797         vv(1)=pizda(1,1)+pizda(2,2)
7798         vv(2)=pizda(2,1)-pizda(1,2)
7799         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7800      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7801      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7802 C Cartesian gradient
7803         do iii=1,2
7804           do kkk=1,5
7805             do lll=1,3
7806               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7807      &          pizda(1,1))
7808               vv(1)=pizda(1,1)+pizda(2,2)
7809               vv(2)=pizda(2,1)-pizda(1,2)
7810               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7811      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7812      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7813             enddo
7814           enddo
7815         enddo
7816       else
7817 C Antiparallel orientation
7818 C Contribution from graph III
7819 c        goto 1110
7820         call transpose2(EUg(1,1,j),auxmat(1,1))
7821         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7822         vv(1)=pizda(1,1)-pizda(2,2)
7823         vv(2)=pizda(1,2)+pizda(2,1)
7824         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7825      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7826 C Explicit gradient in virtual-dihedral angles.
7827         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7828      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7829      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7830         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7831         vv(1)=pizda(1,1)-pizda(2,2)
7832         vv(2)=pizda(1,2)+pizda(2,1)
7833         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7834      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7835      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7836         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7837         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7838         vv(1)=pizda(1,1)-pizda(2,2)
7839         vv(2)=pizda(1,2)+pizda(2,1)
7840         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7841      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7842      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7843 C Cartesian gradient
7844         do iii=1,2
7845           do kkk=1,5
7846             do lll=1,3
7847               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7848      &          pizda(1,1))
7849               vv(1)=pizda(1,1)-pizda(2,2)
7850               vv(2)=pizda(1,2)+pizda(2,1)
7851               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7852      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7853      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7854             enddo
7855           enddo
7856         enddo
7857 cd        goto 1112
7858 C Contribution from graph IV
7859 1110    continue
7860         call transpose2(EE(1,1,itj),auxmat(1,1))
7861         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7862         vv(1)=pizda(1,1)+pizda(2,2)
7863         vv(2)=pizda(2,1)-pizda(1,2)
7864         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7865      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7866 C Explicit gradient in virtual-dihedral angles.
7867         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7868      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7869         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7870         vv(1)=pizda(1,1)+pizda(2,2)
7871         vv(2)=pizda(2,1)-pizda(1,2)
7872         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7873      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7874      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7875 C Cartesian gradient
7876         do iii=1,2
7877           do kkk=1,5
7878             do lll=1,3
7879               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7880      &          pizda(1,1))
7881               vv(1)=pizda(1,1)+pizda(2,2)
7882               vv(2)=pizda(2,1)-pizda(1,2)
7883               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7884      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7885      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7886             enddo
7887           enddo
7888         enddo
7889       endif
7890 1112  continue
7891       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7892 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7893 cd        write (2,*) 'ijkl',i,j,k,l
7894 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7895 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7896 cd      endif
7897 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7898 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7899 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7900 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7901       if (j.lt.nres-1) then
7902         j1=j+1
7903         j2=j-1
7904       else
7905         j1=j-1
7906         j2=j-2
7907       endif
7908       if (l.lt.nres-1) then
7909         l1=l+1
7910         l2=l-1
7911       else
7912         l1=l-1
7913         l2=l-2
7914       endif
7915 cd      eij=1.0d0
7916 cd      ekl=1.0d0
7917 cd      ekont=1.0d0
7918 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7919 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7920 C        summed up outside the subrouine as for the other subroutines
7921 C        handling long-range interactions. The old code is commented out
7922 C        with "cgrad" to keep track of changes.
7923       do ll=1,3
7924 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7925 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7926         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7927         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7928 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7929 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7930 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7931 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7932 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7933 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7934 c     &   gradcorr5ij,
7935 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7936 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7937 cgrad        ghalf=0.5d0*ggg1(ll)
7938 cd        ghalf=0.0d0
7939         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7940         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7941         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7942         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7943         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7944         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7945 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7946 cgrad        ghalf=0.5d0*ggg2(ll)
7947 cd        ghalf=0.0d0
7948         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7949         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7950         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7951         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7952         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7953         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7954       enddo
7955 cd      goto 1112
7956 cgrad      do m=i+1,j-1
7957 cgrad        do ll=1,3
7958 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7959 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7960 cgrad        enddo
7961 cgrad      enddo
7962 cgrad      do m=k+1,l-1
7963 cgrad        do ll=1,3
7964 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7965 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7966 cgrad        enddo
7967 cgrad      enddo
7968 c1112  continue
7969 cgrad      do m=i+2,j2
7970 cgrad        do ll=1,3
7971 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7972 cgrad        enddo
7973 cgrad      enddo
7974 cgrad      do m=k+2,l2
7975 cgrad        do ll=1,3
7976 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7977 cgrad        enddo
7978 cgrad      enddo
7979 cd      do iii=1,nres-3
7980 cd        write (2,*) iii,g_corr5_loc(iii)
7981 cd      enddo
7982       eello5=ekont*eel5
7983 cd      write (2,*) 'ekont',ekont
7984 cd      write (iout,*) 'eello5',ekont*eel5
7985       return
7986       end
7987 c--------------------------------------------------------------------------
7988       double precision function eello6(i,j,k,l,jj,kk)
7989       implicit real*8 (a-h,o-z)
7990       include 'DIMENSIONS'
7991       include 'COMMON.IOUNITS'
7992       include 'COMMON.CHAIN'
7993       include 'COMMON.DERIV'
7994       include 'COMMON.INTERACT'
7995       include 'COMMON.CONTACTS'
7996       include 'COMMON.TORSION'
7997       include 'COMMON.VAR'
7998       include 'COMMON.GEO'
7999       include 'COMMON.FFIELD'
8000       double precision ggg1(3),ggg2(3)
8001 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8002 cd        eello6=0.0d0
8003 cd        return
8004 cd      endif
8005 cd      write (iout,*)
8006 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8007 cd     &   ' and',k,l
8008       eello6_1=0.0d0
8009       eello6_2=0.0d0
8010       eello6_3=0.0d0
8011       eello6_4=0.0d0
8012       eello6_5=0.0d0
8013       eello6_6=0.0d0
8014 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8015 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8016       do iii=1,2
8017         do kkk=1,5
8018           do lll=1,3
8019             derx(lll,kkk,iii)=0.0d0
8020           enddo
8021         enddo
8022       enddo
8023 cd      eij=facont_hb(jj,i)
8024 cd      ekl=facont_hb(kk,k)
8025 cd      ekont=eij*ekl
8026 cd      eij=1.0d0
8027 cd      ekl=1.0d0
8028 cd      ekont=1.0d0
8029       if (l.eq.j+1) then
8030         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8031         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8032         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8033         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8034         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8035         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8036       else
8037         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8038         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8039         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8040         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8041         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8042           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8043         else
8044           eello6_5=0.0d0
8045         endif
8046         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8047       endif
8048 C If turn contributions are considered, they will be handled separately.
8049       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8050 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8051 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8052 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8053 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8054 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8055 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8056 cd      goto 1112
8057       if (j.lt.nres-1) then
8058         j1=j+1
8059         j2=j-1
8060       else
8061         j1=j-1
8062         j2=j-2
8063       endif
8064       if (l.lt.nres-1) then
8065         l1=l+1
8066         l2=l-1
8067       else
8068         l1=l-1
8069         l2=l-2
8070       endif
8071       do ll=1,3
8072 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8073 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8074 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8075 cgrad        ghalf=0.5d0*ggg1(ll)
8076 cd        ghalf=0.0d0
8077         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8078         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8079         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8080         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8081         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8082         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8083         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8084         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8085 cgrad        ghalf=0.5d0*ggg2(ll)
8086 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8087 cd        ghalf=0.0d0
8088         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8089         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8090         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8091         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8092         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8093         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8094       enddo
8095 cd      goto 1112
8096 cgrad      do m=i+1,j-1
8097 cgrad        do ll=1,3
8098 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8099 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8100 cgrad        enddo
8101 cgrad      enddo
8102 cgrad      do m=k+1,l-1
8103 cgrad        do ll=1,3
8104 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8105 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8106 cgrad        enddo
8107 cgrad      enddo
8108 cgrad1112  continue
8109 cgrad      do m=i+2,j2
8110 cgrad        do ll=1,3
8111 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8112 cgrad        enddo
8113 cgrad      enddo
8114 cgrad      do m=k+2,l2
8115 cgrad        do ll=1,3
8116 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8117 cgrad        enddo
8118 cgrad      enddo
8119 cd      do iii=1,nres-3
8120 cd        write (2,*) iii,g_corr6_loc(iii)
8121 cd      enddo
8122       eello6=ekont*eel6
8123 cd      write (2,*) 'ekont',ekont
8124 cd      write (iout,*) 'eello6',ekont*eel6
8125       return
8126       end
8127 c--------------------------------------------------------------------------
8128       double precision function eello6_graph1(i,j,k,l,imat,swap)
8129       implicit real*8 (a-h,o-z)
8130       include 'DIMENSIONS'
8131       include 'COMMON.IOUNITS'
8132       include 'COMMON.CHAIN'
8133       include 'COMMON.DERIV'
8134       include 'COMMON.INTERACT'
8135       include 'COMMON.CONTACTS'
8136       include 'COMMON.TORSION'
8137       include 'COMMON.VAR'
8138       include 'COMMON.GEO'
8139       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8140       logical swap
8141       logical lprn
8142       common /kutas/ lprn
8143 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8144 C
8145 C      Parallel       Antiparallel
8146 C
8147 C          o             o
8148 C         /l\           /j\
8149 C        /   \         /   \
8150 C       /| o |         | o |\
8151 C     \ j|/k\|  /   \  |/k\|l /
8152 C      \ /   \ /     \ /   \ /
8153 C       o     o       o     o
8154 C       i             i
8155 C
8156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8157       itk=itortyp(itype(k))
8158       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8159       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8160       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8161       call transpose2(EUgC(1,1,k),auxmat(1,1))
8162       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8163       vv1(1)=pizda1(1,1)-pizda1(2,2)
8164       vv1(2)=pizda1(1,2)+pizda1(2,1)
8165       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8166       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8167       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8168       s5=scalar2(vv(1),Dtobr2(1,i))
8169 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8170       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8171       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8172      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8173      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8174      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8175      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8176      & +scalar2(vv(1),Dtobr2der(1,i)))
8177       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8178       vv1(1)=pizda1(1,1)-pizda1(2,2)
8179       vv1(2)=pizda1(1,2)+pizda1(2,1)
8180       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8181       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8182       if (l.eq.j+1) then
8183         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8184      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8185      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8186      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8187      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8188       else
8189         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8190      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8191      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8192      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8193      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8194       endif
8195       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8196       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8197       vv1(1)=pizda1(1,1)-pizda1(2,2)
8198       vv1(2)=pizda1(1,2)+pizda1(2,1)
8199       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8200      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8201      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8202      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8203       do iii=1,2
8204         if (swap) then
8205           ind=3-iii
8206         else
8207           ind=iii
8208         endif
8209         do kkk=1,5
8210           do lll=1,3
8211             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8212             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8213             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8214             call transpose2(EUgC(1,1,k),auxmat(1,1))
8215             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8216      &        pizda1(1,1))
8217             vv1(1)=pizda1(1,1)-pizda1(2,2)
8218             vv1(2)=pizda1(1,2)+pizda1(2,1)
8219             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8220             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8221      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8222             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8223      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8224             s5=scalar2(vv(1),Dtobr2(1,i))
8225             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8226           enddo
8227         enddo
8228       enddo
8229       return
8230       end
8231 c----------------------------------------------------------------------------
8232       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8233       implicit real*8 (a-h,o-z)
8234       include 'DIMENSIONS'
8235       include 'COMMON.IOUNITS'
8236       include 'COMMON.CHAIN'
8237       include 'COMMON.DERIV'
8238       include 'COMMON.INTERACT'
8239       include 'COMMON.CONTACTS'
8240       include 'COMMON.TORSION'
8241       include 'COMMON.VAR'
8242       include 'COMMON.GEO'
8243       logical swap
8244       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8245      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8246       logical lprn
8247       common /kutas/ lprn
8248 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8249 C                                                                              C
8250 C      Parallel       Antiparallel                                             C
8251 C                                                                              C
8252 C          o             o                                                     C
8253 C     \   /l\           /j\   /                                                C
8254 C      \ /   \         /   \ /                                                 C
8255 C       o| o |         | o |o                                                  C
8256 C     \ j|/k\|      \  |/k\|l                                                  C
8257 C      \ /   \       \ /   \                                                   C
8258 C       o             o                                                        C
8259 C       i             i                                                        C
8260 C                                                                              C
8261 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8262 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8263 C AL 7/4/01 s1 would occur in the sixth-order moment,
8264 C           but not in a cluster cumulant
8265 #ifdef MOMENT
8266       s1=dip(1,jj,i)*dip(1,kk,k)
8267 #endif
8268       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8269       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8270       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8271       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8272       call transpose2(EUg(1,1,k),auxmat(1,1))
8273       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8274       vv(1)=pizda(1,1)-pizda(2,2)
8275       vv(2)=pizda(1,2)+pizda(2,1)
8276       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8277 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8278 #ifdef MOMENT
8279       eello6_graph2=-(s1+s2+s3+s4)
8280 #else
8281       eello6_graph2=-(s2+s3+s4)
8282 #endif
8283 c      eello6_graph2=-s3
8284 C Derivatives in gamma(i-1)
8285       if (i.gt.1) then
8286 #ifdef MOMENT
8287         s1=dipderg(1,jj,i)*dip(1,kk,k)
8288 #endif
8289         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8290         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8291         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8292         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8293 #ifdef MOMENT
8294         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8295 #else
8296         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8297 #endif
8298 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8299       endif
8300 C Derivatives in gamma(k-1)
8301 #ifdef MOMENT
8302       s1=dip(1,jj,i)*dipderg(1,kk,k)
8303 #endif
8304       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8305       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8306       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8307       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8308       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8309       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8310       vv(1)=pizda(1,1)-pizda(2,2)
8311       vv(2)=pizda(1,2)+pizda(2,1)
8312       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8313 #ifdef MOMENT
8314       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8315 #else
8316       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8317 #endif
8318 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8319 C Derivatives in gamma(j-1) or gamma(l-1)
8320       if (j.gt.1) then
8321 #ifdef MOMENT
8322         s1=dipderg(3,jj,i)*dip(1,kk,k)
8323 #endif
8324         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8325         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8326         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8327         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8328         vv(1)=pizda(1,1)-pizda(2,2)
8329         vv(2)=pizda(1,2)+pizda(2,1)
8330         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8331 #ifdef MOMENT
8332         if (swap) then
8333           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8334         else
8335           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8336         endif
8337 #endif
8338         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8339 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8340       endif
8341 C Derivatives in gamma(l-1) or gamma(j-1)
8342       if (l.gt.1) then
8343 #ifdef MOMENT
8344         s1=dip(1,jj,i)*dipderg(3,kk,k)
8345 #endif
8346         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8347         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8348         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8349         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8350         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8351         vv(1)=pizda(1,1)-pizda(2,2)
8352         vv(2)=pizda(1,2)+pizda(2,1)
8353         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8354 #ifdef MOMENT
8355         if (swap) then
8356           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8357         else
8358           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8359         endif
8360 #endif
8361         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8362 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8363       endif
8364 C Cartesian derivatives.
8365       if (lprn) then
8366         write (2,*) 'In eello6_graph2'
8367         do iii=1,2
8368           write (2,*) 'iii=',iii
8369           do kkk=1,5
8370             write (2,*) 'kkk=',kkk
8371             do jjj=1,2
8372               write (2,'(3(2f10.5),5x)')
8373      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8374             enddo
8375           enddo
8376         enddo
8377       endif
8378       do iii=1,2
8379         do kkk=1,5
8380           do lll=1,3
8381 #ifdef MOMENT
8382             if (iii.eq.1) then
8383               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8384             else
8385               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8386             endif
8387 #endif
8388             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8389      &        auxvec(1))
8390             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8391             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8392      &        auxvec(1))
8393             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8394             call transpose2(EUg(1,1,k),auxmat(1,1))
8395             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8396      &        pizda(1,1))
8397             vv(1)=pizda(1,1)-pizda(2,2)
8398             vv(2)=pizda(1,2)+pizda(2,1)
8399             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8400 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8401 #ifdef MOMENT
8402             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8403 #else
8404             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8405 #endif
8406             if (swap) then
8407               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8408             else
8409               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8410             endif
8411           enddo
8412         enddo
8413       enddo
8414       return
8415       end
8416 c----------------------------------------------------------------------------
8417       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8418       implicit real*8 (a-h,o-z)
8419       include 'DIMENSIONS'
8420       include 'COMMON.IOUNITS'
8421       include 'COMMON.CHAIN'
8422       include 'COMMON.DERIV'
8423       include 'COMMON.INTERACT'
8424       include 'COMMON.CONTACTS'
8425       include 'COMMON.TORSION'
8426       include 'COMMON.VAR'
8427       include 'COMMON.GEO'
8428       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8429       logical swap
8430 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8431 C                                                                              C
8432 C      Parallel       Antiparallel                                             C
8433 C                                                                              C
8434 C          o             o                                                     C
8435 C         /l\   /   \   /j\                                                    C
8436 C        /   \ /     \ /   \                                                   C
8437 C       /| o |o       o| o |\                                                  C
8438 C       j|/k\|  /      |/k\|l /                                                C
8439 C        /   \ /       /   \ /                                                 C
8440 C       /     o       /     o                                                  C
8441 C       i             i                                                        C
8442 C                                                                              C
8443 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8444 C
8445 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8446 C           energy moment and not to the cluster cumulant.
8447       iti=itortyp(itype(i))
8448       if (j.lt.nres-1) then
8449         itj1=itortyp(itype(j+1))
8450       else
8451         itj1=ntortyp+1
8452       endif
8453       itk=itortyp(itype(k))
8454       itk1=itortyp(itype(k+1))
8455       if (l.lt.nres-1) then
8456         itl1=itortyp(itype(l+1))
8457       else
8458         itl1=ntortyp+1
8459       endif
8460 #ifdef MOMENT
8461       s1=dip(4,jj,i)*dip(4,kk,k)
8462 #endif
8463       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8464       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8465       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8466       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8467       call transpose2(EE(1,1,itk),auxmat(1,1))
8468       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8469       vv(1)=pizda(1,1)+pizda(2,2)
8470       vv(2)=pizda(2,1)-pizda(1,2)
8471       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8472 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8473 cd     & "sum",-(s2+s3+s4)
8474 #ifdef MOMENT
8475       eello6_graph3=-(s1+s2+s3+s4)
8476 #else
8477       eello6_graph3=-(s2+s3+s4)
8478 #endif
8479 c      eello6_graph3=-s4
8480 C Derivatives in gamma(k-1)
8481       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8482       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8483       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8484       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8485 C Derivatives in gamma(l-1)
8486       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8487       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8488       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8489       vv(1)=pizda(1,1)+pizda(2,2)
8490       vv(2)=pizda(2,1)-pizda(1,2)
8491       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8492       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8493 C Cartesian derivatives.
8494       do iii=1,2
8495         do kkk=1,5
8496           do lll=1,3
8497 #ifdef MOMENT
8498             if (iii.eq.1) then
8499               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8500             else
8501               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8502             endif
8503 #endif
8504             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8505      &        auxvec(1))
8506             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8507             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8508      &        auxvec(1))
8509             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8510             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8511      &        pizda(1,1))
8512             vv(1)=pizda(1,1)+pizda(2,2)
8513             vv(2)=pizda(2,1)-pizda(1,2)
8514             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8515 #ifdef MOMENT
8516             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8517 #else
8518             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8519 #endif
8520             if (swap) then
8521               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8522             else
8523               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8524             endif
8525 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8526           enddo
8527         enddo
8528       enddo
8529       return
8530       end
8531 c----------------------------------------------------------------------------
8532       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8533       implicit real*8 (a-h,o-z)
8534       include 'DIMENSIONS'
8535       include 'COMMON.IOUNITS'
8536       include 'COMMON.CHAIN'
8537       include 'COMMON.DERIV'
8538       include 'COMMON.INTERACT'
8539       include 'COMMON.CONTACTS'
8540       include 'COMMON.TORSION'
8541       include 'COMMON.VAR'
8542       include 'COMMON.GEO'
8543       include 'COMMON.FFIELD'
8544       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8545      & auxvec1(2),auxmat1(2,2)
8546       logical swap
8547 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8548 C                                                                              C
8549 C      Parallel       Antiparallel                                             C
8550 C                                                                              C
8551 C          o             o                                                     C
8552 C         /l\   /   \   /j\                                                    C
8553 C        /   \ /     \ /   \                                                   C
8554 C       /| o |o       o| o |\                                                  C
8555 C     \ j|/k\|      \  |/k\|l                                                  C
8556 C      \ /   \       \ /   \                                                   C
8557 C       o     \       o     \                                                  C
8558 C       i             i                                                        C
8559 C                                                                              C
8560 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8561 C
8562 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8563 C           energy moment and not to the cluster cumulant.
8564 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8565       iti=itortyp(itype(i))
8566       itj=itortyp(itype(j))
8567       if (j.lt.nres-1) then
8568         itj1=itortyp(itype(j+1))
8569       else
8570         itj1=ntortyp+1
8571       endif
8572       itk=itortyp(itype(k))
8573       if (k.lt.nres-1) then
8574         itk1=itortyp(itype(k+1))
8575       else
8576         itk1=ntortyp+1
8577       endif
8578       itl=itortyp(itype(l))
8579       if (l.lt.nres-1) then
8580         itl1=itortyp(itype(l+1))
8581       else
8582         itl1=ntortyp+1
8583       endif
8584 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8585 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8586 cd     & ' itl',itl,' itl1',itl1
8587 #ifdef MOMENT
8588       if (imat.eq.1) then
8589         s1=dip(3,jj,i)*dip(3,kk,k)
8590       else
8591         s1=dip(2,jj,j)*dip(2,kk,l)
8592       endif
8593 #endif
8594       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8595       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8596       if (j.eq.l+1) then
8597         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8598         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8599       else
8600         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8601         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8602       endif
8603       call transpose2(EUg(1,1,k),auxmat(1,1))
8604       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8605       vv(1)=pizda(1,1)-pizda(2,2)
8606       vv(2)=pizda(2,1)+pizda(1,2)
8607       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8608 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8609 #ifdef MOMENT
8610       eello6_graph4=-(s1+s2+s3+s4)
8611 #else
8612       eello6_graph4=-(s2+s3+s4)
8613 #endif
8614 C Derivatives in gamma(i-1)
8615       if (i.gt.1) then
8616 #ifdef MOMENT
8617         if (imat.eq.1) then
8618           s1=dipderg(2,jj,i)*dip(3,kk,k)
8619         else
8620           s1=dipderg(4,jj,j)*dip(2,kk,l)
8621         endif
8622 #endif
8623         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8624         if (j.eq.l+1) then
8625           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8626           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8627         else
8628           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8629           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8630         endif
8631         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8632         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8633 cd          write (2,*) 'turn6 derivatives'
8634 #ifdef MOMENT
8635           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8636 #else
8637           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8638 #endif
8639         else
8640 #ifdef MOMENT
8641           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8642 #else
8643           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8644 #endif
8645         endif
8646       endif
8647 C Derivatives in gamma(k-1)
8648 #ifdef MOMENT
8649       if (imat.eq.1) then
8650         s1=dip(3,jj,i)*dipderg(2,kk,k)
8651       else
8652         s1=dip(2,jj,j)*dipderg(4,kk,l)
8653       endif
8654 #endif
8655       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8656       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8657       if (j.eq.l+1) then
8658         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8659         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8660       else
8661         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8662         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8663       endif
8664       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8665       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8666       vv(1)=pizda(1,1)-pizda(2,2)
8667       vv(2)=pizda(2,1)+pizda(1,2)
8668       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8669       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8670 #ifdef MOMENT
8671         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8672 #else
8673         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8674 #endif
8675       else
8676 #ifdef MOMENT
8677         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8678 #else
8679         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8680 #endif
8681       endif
8682 C Derivatives in gamma(j-1) or gamma(l-1)
8683       if (l.eq.j+1 .and. l.gt.1) then
8684         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8685         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8686         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8687         vv(1)=pizda(1,1)-pizda(2,2)
8688         vv(2)=pizda(2,1)+pizda(1,2)
8689         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8690         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8691       else if (j.gt.1) then
8692         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8693         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8694         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8695         vv(1)=pizda(1,1)-pizda(2,2)
8696         vv(2)=pizda(2,1)+pizda(1,2)
8697         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8698         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8699           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8700         else
8701           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8702         endif
8703       endif
8704 C Cartesian derivatives.
8705       do iii=1,2
8706         do kkk=1,5
8707           do lll=1,3
8708 #ifdef MOMENT
8709             if (iii.eq.1) then
8710               if (imat.eq.1) then
8711                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8712               else
8713                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8714               endif
8715             else
8716               if (imat.eq.1) then
8717                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8718               else
8719                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8720               endif
8721             endif
8722 #endif
8723             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8724      &        auxvec(1))
8725             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8726             if (j.eq.l+1) then
8727               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8728      &          b1(1,itj1),auxvec(1))
8729               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8730             else
8731               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8732      &          b1(1,itl1),auxvec(1))
8733               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8734             endif
8735             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8736      &        pizda(1,1))
8737             vv(1)=pizda(1,1)-pizda(2,2)
8738             vv(2)=pizda(2,1)+pizda(1,2)
8739             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8740             if (swap) then
8741               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8742 #ifdef MOMENT
8743                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8744      &             -(s1+s2+s4)
8745 #else
8746                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8747      &             -(s2+s4)
8748 #endif
8749                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8750               else
8751 #ifdef MOMENT
8752                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8753 #else
8754                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8755 #endif
8756                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8757               endif
8758             else
8759 #ifdef MOMENT
8760               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8761 #else
8762               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8763 #endif
8764               if (l.eq.j+1) then
8765                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8766               else
8767                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8768               endif
8769             endif
8770           enddo
8771         enddo
8772       enddo
8773       return
8774       end
8775 c----------------------------------------------------------------------------
8776       double precision function eello_turn6(i,jj,kk)
8777       implicit real*8 (a-h,o-z)
8778       include 'DIMENSIONS'
8779       include 'COMMON.IOUNITS'
8780       include 'COMMON.CHAIN'
8781       include 'COMMON.DERIV'
8782       include 'COMMON.INTERACT'
8783       include 'COMMON.CONTACTS'
8784       include 'COMMON.TORSION'
8785       include 'COMMON.VAR'
8786       include 'COMMON.GEO'
8787       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8788      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8789      &  ggg1(3),ggg2(3)
8790       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8791      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8792 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8793 C           the respective energy moment and not to the cluster cumulant.
8794       s1=0.0d0
8795       s8=0.0d0
8796       s13=0.0d0
8797 c
8798       eello_turn6=0.0d0
8799       j=i+4
8800       k=i+1
8801       l=i+3
8802       iti=itortyp(itype(i))
8803       itk=itortyp(itype(k))
8804       itk1=itortyp(itype(k+1))
8805       itl=itortyp(itype(l))
8806       itj=itortyp(itype(j))
8807 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8808 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8809 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8810 cd        eello6=0.0d0
8811 cd        return
8812 cd      endif
8813 cd      write (iout,*)
8814 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8815 cd     &   ' and',k,l
8816 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8817       do iii=1,2
8818         do kkk=1,5
8819           do lll=1,3
8820             derx_turn(lll,kkk,iii)=0.0d0
8821           enddo
8822         enddo
8823       enddo
8824 cd      eij=1.0d0
8825 cd      ekl=1.0d0
8826 cd      ekont=1.0d0
8827       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8828 cd      eello6_5=0.0d0
8829 cd      write (2,*) 'eello6_5',eello6_5
8830 #ifdef MOMENT
8831       call transpose2(AEA(1,1,1),auxmat(1,1))
8832       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8833       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8834       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8835 #endif
8836       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8837       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8838       s2 = scalar2(b1(1,itk),vtemp1(1))
8839 #ifdef MOMENT
8840       call transpose2(AEA(1,1,2),atemp(1,1))
8841       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8842       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8843       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8844 #endif
8845       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8846       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8847       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8848 #ifdef MOMENT
8849       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8850       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8851       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8852       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8853       ss13 = scalar2(b1(1,itk),vtemp4(1))
8854       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8855 #endif
8856 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8857 c      s1=0.0d0
8858 c      s2=0.0d0
8859 c      s8=0.0d0
8860 c      s12=0.0d0
8861 c      s13=0.0d0
8862       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8863 C Derivatives in gamma(i+2)
8864       s1d =0.0d0
8865       s8d =0.0d0
8866 #ifdef MOMENT
8867       call transpose2(AEA(1,1,1),auxmatd(1,1))
8868       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8869       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8870       call transpose2(AEAderg(1,1,2),atempd(1,1))
8871       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8872       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8873 #endif
8874       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8875       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8876       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8877 c      s1d=0.0d0
8878 c      s2d=0.0d0
8879 c      s8d=0.0d0
8880 c      s12d=0.0d0
8881 c      s13d=0.0d0
8882       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8883 C Derivatives in gamma(i+3)
8884 #ifdef MOMENT
8885       call transpose2(AEA(1,1,1),auxmatd(1,1))
8886       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8887       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8888       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8889 #endif
8890       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8891       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8892       s2d = scalar2(b1(1,itk),vtemp1d(1))
8893 #ifdef MOMENT
8894       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8895       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8896 #endif
8897       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8898 #ifdef MOMENT
8899       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8900       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8901       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8902 #endif
8903 c      s1d=0.0d0
8904 c      s2d=0.0d0
8905 c      s8d=0.0d0
8906 c      s12d=0.0d0
8907 c      s13d=0.0d0
8908 #ifdef MOMENT
8909       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8910      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8911 #else
8912       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8913      &               -0.5d0*ekont*(s2d+s12d)
8914 #endif
8915 C Derivatives in gamma(i+4)
8916       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8917       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8918       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8919 #ifdef MOMENT
8920       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8921       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8922       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8923 #endif
8924 c      s1d=0.0d0
8925 c      s2d=0.0d0
8926 c      s8d=0.0d0
8927 C      s12d=0.0d0
8928 c      s13d=0.0d0
8929 #ifdef MOMENT
8930       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8931 #else
8932       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8933 #endif
8934 C Derivatives in gamma(i+5)
8935 #ifdef MOMENT
8936       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8937       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8938       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8939 #endif
8940       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8941       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8942       s2d = scalar2(b1(1,itk),vtemp1d(1))
8943 #ifdef MOMENT
8944       call transpose2(AEA(1,1,2),atempd(1,1))
8945       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8946       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8947 #endif
8948       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8949       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8950 #ifdef MOMENT
8951       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8952       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8953       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8954 #endif
8955 c      s1d=0.0d0
8956 c      s2d=0.0d0
8957 c      s8d=0.0d0
8958 c      s12d=0.0d0
8959 c      s13d=0.0d0
8960 #ifdef MOMENT
8961       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8962      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8963 #else
8964       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8965      &               -0.5d0*ekont*(s2d+s12d)
8966 #endif
8967 C Cartesian derivatives
8968       do iii=1,2
8969         do kkk=1,5
8970           do lll=1,3
8971 #ifdef MOMENT
8972             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8973             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8974             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8975 #endif
8976             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8977             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8978      &          vtemp1d(1))
8979             s2d = scalar2(b1(1,itk),vtemp1d(1))
8980 #ifdef MOMENT
8981             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8982             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8983             s8d = -(atempd(1,1)+atempd(2,2))*
8984      &           scalar2(cc(1,1,itl),vtemp2(1))
8985 #endif
8986             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8987      &           auxmatd(1,1))
8988             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8989             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8990 c      s1d=0.0d0
8991 c      s2d=0.0d0
8992 c      s8d=0.0d0
8993 c      s12d=0.0d0
8994 c      s13d=0.0d0
8995 #ifdef MOMENT
8996             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8997      &        - 0.5d0*(s1d+s2d)
8998 #else
8999             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9000      &        - 0.5d0*s2d
9001 #endif
9002 #ifdef MOMENT
9003             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9004      &        - 0.5d0*(s8d+s12d)
9005 #else
9006             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9007      &        - 0.5d0*s12d
9008 #endif
9009           enddo
9010         enddo
9011       enddo
9012 #ifdef MOMENT
9013       do kkk=1,5
9014         do lll=1,3
9015           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9016      &      achuj_tempd(1,1))
9017           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9018           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9019           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9020           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9021           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9022      &      vtemp4d(1))
9023           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9024           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9025           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9026         enddo
9027       enddo
9028 #endif
9029 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9030 cd     &  16*eel_turn6_num
9031 cd      goto 1112
9032       if (j.lt.nres-1) then
9033         j1=j+1
9034         j2=j-1
9035       else
9036         j1=j-1
9037         j2=j-2
9038       endif
9039       if (l.lt.nres-1) then
9040         l1=l+1
9041         l2=l-1
9042       else
9043         l1=l-1
9044         l2=l-2
9045       endif
9046       do ll=1,3
9047 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9048 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9049 cgrad        ghalf=0.5d0*ggg1(ll)
9050 cd        ghalf=0.0d0
9051         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9052         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9053         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9054      &    +ekont*derx_turn(ll,2,1)
9055         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9056         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9057      &    +ekont*derx_turn(ll,4,1)
9058         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9059         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9060         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9061 cgrad        ghalf=0.5d0*ggg2(ll)
9062 cd        ghalf=0.0d0
9063         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9064      &    +ekont*derx_turn(ll,2,2)
9065         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9066         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9067      &    +ekont*derx_turn(ll,4,2)
9068         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9069         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9070         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9071       enddo
9072 cd      goto 1112
9073 cgrad      do m=i+1,j-1
9074 cgrad        do ll=1,3
9075 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9076 cgrad        enddo
9077 cgrad      enddo
9078 cgrad      do m=k+1,l-1
9079 cgrad        do ll=1,3
9080 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9081 cgrad        enddo
9082 cgrad      enddo
9083 cgrad1112  continue
9084 cgrad      do m=i+2,j2
9085 cgrad        do ll=1,3
9086 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9087 cgrad        enddo
9088 cgrad      enddo
9089 cgrad      do m=k+2,l2
9090 cgrad        do ll=1,3
9091 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9092 cgrad        enddo
9093 cgrad      enddo
9094 cd      do iii=1,nres-3
9095 cd        write (2,*) iii,g_corr6_loc(iii)
9096 cd      enddo
9097       eello_turn6=ekont*eel_turn6
9098 cd      write (2,*) 'ekont',ekont
9099 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9100       return
9101       end
9102
9103 C-----------------------------------------------------------------------------
9104       double precision function scalar(u,v)
9105 !DIR$ INLINEALWAYS scalar
9106 #ifndef OSF
9107 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9108 #endif
9109       implicit none
9110       double precision u(3),v(3)
9111 cd      double precision sc
9112 cd      integer i
9113 cd      sc=0.0d0
9114 cd      do i=1,3
9115 cd        sc=sc+u(i)*v(i)
9116 cd      enddo
9117 cd      scalar=sc
9118
9119       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9120       return
9121       end
9122 crc-------------------------------------------------
9123       SUBROUTINE MATVEC2(A1,V1,V2)
9124 !DIR$ INLINEALWAYS MATVEC2
9125 #ifndef OSF
9126 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9127 #endif
9128       implicit real*8 (a-h,o-z)
9129       include 'DIMENSIONS'
9130       DIMENSION A1(2,2),V1(2),V2(2)
9131 c      DO 1 I=1,2
9132 c        VI=0.0
9133 c        DO 3 K=1,2
9134 c    3     VI=VI+A1(I,K)*V1(K)
9135 c        Vaux(I)=VI
9136 c    1 CONTINUE
9137
9138       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9139       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9140
9141       v2(1)=vaux1
9142       v2(2)=vaux2
9143       END
9144 C---------------------------------------
9145       SUBROUTINE MATMAT2(A1,A2,A3)
9146 #ifndef OSF
9147 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9148 #endif
9149       implicit real*8 (a-h,o-z)
9150       include 'DIMENSIONS'
9151       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9152 c      DIMENSION AI3(2,2)
9153 c        DO  J=1,2
9154 c          A3IJ=0.0
9155 c          DO K=1,2
9156 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9157 c          enddo
9158 c          A3(I,J)=A3IJ
9159 c       enddo
9160 c      enddo
9161
9162       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9163       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9164       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9165       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9166
9167       A3(1,1)=AI3_11
9168       A3(2,1)=AI3_21
9169       A3(1,2)=AI3_12
9170       A3(2,2)=AI3_22
9171       END
9172
9173 c-------------------------------------------------------------------------
9174       double precision function scalar2(u,v)
9175 !DIR$ INLINEALWAYS scalar2
9176       implicit none
9177       double precision u(2),v(2)
9178       double precision sc
9179       integer i
9180       scalar2=u(1)*v(1)+u(2)*v(2)
9181       return
9182       end
9183
9184 C-----------------------------------------------------------------------------
9185
9186       subroutine transpose2(a,at)
9187 !DIR$ INLINEALWAYS transpose2
9188 #ifndef OSF
9189 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9190 #endif
9191       implicit none
9192       double precision a(2,2),at(2,2)
9193       at(1,1)=a(1,1)
9194       at(1,2)=a(2,1)
9195       at(2,1)=a(1,2)
9196       at(2,2)=a(2,2)
9197       return
9198       end
9199 c--------------------------------------------------------------------------
9200       subroutine transpose(n,a,at)
9201       implicit none
9202       integer n,i,j
9203       double precision a(n,n),at(n,n)
9204       do i=1,n
9205         do j=1,n
9206           at(j,i)=a(i,j)
9207         enddo
9208       enddo
9209       return
9210       end
9211 C---------------------------------------------------------------------------
9212       subroutine prodmat3(a1,a2,kk,transp,prod)
9213 !DIR$ INLINEALWAYS prodmat3
9214 #ifndef OSF
9215 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9216 #endif
9217       implicit none
9218       integer i,j
9219       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9220       logical transp
9221 crc      double precision auxmat(2,2),prod_(2,2)
9222
9223       if (transp) then
9224 crc        call transpose2(kk(1,1),auxmat(1,1))
9225 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9226 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9227
9228            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9229      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9230            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9231      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9232            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9233      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9234            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9235      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9236
9237       else
9238 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9239 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9240
9241            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9242      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9243            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9244      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9245            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9246      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9247            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9248      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9249
9250       endif
9251 c      call transpose2(a2(1,1),a2t(1,1))
9252
9253 crc      print *,transp
9254 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9255 crc      print *,((prod(i,j),i=1,2),j=1,2)
9256
9257       return
9258       end
9259