source/unres/src_MD_DFA/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
 135 C     BARTEK for dfa test!
 136       if (wdfa_dist.gt.0) call edfad(edfadis)
 137 c      print*, 'edfad is finished!', edfadis
 138       if (wdfa_tor.gt.0) call edfat(edfator)
 139 c      print*, 'edfat is finished!', edfator
 140       if (wdfa_nei.gt.0) call edfan(edfanei)
 141 c      print*, 'edfan is finished!', edfanei
 142       if (wdfa_beta.gt.0) call edfab(edfabet)
 143 c      print*, 'edfab is finished!', edfabet
 144 C      stop
 145 C     BARTEK
 146
 147 c      print *,"Processor",myrank," computed USCSC"
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time01=MPI_Wtime()
 151 #else
 152       time00=tcpu()
 153 #endif
 154 #endif
 155       call vec_and_deriv
 156 #ifdef TIMING
 157 #ifdef MPI
 158       time_vec=time_vec+MPI_Wtime()-time01
 159 #else
 160       time_vec=time_vec+tcpu()-time01
 161 #endif
 162 #endif
 163 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 164       if (ipot.lt.6) then
 165 #ifdef SPLITELE
 166          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 167      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 168      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 169      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 170 #else
 171          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 172      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 173      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 174      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 175 #endif
 176             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 177          else
 178             ees=0.0d0
 179             evdw1=0.0d0
 180             eel_loc=0.0d0
 181             eello_turn3=0.0d0
 182             eello_turn4=0.0d0
 183          endif
 184       else
 185 c        write (iout,*) "Soft-spheer ELEC potential"
 186         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 187      &   eello_turn4)
 188       endif
 189 c      print *,"Processor",myrank," computed UELEC"
 190 C
 191 C Calculate excluded-volume interaction energy between peptide groups
 192 C and side chains.
 193 C
 194       if (ipot.lt.6) then
 195        if(wscp.gt.0d0) then
 196         call escp(evdw2,evdw2_14)
 197        else
 198         evdw2=0
 199         evdw2_14=0
 200        endif
 201       else
 202 c        write (iout,*) "Soft-sphere SCP potential"
 203         call escp_soft_sphere(evdw2,evdw2_14)
 204       endif
 205 c
 206 c Calculate the bond-stretching energy
 207 c
 208       call ebond(estr)
 209 C
 210 C Calculate the disulfide-bridge and other energy and the contributions
 211 C from other distance constraints.
 212 cd    print *,'Calling EHPB'
 213       call edis(ehpb)
 214 cd    print *,'EHPB exitted succesfully.'
 215 C
 216 C Calculate the virtual-bond-angle energy.
 217 C
 218       if (wang.gt.0d0) then
 219         call ebend(ebe)
 220       else
 221         ebe=0
 222       endif
 223 c      print *,"Processor",myrank," computed UB"
 224 C
 225 C Calculate the SC local energy.
 226 C
 227       call esc(escloc)
 228 c      print *,"Processor",myrank," computed USC"
 229 C
 230 C Calculate the virtual-bond torsional energy.
 231 C
 232 cd    print *,'nterm=',nterm
 233       if (wtor.gt.0) then
 234        call etor(etors,edihcnstr)
 235       else
 236        etors=0
 237        edihcnstr=0
 238       endif
 239 c      print *,"Processor",myrank," computed Utor"
 240 C
 241 C 6/23/01 Calculate double-torsional energy
 242 C
 243       if (wtor_d.gt.0) then
 244        call etor_d(etors_d)
 245       else
 246        etors_d=0
 247       endif
 248 c      print *,"Processor",myrank," computed Utord"
 249 C
 250 C 21/5/07 Calculate local sicdechain correlation energy
 251 C
 252       if (wsccor.gt.0.0d0) then
 253         call eback_sc_corr(esccor)
 254       else
 255         esccor=0.0d0
 256       endif
 257 c      print *,"Processor",myrank," computed Usccorr"
 258 C
 259 C 12/1/95 Multi-body terms
 260 C
 261       n_corr=0
 262       n_corr1=0
 263       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 264      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 265          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 266 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 267 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 268       else
 269          ecorr=0.0d0
 270          ecorr5=0.0d0
 271          ecorr6=0.0d0
 272          eturn6=0.0d0
 273       endif
 274       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 275          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 276 cd         write (iout,*) "multibody_hb ecorr",ecorr
 277       endif
 278 c      print *,"Processor",myrank," computed Ucorr"
 279 C
 280 C If performing constraint dynamics, call the constraint energy
 281 C  after the equilibration time
 282       if(usampl.and.totT.gt.eq_time) then
 283          call EconstrQ
 284          call Econstr_back
 285       else
 286          Uconst=0.0d0
 287          Uconst_back=0.0d0
 288       endif
 289 #ifdef TIMING
 290 #ifdef MPI
 291       time_enecalc=time_enecalc+MPI_Wtime()-time00
 292 #else
 293       time_enecalc=time_enecalc+tcpu()-time00
 294 #endif
 295 #endif
 296 c      print *,"Processor",myrank," computed Uconstr"
 297 #ifdef TIMING
 298 #ifdef MPI
 299       time00=MPI_Wtime()
 300 #else
 301       time00=tcpu()
 302 #endif
 303 #endif
 304 c
 305 C Sum the energies
 306 C
 307       energia(1)=evdw
 308 #ifdef SCP14
 309       energia(2)=evdw2-evdw2_14
 310       energia(18)=evdw2_14
 311 #else
 312       energia(2)=evdw2
 313       energia(18)=0.0d0
 314 #endif
 315 #ifdef SPLITELE
 316       energia(3)=ees
 317       energia(16)=evdw1
 318 #else
 319       energia(3)=ees+evdw1
 320       energia(16)=0.0d0
 321 #endif
 322       energia(4)=ecorr
 323       energia(5)=ecorr5
 324       energia(6)=ecorr6
 325       energia(7)=eel_loc
 326       energia(8)=eello_turn3
 327       energia(9)=eello_turn4
 328       energia(10)=eturn6
 329       energia(11)=ebe
 330       energia(12)=escloc
 331       energia(13)=etors
 332       energia(14)=etors_d
 333       energia(15)=ehpb
 334       energia(19)=edihcnstr
 335       energia(17)=estr
 336       energia(20)=Uconst+Uconst_back
 337       energia(21)=esccor
 338       energia(22)=evdw_p
 339       energia(23)=evdw_m
 340       energia(24)=edfadis
 341       energia(25)=edfator
 342       energia(26)=edfanei
 343       energia(27)=edfabet
 344 c      print *," Processor",myrank," calls SUM_ENERGY"
 345       call sum_energy(energia,.true.)
 346 c      print *," Processor",myrank," left SUM_ENERGY"
 347 #ifdef TIMING
 348 #ifdef MPI
 349       time_sumene=time_sumene+MPI_Wtime()-time00
 350 #else
 351       time_sumene=time_sumene+tcpu()-time00
 352 #endif
 353 #endif
 354       return
 355       end
 356 c-------------------------------------------------------------------------------
 357       subroutine sum_energy(energia,reduce)
 358       implicit real*8 (a-h,o-z)
 359       include 'DIMENSIONS'
 360 #ifndef ISNAN
 361       external proc_proc
 362 #ifdef WINPGI
 363 cMS$ATTRIBUTES C ::  proc_proc
 364 #endif
 365 #endif
 366 #ifdef MPI
 367       include "mpif.h"
 368 #endif
 369       include 'COMMON.SETUP'
 370       include 'COMMON.IOUNITS'
 371       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 372       include 'COMMON.FFIELD'
 373       include 'COMMON.DERIV'
 374       include 'COMMON.INTERACT'
 375       include 'COMMON.SBRIDGE'
 376       include 'COMMON.CHAIN'
 377       include 'COMMON.VAR'
 378       include 'COMMON.CONTROL'
 379       include 'COMMON.TIME1'
 380       logical reduce
 381 #ifdef MPI
 382       if (nfgtasks.gt.1 .and. reduce) then
 383 #ifdef DEBUG
 384         write (iout,*) "energies before REDUCE"
 385         call enerprint(energia)
 386         call flush(iout)
 387 #endif
 388         do i=0,n_ene
 389           enebuff(i)=energia(i)
 390         enddo
 391         time00=MPI_Wtime()
 392         call MPI_Barrier(FG_COMM,IERR)
 393         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 394         time00=MPI_Wtime()
 395         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 396      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 397 #ifdef DEBUG
 398         write (iout,*) "energies after REDUCE"
 399         call enerprint(energia)
 400         call flush(iout)
 401 #endif
 402         time_Reduce=time_Reduce+MPI_Wtime()-time00
 403       endif
 404       if (fg_rank.eq.0) then
 405 #endif
 406 #ifdef TSCSC
 407       evdw=energia(22)+wsct*energia(23)
 408 #else
 409       evdw=energia(1)
 410 #endif
 411 #ifdef SCP14
 412       evdw2=energia(2)+energia(18)
 413       evdw2_14=energia(18)
 414 #else
 415       evdw2=energia(2)
 416 #endif
 417 #ifdef SPLITELE
 418       ees=energia(3)
 419       evdw1=energia(16)
 420 #else
 421       ees=energia(3)
 422       evdw1=0.0d0
 423 #endif
 424       ecorr=energia(4)
 425       ecorr5=energia(5)
 426       ecorr6=energia(6)
 427       eel_loc=energia(7)
 428       eello_turn3=energia(8)
 429       eello_turn4=energia(9)
 430       eturn6=energia(10)
 431       ebe=energia(11)
 432       escloc=energia(12)
 433       etors=energia(13)
 434       etors_d=energia(14)
 435       ehpb=energia(15)
 436       edihcnstr=energia(19)
 437       estr=energia(17)
 438       Uconst=energia(20)
 439       esccor=energia(21)
 440       edfadis=energia(24)
 441       edfator=energia(25)
 442       edfanei=energia(26)
 443       edfabet=energia(27)
 444 #ifdef SPLITELE
 445       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 446      & +wang*ebe+wtor*etors+wscloc*escloc
 447      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 448      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 449      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 450      & +wbond*estr+Uconst+wsccor*esccor
 451      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 452      & +wdfa_beta*edfabet
 453 #else
 454       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 455      & +wang*ebe+wtor*etors+wscloc*escloc
 456      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 457      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 458      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 459      & +wbond*estr+Uconst+wsccor*esccor
 460      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 461      & +wdfa_beta*edfabet
 462
 463 #endif
 464       energia(0)=etot
 465 c detecting NaNQ
 466 #ifdef ISNAN
 467 #ifdef AIX
 468       if (isnan(etot).ne.0) energia(0)=1.0d+99
 469 #else
 470       if (isnan(etot)) energia(0)=1.0d+99
 471 #endif
 472 #else
 473       i=0
 474 #ifdef WINPGI
 475       idumm=proc_proc(etot,i)
 476 #else
 477       call proc_proc(etot,i)
 478 #endif
 479       if(i.eq.1)energia(0)=1.0d+99
 480 #endif
 481 #ifdef MPI
 482       endif
 483 #endif
 484       return
 485       end
 486 c-------------------------------------------------------------------------------
 487       subroutine sum_gradient
 488       implicit real*8 (a-h,o-z)
 489       include 'DIMENSIONS'
 490 #ifndef ISNAN
 491       external proc_proc
 492 #ifdef WINPGI
 493 cMS$ATTRIBUTES C ::  proc_proc
 494 #endif
 495 #endif
 496 #ifdef MPI
 497       include 'mpif.h'
 498 #endif
 499       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 500      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 501       include 'COMMON.SETUP'
 502       include 'COMMON.IOUNITS'
 503       include 'COMMON.FFIELD'
 504       include 'COMMON.DERIV'
 505       include 'COMMON.INTERACT'
 506       include 'COMMON.SBRIDGE'
 507       include 'COMMON.CHAIN'
 508       include 'COMMON.VAR'
 509       include 'COMMON.CONTROL'
 510       include 'COMMON.TIME1'
 511       include 'COMMON.MAXGRAD'
 512       include 'COMMON.SCCOR'
 513 #ifdef TIMING
 514 #ifdef MPI
 515       time01=MPI_Wtime()
 516 #else
 517       time01=tcpu()
 518 #endif
 519 #endif
 520 #ifdef DEBUG
 521       write (iout,*) "sum_gradient gvdwc, gvdwx"
 522       do i=1,nres
 523         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 524      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 525      &   (gvdwcT(j,i),j=1,3)
 526       enddo
 527       call flush(iout)
 528 #endif
 529 #ifdef MPI
 530 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 531         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 532      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 533 #endif
 534 C
 535 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 536 C            in virtual-bond-vector coordinates
 537 C
 538 #ifdef DEBUG
 539 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 540 c      do i=1,nres-1
 541 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 542 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 543 c      enddo
 544 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 545 c      do i=1,nres-1
 546 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 547 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 548 c      enddo
 549       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 550       do i=1,nres
 551         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 552      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 553      &   g_corr5_loc(i)
 554       enddo
 555       call flush(iout)
 556 #endif
 557 #ifdef SPLITELE
 558 #ifdef TSCSC
 559       do i=1,nct
 560         do j=1,3
 561           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 562      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 563      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 564      &                wel_loc*gel_loc_long(j,i)+
 565      &                wcorr*gradcorr_long(j,i)+
 566      &                wcorr5*gradcorr5_long(j,i)+
 567      &                wcorr6*gradcorr6_long(j,i)+
 568      &                wturn6*gcorr6_turn_long(j,i)+
 569      &                wstrain*ghpbc(j,i)+
 570      &                wdfa_dist*gdfad(j,i)+
 571      &                wdfa_tor*gdfat(j,i)+
 572      &                wdfa_nei*gdfan(j,i)+
 573      &                wdfa_beta*gdfab(j,i)
 574
 575         enddo
 576       enddo
 577 #else
 578       do i=1,nct
 579         do j=1,3
 580           gradbufc(j,i)=wsc*gvdwc(j,i)+
 581      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 582      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 583      &                wel_loc*gel_loc_long(j,i)+
 584      &                wcorr*gradcorr_long(j,i)+
 585      &                wcorr5*gradcorr5_long(j,i)+
 586      &                wcorr6*gradcorr6_long(j,i)+
 587      &                wturn6*gcorr6_turn_long(j,i)+
 588      &                wstrain*ghpbc(j,i)+
 589      &                wdfa_dist*gdfad(j,i)+
 590      &                wdfa_tor*gdfat(j,i)+
 591      &                wdfa_nei*gdfan(j,i)+
 592      &                wdfa_beta*gdfab(j,i)
 593
 594         enddo
 595       enddo
 596 #endif
 597 #else
 598       do i=1,nct
 599         do j=1,3
 600           gradbufc(j,i)=wsc*gvdwc(j,i)+
 601      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 602      &                welec*gelc_long(j,i)+
 603      &                wbond*gradb(j,i)+
 604      &                wel_loc*gel_loc_long(j,i)+
 605      &                wcorr*gradcorr_long(j,i)+
 606      &                wcorr5*gradcorr5_long(j,i)+
 607      &                wcorr6*gradcorr6_long(j,i)+
 608      &                wturn6*gcorr6_turn_long(j,i)+
 609      &                wstrain*ghpbc(j,i)+
 610      &                wdfa_dist*gdfad(j,i)+
 611      &                wdfa_tor*gdfat(j,i)+
 612      &                wdfa_nei*gdfan(j,i)+
 613      &                wdfa_beta*gdfab(j,i)
 614
 615
 616         enddo
 617       enddo
 618 #endif
 619 #ifdef MPI
 620       if (nfgtasks.gt.1) then
 621       time00=MPI_Wtime()
 622 #ifdef DEBUG
 623       write (iout,*) "gradbufc before allreduce"
 624       do i=1,nres
 625         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 626       enddo
 627       call flush(iout)
 628 #endif
 629       do i=1,nres
 630         do j=1,3
 631           gradbufc_sum(j,i)=gradbufc(j,i)
 632         enddo
 633       enddo
 634 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 635 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 636 c      time_reduce=time_reduce+MPI_Wtime()-time00
 637 #ifdef DEBUG
 638 c      write (iout,*) "gradbufc_sum after allreduce"
 639 c      do i=1,nres
 640 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 641 c      enddo
 642 c      call flush(iout)
 643 #endif
 644 #ifdef TIMING
 645 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 646 #endif
 647       do i=nnt,nres
 648         do k=1,3
 649           gradbufc(k,i)=0.0d0
 650         enddo
 651       enddo
 652 #ifdef DEBUG
 653       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 654       write (iout,*) (i," jgrad_start",jgrad_start(i),
 655      &                  " jgrad_end  ",jgrad_end(i),
 656      &                  i=igrad_start,igrad_end)
 657 #endif
 658 c
 659 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 660 c do not parallelize this part.
 661 c
 662 c      do i=igrad_start,igrad_end
 663 c        do j=jgrad_start(i),jgrad_end(i)
 664 c          do k=1,3
 665 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 666 c          enddo
 667 c        enddo
 668 c      enddo
 669       do j=1,3
 670         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 671       enddo
 672       do i=nres-2,nnt,-1
 673         do j=1,3
 674           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 675         enddo
 676       enddo
 677 #ifdef DEBUG
 678       write (iout,*) "gradbufc after summing"
 679       do i=1,nres
 680         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 681       enddo
 682       call flush(iout)
 683 #endif
 684       else
 685 #endif
 686 #ifdef DEBUG
 687       write (iout,*) "gradbufc"
 688       do i=1,nres
 689         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 690       enddo
 691       call flush(iout)
 692 #endif
 693       do i=1,nres
 694         do j=1,3
 695           gradbufc_sum(j,i)=gradbufc(j,i)
 696           gradbufc(j,i)=0.0d0
 697         enddo
 698       enddo
 699       do j=1,3
 700         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 701       enddo
 702       do i=nres-2,nnt,-1
 703         do j=1,3
 704           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 705         enddo
 706       enddo
 707 c      do i=nnt,nres-1
 708 c        do k=1,3
 709 c          gradbufc(k,i)=0.0d0
 710 c        enddo
 711 c        do j=i+1,nres
 712 c          do k=1,3
 713 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 714 c          enddo
 715 c        enddo
 716 c      enddo
 717 #ifdef DEBUG
 718       write (iout,*) "gradbufc after summing"
 719       do i=1,nres
 720         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 721       enddo
 722       call flush(iout)
 723 #endif
 724 #ifdef MPI
 725       endif
 726 #endif
 727       do k=1,3
 728         gradbufc(k,nres)=0.0d0
 729       enddo
 730       do i=1,nct
 731         do j=1,3
 732 #ifdef SPLITELE
 733           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 734      &                wel_loc*gel_loc(j,i)+
 735      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 736      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 737      &                wel_loc*gel_loc_long(j,i)+
 738      &                wcorr*gradcorr_long(j,i)+
 739      &                wcorr5*gradcorr5_long(j,i)+
 740      &                wcorr6*gradcorr6_long(j,i)+
 741      &                wturn6*gcorr6_turn_long(j,i))+
 742      &                wbond*gradb(j,i)+
 743      &                wcorr*gradcorr(j,i)+
 744      &                wturn3*gcorr3_turn(j,i)+
 745      &                wturn4*gcorr4_turn(j,i)+
 746      &                wcorr5*gradcorr5(j,i)+
 747      &                wcorr6*gradcorr6(j,i)+
 748      &                wturn6*gcorr6_turn(j,i)+
 749      &                wsccor*gsccorc(j,i)
 750      &               +wscloc*gscloc(j,i)
 751 #else
 752           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 753      &                wel_loc*gel_loc(j,i)+
 754      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 755      &                welec*gelc_long(j,i)+
 756      &                wel_loc*gel_loc_long(j,i)+
 757      &                wcorr*gcorr_long(j,i)+
 758      &                wcorr5*gradcorr5_long(j,i)+
 759      &                wcorr6*gradcorr6_long(j,i)+
 760      &                wturn6*gcorr6_turn_long(j,i))+
 761      &                wbond*gradb(j,i)+
 762      &                wcorr*gradcorr(j,i)+
 763      &                wturn3*gcorr3_turn(j,i)+
 764      &                wturn4*gcorr4_turn(j,i)+
 765      &                wcorr5*gradcorr5(j,i)+
 766      &                wcorr6*gradcorr6(j,i)+
 767      &                wturn6*gcorr6_turn(j,i)+
 768      &                wsccor*gsccorc(j,i)
 769      &               +wscloc*gscloc(j,i)
 770 #endif
 771 #ifdef TSCSC
 772           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 773      &                  wscp*gradx_scp(j,i)+
 774      &                  wbond*gradbx(j,i)+
 775      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 776      &                  wsccor*gsccorx(j,i)
 777      &                 +wscloc*gsclocx(j,i)
 778 #else
 779           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 780      &                  wbond*gradbx(j,i)+
 781      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 782      &                  wsccor*gsccorx(j,i)
 783      &                 +wscloc*gsclocx(j,i)
 784 #endif
 785         enddo
 786       enddo
 787 #ifdef DEBUG
 788       write (iout,*) "gloc before adding corr"
 789       do i=1,4*nres
 790         write (iout,*) i,gloc(i,icg)
 791       enddo
 792 #endif
 793       do i=1,nres-3
 794         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 795      &   +wcorr5*g_corr5_loc(i)
 796      &   +wcorr6*g_corr6_loc(i)
 797      &   +wturn4*gel_loc_turn4(i)
 798      &   +wturn3*gel_loc_turn3(i)
 799      &   +wturn6*gel_loc_turn6(i)
 800      &   +wel_loc*gel_loc_loc(i)
 801      &   +wsccor*gsccor_loc(i)
 802       enddo
 803 #ifdef DEBUG
 804       write (iout,*) "gloc after adding corr"
 805       do i=1,4*nres
 806         write (iout,*) i,gloc(i,icg)
 807       enddo
 808 #endif
 809 #ifdef MPI
 810       if (nfgtasks.gt.1) then
 811         do j=1,3
 812           do i=1,nres
 813             gradbufc(j,i)=gradc(j,i,icg)
 814             gradbufx(j,i)=gradx(j,i,icg)
 815           enddo
 816         enddo
 817         do i=1,4*nres
 818           glocbuf(i)=gloc(i,icg)
 819         enddo
 820 #define DEBUG
 821 #ifdef DEBUG
 822       write (iout,*) "gloc_sc before reduce"
 823       do i=1,nres
 824        do j=1,3
 825         write (iout,*) i,j,gloc_sc(j,i,icg)
 826        enddo
 827       enddo
 828 #endif
 829 #undef DEBUG
 830         do i=1,nres
 831          do j=1,3
 832           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 833          enddo
 834         enddo
 835         time00=MPI_Wtime()
 836         call MPI_Barrier(FG_COMM,IERR)
 837         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 838         time00=MPI_Wtime()
 839         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 840      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 841         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 842      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 843         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 844      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 845         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 846      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 847         time_reduce=time_reduce+MPI_Wtime()-time00
 848 #define DEBUG
 849 #ifdef DEBUG
 850       write (iout,*) "gloc_sc after reduce"
 851       do i=1,nres
 852        do j=1,3
 853         write (iout,*) i,j,gloc_sc(j,i,icg)
 854        enddo
 855       enddo
 856 #endif
 857 #undef DEBUG
 858 #ifdef DEBUG
 859       write (iout,*) "gloc after reduce"
 860       do i=1,4*nres
 861         write (iout,*) i,gloc(i,icg)
 862       enddo
 863 #endif
 864       endif
 865 #endif
 866       if (gnorm_check) then
 867 c
 868 c Compute the maximum elements of the gradient
 869 c
 870       gvdwc_max=0.0d0
 871       gvdwc_scp_max=0.0d0
 872       gelc_max=0.0d0
 873       gvdwpp_max=0.0d0
 874       gradb_max=0.0d0
 875       ghpbc_max=0.0d0
 876       gradcorr_max=0.0d0
 877       gel_loc_max=0.0d0
 878       gcorr3_turn_max=0.0d0
 879       gcorr4_turn_max=0.0d0
 880       gradcorr5_max=0.0d0
 881       gradcorr6_max=0.0d0
 882       gcorr6_turn_max=0.0d0
 883       gsccorc_max=0.0d0
 884       gscloc_max=0.0d0
 885       gvdwx_max=0.0d0
 886       gradx_scp_max=0.0d0
 887       ghpbx_max=0.0d0
 888       gradxorr_max=0.0d0
 889       gsccorx_max=0.0d0
 890       gsclocx_max=0.0d0
 891       do i=1,nct
 892         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 893         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 894 #ifdef TSCSC
 895         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 896         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 897 #endif
 898         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 899         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 900      &   gvdwc_scp_max=gvdwc_scp_norm
 901         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 902         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 903         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 904         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 905         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 906         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 907         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 908         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 909         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 910         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 911         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 912         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 913         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 914      &    gcorr3_turn(1,i)))
 915         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 916      &    gcorr3_turn_max=gcorr3_turn_norm
 917         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 918      &    gcorr4_turn(1,i)))
 919         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 920      &    gcorr4_turn_max=gcorr4_turn_norm
 921         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 922         if (gradcorr5_norm.gt.gradcorr5_max)
 923      &    gradcorr5_max=gradcorr5_norm
 924         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 925         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 926         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 927      &    gcorr6_turn(1,i)))
 928         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 929      &    gcorr6_turn_max=gcorr6_turn_norm
 930         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 931         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 932         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 933         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 934         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 935         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 936 #ifdef TSCSC
 937         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 938         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 939 #endif
 940         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 941         if (gradx_scp_norm.gt.gradx_scp_max)
 942      &    gradx_scp_max=gradx_scp_norm
 943         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 944         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 945         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 946         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 947         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 948         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 949         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 950         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 951       enddo
 952       if (gradout) then
 953 #ifdef AIX
 954         open(istat,file=statname,position="append")
 955 #else
 956         open(istat,file=statname,access="append")
 957 #endif
 958         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 959      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 960      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 961      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 962      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 963      &     gsccorx_max,gsclocx_max
 964         close(istat)
 965         if (gvdwc_max.gt.1.0d4) then
 966           write (iout,*) "gvdwc gvdwx gradb gradbx"
 967           do i=nnt,nct
 968             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 969      &        gradb(j,i),gradbx(j,i),j=1,3)
 970           enddo
 971           call pdbout(0.0d0,'cipiszcze',iout)
 972           call flush(iout)
 973         endif
 974       endif
 975       endif
 976 #ifdef DEBUG
 977       write (iout,*) "gradc gradx gloc"
 978       do i=1,nres
 979         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 980      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 981       enddo
 982 #endif
 983 #ifdef TIMING
 984 #ifdef MPI
 985       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 986 #else
 987       time_sumgradient=time_sumgradient+tcpu()-time01
 988 #endif
 989 #endif
 990       return
 991       end
 992 c-------------------------------------------------------------------------------
 993       subroutine rescale_weights(t_bath)
 994       implicit real*8 (a-h,o-z)
 995       include 'DIMENSIONS'
 996       include 'COMMON.IOUNITS'
 997       include 'COMMON.FFIELD'
 998       include 'COMMON.SBRIDGE'
 999       double precision kfac /2.4d0/
1000       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1001 c      facT=temp0/t_bath
1002 c      facT=2*temp0/(t_bath+temp0)
1003       if (rescale_mode.eq.0) then
1004         facT=1.0d0
1005         facT2=1.0d0
1006         facT3=1.0d0
1007         facT4=1.0d0
1008         facT5=1.0d0
1009       else if (rescale_mode.eq.1) then
1010         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1011         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1012         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1013         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1014         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1015       else if (rescale_mode.eq.2) then
1016         x=t_bath/temp0
1017         x2=x*x
1018         x3=x2*x
1019         x4=x3*x
1020         x5=x4*x
1021         facT=licznik/dlog(dexp(x)+dexp(-x))
1022         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1023         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1024         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1025         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1026       else
1027         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1028         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1029 #ifdef MPI
1030        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1031 #endif
1032        stop 555
1033       endif
1034       welec=weights(3)*fact
1035       wcorr=weights(4)*fact3
1036       wcorr5=weights(5)*fact4
1037       wcorr6=weights(6)*fact5
1038       wel_loc=weights(7)*fact2
1039       wturn3=weights(8)*fact2
1040       wturn4=weights(9)*fact3
1041       wturn6=weights(10)*fact5
1042       wtor=weights(13)*fact
1043       wtor_d=weights(14)*fact2
1044       wsccor=weights(21)*fact
1045 #ifdef TSCSC
1046 c      wsct=t_bath/temp0
1047       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1048 #endif
1049       return
1050       end
1051 C------------------------------------------------------------------------
1052       subroutine enerprint(energia)
1053       implicit real*8 (a-h,o-z)
1054       include 'DIMENSIONS'
1055       include 'COMMON.IOUNITS'
1056       include 'COMMON.FFIELD'
1057       include 'COMMON.SBRIDGE'
1058       include 'COMMON.MD'
1059       double precision energia(0:n_ene)
1060       etot=energia(0)
1061 #ifdef TSCSC
1062       evdw=energia(22)+wsct*energia(23)
1063 #else
1064       evdw=energia(1)
1065 #endif
1066       evdw2=energia(2)
1067 #ifdef SCP14
1068       evdw2=energia(2)+energia(18)
1069 #else
1070       evdw2=energia(2)
1071 #endif
1072       ees=energia(3)
1073 #ifdef SPLITELE
1074       evdw1=energia(16)
1075 #endif
1076       ecorr=energia(4)
1077       ecorr5=energia(5)
1078       ecorr6=energia(6)
1079       eel_loc=energia(7)
1080       eello_turn3=energia(8)
1081       eello_turn4=energia(9)
1082       eello_turn6=energia(10)
1083       ebe=energia(11)
1084       escloc=energia(12)
1085       etors=energia(13)
1086       etors_d=energia(14)
1087       ehpb=energia(15)
1088       edihcnstr=energia(19)
1089       estr=energia(17)
1090       Uconst=energia(20)
1091       esccor=energia(21)
1092 C     Bartek
1093       edfadis = energia(24)
1094       edfator = energia(25)
1095       edfanei = energia(26)
1096       edfabet = energia(27)
1097
1098 #ifdef SPLITELE
1099       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1100      &  estr,wbond,ebe,wang,
1101      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1102      &  ecorr,wcorr,
1103      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1104      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1105      &  edihcnstr,ebr*nss,
1106      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
1107    10 format (/'Virtual-chain energies:'//
1108      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1109      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1110      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1111      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1112      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1113      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1114      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1115      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1116      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1117      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1118      & ' (SS bridges & dist. cnstr.)'/
1119      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1120      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1121      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1122      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1123      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1124      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1125      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1126      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1127      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1128      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1129      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1130      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1131      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1132      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1133      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1134      & 'ETOT=  ',1pE16.6,' (total)')
1135 #else
1136       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1137      &  estr,wbond,ebe,wang,
1138      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1139      &  ecorr,wcorr,
1140      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1141      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1142      &  ebr*nss,
1143      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
1144    10 format (/'Virtual-chain energies:'//
1145      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1146      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1147      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1148      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1149      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1150      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1151      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1152      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1153      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1154      & ' (SS bridges & dist. cnstr.)'/
1155      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1156      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1157      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1158      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1159      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1160      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1161      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1162      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1163      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1164      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1165      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1166      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1167      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1168      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1169      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1170      & 'ETOT=  ',1pE16.6,' (total)')
1171 #endif
1172       return
1173       end
1174 C-----------------------------------------------------------------------
1175       subroutine elj(evdw,evdw_p,evdw_m)
1176 C
1177 C This subroutine calculates the interaction energy of nonbonded side chains
1178 C assuming the LJ potential of interaction.
1179 C
1180       implicit real*8 (a-h,o-z)
1181       include 'DIMENSIONS'
1182       parameter (accur=1.0d-10)
1183       include 'COMMON.GEO'
1184       include 'COMMON.VAR'
1185       include 'COMMON.LOCAL'
1186       include 'COMMON.CHAIN'
1187       include 'COMMON.DERIV'
1188       include 'COMMON.INTERACT'
1189       include 'COMMON.TORSION'
1190       include 'COMMON.SBRIDGE'
1191       include 'COMMON.NAMES'
1192       include 'COMMON.IOUNITS'
1193       include 'COMMON.CONTACTS'
1194       dimension gg(3)
1195 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1196       evdw=0.0D0
1197       do i=iatsc_s,iatsc_e
1198         itypi=itype(i)
1199         itypi1=itype(i+1)
1200         xi=c(1,nres+i)
1201         yi=c(2,nres+i)
1202         zi=c(3,nres+i)
1203 C Change 12/1/95
1204         num_conti=0
1205 C
1206 C Calculate SC interaction energy.
1207 C
1208         do iint=1,nint_gr(i)
1209 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1210 cd   &                  'iend=',iend(i,iint)
1211           do j=istart(i,iint),iend(i,iint)
1212             itypj=itype(j)
1213             xj=c(1,nres+j)-xi
1214             yj=c(2,nres+j)-yi
1215             zj=c(3,nres+j)-zi
1216 C Change 12/1/95 to calculate four-body interactions
1217             rij=xj*xj+yj*yj+zj*zj
1218             rrij=1.0D0/rij
1219 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1220             eps0ij=eps(itypi,itypj)
1221             fac=rrij**expon2
1222             e1=fac*fac*aa(itypi,itypj)
1223             e2=fac*bb(itypi,itypj)
1224             evdwij=e1+e2
1225 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1226 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1227 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1228 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1229 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1230 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1231 #ifdef TSCSC
1232             if (bb(itypi,itypj).gt.0) then
1233                evdw_p=evdw_p+evdwij
1234             else
1235                evdw_m=evdw_m+evdwij
1236             endif
1237 #else
1238             evdw=evdw+evdwij
1239 #endif
1240 C
1241 C Calculate the components of the gradient in DC and X
1242 C
1243             fac=-rrij*(e1+evdwij)
1244             gg(1)=xj*fac
1245             gg(2)=yj*fac
1246             gg(3)=zj*fac
1247 #ifdef TSCSC
1248             if (bb(itypi,itypj).gt.0.0d0) then
1249               do k=1,3
1250                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1251                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1252                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1253                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1254               enddo
1255             else
1256               do k=1,3
1257                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1258                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1259                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1260                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1261               enddo
1262             endif
1263 #else
1264             do k=1,3
1265               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1266               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1267               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1268               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1269             enddo
1270 #endif
1271 cgrad            do k=i,j-1
1272 cgrad              do l=1,3
1273 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1274 cgrad              enddo
1275 cgrad            enddo
1276 C
1277 C 12/1/95, revised on 5/20/97
1278 C
1279 C Calculate the contact function. The ith column of the array JCONT will
1280 C contain the numbers of atoms that make contacts with the atom I (of numbers
1281 C greater than I). The arrays FACONT and GACONT will contain the values of
1282 C the contact function and its derivative.
1283 C
1284 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1285 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1286 C Uncomment next line, if the correlation interactions are contact function only
1287             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1288               rij=dsqrt(rij)
1289               sigij=sigma(itypi,itypj)
1290               r0ij=rs0(itypi,itypj)
1291 C
1292 C Check whether the SC's are not too far to make a contact.
1293 C
1294               rcut=1.5d0*r0ij
1295               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1296 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1297 C
1298               if (fcont.gt.0.0D0) then
1299 C If the SC-SC distance if close to sigma, apply spline.
1300 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1301 cAdam &             fcont1,fprimcont1)
1302 cAdam           fcont1=1.0d0-fcont1
1303 cAdam           if (fcont1.gt.0.0d0) then
1304 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1305 cAdam             fcont=fcont*fcont1
1306 cAdam           endif
1307 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1308 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1309 cga             do k=1,3
1310 cga               gg(k)=gg(k)*eps0ij
1311 cga             enddo
1312 cga             eps0ij=-evdwij*eps0ij
1313 C Uncomment for AL's type of SC correlation interactions.
1314 cadam           eps0ij=-evdwij
1315                 num_conti=num_conti+1
1316                 jcont(num_conti,i)=j
1317                 facont(num_conti,i)=fcont*eps0ij
1318                 fprimcont=eps0ij*fprimcont/rij
1319                 fcont=expon*fcont
1320 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1321 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1322 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1323 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1324                 gacont(1,num_conti,i)=-fprimcont*xj
1325                 gacont(2,num_conti,i)=-fprimcont*yj
1326                 gacont(3,num_conti,i)=-fprimcont*zj
1327 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1328 cd              write (iout,'(2i3,3f10.5)')
1329 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1330               endif
1331             endif
1332           enddo      ! j
1333         enddo        ! iint
1334 C Change 12/1/95
1335         num_cont(i)=num_conti
1336       enddo          ! i
1337       do i=1,nct
1338         do j=1,3
1339           gvdwc(j,i)=expon*gvdwc(j,i)
1340           gvdwx(j,i)=expon*gvdwx(j,i)
1341         enddo
1342       enddo
1343 C******************************************************************************
1344 C
1345 C                              N O T E !!!
1346 C
1347 C To save time, the factor of EXPON has been extracted from ALL components
1348 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1349 C use!
1350 C
1351 C******************************************************************************
1352       return
1353       end
1354 C-----------------------------------------------------------------------------
1355       subroutine eljk(evdw,evdw_p,evdw_m)
1356 C
1357 C This subroutine calculates the interaction energy of nonbonded side chains
1358 C assuming the LJK potential of interaction.
1359 C
1360       implicit real*8 (a-h,o-z)
1361       include 'DIMENSIONS'
1362       include 'COMMON.GEO'
1363       include 'COMMON.VAR'
1364       include 'COMMON.LOCAL'
1365       include 'COMMON.CHAIN'
1366       include 'COMMON.DERIV'
1367       include 'COMMON.INTERACT'
1368       include 'COMMON.IOUNITS'
1369       include 'COMMON.NAMES'
1370       dimension gg(3)
1371       logical scheck
1372 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1373       evdw=0.0D0
1374       do i=iatsc_s,iatsc_e
1375         itypi=itype(i)
1376         itypi1=itype(i+1)
1377         xi=c(1,nres+i)
1378         yi=c(2,nres+i)
1379         zi=c(3,nres+i)
1380 C
1381 C Calculate SC interaction energy.
1382 C
1383         do iint=1,nint_gr(i)
1384           do j=istart(i,iint),iend(i,iint)
1385             itypj=itype(j)
1386             xj=c(1,nres+j)-xi
1387             yj=c(2,nres+j)-yi
1388             zj=c(3,nres+j)-zi
1389             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1390             fac_augm=rrij**expon
1391             e_augm=augm(itypi,itypj)*fac_augm
1392             r_inv_ij=dsqrt(rrij)
1393             rij=1.0D0/r_inv_ij
1394             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1395             fac=r_shift_inv**expon
1396             e1=fac*fac*aa(itypi,itypj)
1397             e2=fac*bb(itypi,itypj)
1398             evdwij=e_augm+e1+e2
1399 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1400 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1401 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1402 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1403 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1404 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1405 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1406 #ifdef TSCSC
1407             if (bb(itypi,itypj).gt.0) then
1408                evdw_p=evdw_p+evdwij
1409             else
1410                evdw_m=evdw_m+evdwij
1411             endif
1412 #else
1413             evdw=evdw+evdwij
1414 #endif
1415 C
1416 C Calculate the components of the gradient in DC and X
1417 C
1418             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1419             gg(1)=xj*fac
1420             gg(2)=yj*fac
1421             gg(3)=zj*fac
1422 #ifdef TSCSC
1423             if (bb(itypi,itypj).gt.0.0d0) then
1424               do k=1,3
1425                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1426                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1427                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1428                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1429               enddo
1430             else
1431               do k=1,3
1432                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1433                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1434                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1435                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1436               enddo
1437             endif
1438 #else
1439             do k=1,3
1440               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1441               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1442               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1443               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1444             enddo
1445 #endif
1446 cgrad            do k=i,j-1
1447 cgrad              do l=1,3
1448 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1449 cgrad              enddo
1450 cgrad            enddo
1451           enddo      ! j
1452         enddo        ! iint
1453       enddo          ! i
1454       do i=1,nct
1455         do j=1,3
1456           gvdwc(j,i)=expon*gvdwc(j,i)
1457           gvdwx(j,i)=expon*gvdwx(j,i)
1458         enddo
1459       enddo
1460       return
1461       end
1462 C-----------------------------------------------------------------------------
1463       subroutine ebp(evdw,evdw_p,evdw_m)
1464 C
1465 C This subroutine calculates the interaction energy of nonbonded side chains
1466 C assuming the Berne-Pechukas potential of interaction.
1467 C
1468       implicit real*8 (a-h,o-z)
1469       include 'DIMENSIONS'
1470       include 'COMMON.GEO'
1471       include 'COMMON.VAR'
1472       include 'COMMON.LOCAL'
1473       include 'COMMON.CHAIN'
1474       include 'COMMON.DERIV'
1475       include 'COMMON.NAMES'
1476       include 'COMMON.INTERACT'
1477       include 'COMMON.IOUNITS'
1478       include 'COMMON.CALC'
1479       common /srutu/ icall
1480 c     double precision rrsave(maxdim)
1481       logical lprn
1482       evdw=0.0D0
1483 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1484       evdw=0.0D0
1485 c     if (icall.eq.0) then
1486 c       lprn=.true.
1487 c     else
1488         lprn=.false.
1489 c     endif
1490       ind=0
1491       do i=iatsc_s,iatsc_e
1492         itypi=itype(i)
1493         itypi1=itype(i+1)
1494         xi=c(1,nres+i)
1495         yi=c(2,nres+i)
1496         zi=c(3,nres+i)
1497         dxi=dc_norm(1,nres+i)
1498         dyi=dc_norm(2,nres+i)
1499         dzi=dc_norm(3,nres+i)
1500 c        dsci_inv=dsc_inv(itypi)
1501         dsci_inv=vbld_inv(i+nres)
1502 C
1503 C Calculate SC interaction energy.
1504 C
1505         do iint=1,nint_gr(i)
1506           do j=istart(i,iint),iend(i,iint)
1507             ind=ind+1
1508             itypj=itype(j)
1509 c            dscj_inv=dsc_inv(itypj)
1510             dscj_inv=vbld_inv(j+nres)
1511             chi1=chi(itypi,itypj)
1512             chi2=chi(itypj,itypi)
1513             chi12=chi1*chi2
1514             chip1=chip(itypi)
1515             chip2=chip(itypj)
1516             chip12=chip1*chip2
1517             alf1=alp(itypi)
1518             alf2=alp(itypj)
1519             alf12=0.5D0*(alf1+alf2)
1520 C For diagnostics only!!!
1521 c           chi1=0.0D0
1522 c           chi2=0.0D0
1523 c           chi12=0.0D0
1524 c           chip1=0.0D0
1525 c           chip2=0.0D0
1526 c           chip12=0.0D0
1527 c           alf1=0.0D0
1528 c           alf2=0.0D0
1529 c           alf12=0.0D0
1530             xj=c(1,nres+j)-xi
1531             yj=c(2,nres+j)-yi
1532             zj=c(3,nres+j)-zi
1533             dxj=dc_norm(1,nres+j)
1534             dyj=dc_norm(2,nres+j)
1535             dzj=dc_norm(3,nres+j)
1536             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1537 cd          if (icall.eq.0) then
1538 cd            rrsave(ind)=rrij
1539 cd          else
1540 cd            rrij=rrsave(ind)
1541 cd          endif
1542             rij=dsqrt(rrij)
1543 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1544             call sc_angular
1545 C Calculate whole angle-dependent part of epsilon and contributions
1546 C to its derivatives
1547             fac=(rrij*sigsq)**expon2
1548             e1=fac*fac*aa(itypi,itypj)
1549             e2=fac*bb(itypi,itypj)
1550             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1551             eps2der=evdwij*eps3rt
1552             eps3der=evdwij*eps2rt
1553             evdwij=evdwij*eps2rt*eps3rt
1554 #ifdef TSCSC
1555             if (bb(itypi,itypj).gt.0) then
1556                evdw_p=evdw_p+evdwij
1557             else
1558                evdw_m=evdw_m+evdwij
1559             endif
1560 #else
1561             evdw=evdw+evdwij
1562 #endif
1563             if (lprn) then
1564             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1565             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1566 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1567 cd     &        restyp(itypi),i,restyp(itypj),j,
1568 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1569 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1570 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1571 cd     &        evdwij
1572             endif
1573 C Calculate gradient components.
1574             e1=e1*eps1*eps2rt**2*eps3rt**2
1575             fac=-expon*(e1+evdwij)
1576             sigder=fac/sigsq
1577             fac=rrij*fac
1578 C Calculate radial part of the gradient
1579             gg(1)=xj*fac
1580             gg(2)=yj*fac
1581             gg(3)=zj*fac
1582 C Calculate the angular part of the gradient and sum add the contributions
1583 C to the appropriate components of the Cartesian gradient.
1584 #ifdef TSCSC
1585             if (bb(itypi,itypj).gt.0) then
1586                call sc_grad
1587             else
1588                call sc_grad_T
1589             endif
1590 #else
1591             call sc_grad
1592 #endif
1593           enddo      ! j
1594         enddo        ! iint
1595       enddo          ! i
1596 c     stop
1597       return
1598       end
1599 C-----------------------------------------------------------------------------
1600       subroutine egb(evdw,evdw_p,evdw_m)
1601 C
1602 C This subroutine calculates the interaction energy of nonbonded side chains
1603 C assuming the Gay-Berne potential of interaction.
1604 C
1605       implicit real*8 (a-h,o-z)
1606       include 'DIMENSIONS'
1607       include 'COMMON.GEO'
1608       include 'COMMON.VAR'
1609       include 'COMMON.LOCAL'
1610       include 'COMMON.CHAIN'
1611       include 'COMMON.DERIV'
1612       include 'COMMON.NAMES'
1613       include 'COMMON.INTERACT'
1614       include 'COMMON.IOUNITS'
1615       include 'COMMON.CALC'
1616       include 'COMMON.CONTROL'
1617       logical lprn
1618       evdw=0.0D0
1619 ccccc      energy_dec=.false.
1620 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1621       evdw=0.0D0
1622       evdw_p=0.0D0
1623       evdw_m=0.0D0
1624       lprn=.false.
1625 c     if (icall.eq.0) lprn=.false.
1626       ind=0
1627       do i=iatsc_s,iatsc_e
1628         itypi=itype(i)
1629         itypi1=itype(i+1)
1630         xi=c(1,nres+i)
1631         yi=c(2,nres+i)
1632         zi=c(3,nres+i)
1633         dxi=dc_norm(1,nres+i)
1634         dyi=dc_norm(2,nres+i)
1635         dzi=dc_norm(3,nres+i)
1636 c        dsci_inv=dsc_inv(itypi)
1637         dsci_inv=vbld_inv(i+nres)
1638 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1639 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1640 C
1641 C Calculate SC interaction energy.
1642 C
1643         do iint=1,nint_gr(i)
1644           do j=istart(i,iint),iend(i,iint)
1645             ind=ind+1
1646             itypj=itype(j)
1647 c            dscj_inv=dsc_inv(itypj)
1648             dscj_inv=vbld_inv(j+nres)
1649 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1650 c     &       1.0d0/vbld(j+nres)
1651 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1652             sig0ij=sigma(itypi,itypj)
1653             chi1=chi(itypi,itypj)
1654             chi2=chi(itypj,itypi)
1655             chi12=chi1*chi2
1656             chip1=chip(itypi)
1657             chip2=chip(itypj)
1658             chip12=chip1*chip2
1659             alf1=alp(itypi)
1660             alf2=alp(itypj)
1661             alf12=0.5D0*(alf1+alf2)
1662 C For diagnostics only!!!
1663 c           chi1=0.0D0
1664 c           chi2=0.0D0
1665 c           chi12=0.0D0
1666 c           chip1=0.0D0
1667 c           chip2=0.0D0
1668 c           chip12=0.0D0
1669 c           alf1=0.0D0
1670 c           alf2=0.0D0
1671 c           alf12=0.0D0
1672             xj=c(1,nres+j)-xi
1673             yj=c(2,nres+j)-yi
1674             zj=c(3,nres+j)-zi
1675             dxj=dc_norm(1,nres+j)
1676             dyj=dc_norm(2,nres+j)
1677             dzj=dc_norm(3,nres+j)
1678 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1679 c            write (iout,*) "j",j," dc_norm",
1680 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1681             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1682             rij=dsqrt(rrij)
1683 C Calculate angle-dependent terms of energy and contributions to their
1684 C derivatives.
1685             call sc_angular
1686             sigsq=1.0D0/sigsq
1687             sig=sig0ij*dsqrt(sigsq)
1688             rij_shift=1.0D0/rij-sig+sig0ij
1689 c for diagnostics; uncomment
1690 c            rij_shift=1.2*sig0ij
1691 C I hate to put IF's in the loops, but here don't have another choice!!!!
1692             if (rij_shift.le.0.0D0) then
1693               evdw=1.0D20
1694 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1695 cd     &        restyp(itypi),i,restyp(itypj),j,
1696 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1697               return
1698             endif
1699             sigder=-sig*sigsq
1700 c---------------------------------------------------------------
1701             rij_shift=1.0D0/rij_shift
1702             fac=rij_shift**expon
1703             e1=fac*fac*aa(itypi,itypj)
1704             e2=fac*bb(itypi,itypj)
1705             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1706             eps2der=evdwij*eps3rt
1707             eps3der=evdwij*eps2rt
1708 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1709 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1710             evdwij=evdwij*eps2rt*eps3rt
1711 #ifdef TSCSC
1712             if (bb(itypi,itypj).gt.0) then
1713                evdw_p=evdw_p+evdwij
1714             else
1715                evdw_m=evdw_m+evdwij
1716             endif
1717 #else
1718             evdw=evdw+evdwij
1719 #endif
1720             if (lprn) then
1721             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1722             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1723             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1724      &        restyp(itypi),i,restyp(itypj),j,
1725      &        epsi,sigm,chi1,chi2,chip1,chip2,
1726      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1727      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1728      &        evdwij
1729             endif
1730
1731             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1732      &                        'evdw',i,j,evdwij
1733
1734 C Calculate gradient components.
1735             e1=e1*eps1*eps2rt**2*eps3rt**2
1736             fac=-expon*(e1+evdwij)*rij_shift
1737             sigder=fac*sigder
1738             fac=rij*fac
1739 c            fac=0.0d0
1740 C Calculate the radial part of the gradient
1741             gg(1)=xj*fac
1742             gg(2)=yj*fac
1743             gg(3)=zj*fac
1744 C Calculate angular part of the gradient.
1745 #ifdef TSCSC
1746             if (bb(itypi,itypj).gt.0) then
1747                call sc_grad
1748             else
1749                call sc_grad_T
1750             endif
1751 #else
1752             call sc_grad
1753 #endif
1754           enddo      ! j
1755         enddo        ! iint
1756       enddo          ! i
1757 c      write (iout,*) "Number of loop steps in EGB:",ind
1758 cccc      energy_dec=.false.
1759       return
1760       end
1761 C-----------------------------------------------------------------------------
1762       subroutine egbv(evdw,evdw_p,evdw_m)
1763 C
1764 C This subroutine calculates the interaction energy of nonbonded side chains
1765 C assuming the Gay-Berne-Vorobjev potential of interaction.
1766 C
1767       implicit real*8 (a-h,o-z)
1768       include 'DIMENSIONS'
1769       include 'COMMON.GEO'
1770       include 'COMMON.VAR'
1771       include 'COMMON.LOCAL'
1772       include 'COMMON.CHAIN'
1773       include 'COMMON.DERIV'
1774       include 'COMMON.NAMES'
1775       include 'COMMON.INTERACT'
1776       include 'COMMON.IOUNITS'
1777       include 'COMMON.CALC'
1778       common /srutu/ icall
1779       logical lprn
1780       evdw=0.0D0
1781 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1782       evdw=0.0D0
1783       lprn=.false.
1784 c     if (icall.eq.0) lprn=.true.
1785       ind=0
1786       do i=iatsc_s,iatsc_e
1787         itypi=itype(i)
1788         itypi1=itype(i+1)
1789         xi=c(1,nres+i)
1790         yi=c(2,nres+i)
1791         zi=c(3,nres+i)
1792         dxi=dc_norm(1,nres+i)
1793         dyi=dc_norm(2,nres+i)
1794         dzi=dc_norm(3,nres+i)
1795 c        dsci_inv=dsc_inv(itypi)
1796         dsci_inv=vbld_inv(i+nres)
1797 C
1798 C Calculate SC interaction energy.
1799 C
1800         do iint=1,nint_gr(i)
1801           do j=istart(i,iint),iend(i,iint)
1802             ind=ind+1
1803             itypj=itype(j)
1804 c            dscj_inv=dsc_inv(itypj)
1805             dscj_inv=vbld_inv(j+nres)
1806             sig0ij=sigma(itypi,itypj)
1807             r0ij=r0(itypi,itypj)
1808             chi1=chi(itypi,itypj)
1809             chi2=chi(itypj,itypi)
1810             chi12=chi1*chi2
1811             chip1=chip(itypi)
1812             chip2=chip(itypj)
1813             chip12=chip1*chip2
1814             alf1=alp(itypi)
1815             alf2=alp(itypj)
1816             alf12=0.5D0*(alf1+alf2)
1817 C For diagnostics only!!!
1818 c           chi1=0.0D0
1819 c           chi2=0.0D0
1820 c           chi12=0.0D0
1821 c           chip1=0.0D0
1822 c           chip2=0.0D0
1823 c           chip12=0.0D0
1824 c           alf1=0.0D0
1825 c           alf2=0.0D0
1826 c           alf12=0.0D0
1827             xj=c(1,nres+j)-xi
1828             yj=c(2,nres+j)-yi
1829             zj=c(3,nres+j)-zi
1830             dxj=dc_norm(1,nres+j)
1831             dyj=dc_norm(2,nres+j)
1832             dzj=dc_norm(3,nres+j)
1833             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1834             rij=dsqrt(rrij)
1835 C Calculate angle-dependent terms of energy and contributions to their
1836 C derivatives.
1837             call sc_angular
1838             sigsq=1.0D0/sigsq
1839             sig=sig0ij*dsqrt(sigsq)
1840             rij_shift=1.0D0/rij-sig+r0ij
1841 C I hate to put IF's in the loops, but here don't have another choice!!!!
1842             if (rij_shift.le.0.0D0) then
1843               evdw=1.0D20
1844               return
1845             endif
1846             sigder=-sig*sigsq
1847 c---------------------------------------------------------------
1848             rij_shift=1.0D0/rij_shift
1849             fac=rij_shift**expon
1850             e1=fac*fac*aa(itypi,itypj)
1851             e2=fac*bb(itypi,itypj)
1852             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1853             eps2der=evdwij*eps3rt
1854             eps3der=evdwij*eps2rt
1855             fac_augm=rrij**expon
1856             e_augm=augm(itypi,itypj)*fac_augm
1857             evdwij=evdwij*eps2rt*eps3rt
1858 #ifdef TSCSC
1859             if (bb(itypi,itypj).gt.0) then
1860                evdw_p=evdw_p+evdwij+e_augm
1861             else
1862                evdw_m=evdw_m+evdwij+e_augm
1863             endif
1864 #else
1865             evdw=evdw+evdwij+e_augm
1866 #endif
1867             if (lprn) then
1868             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1869             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1870             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1871      &        restyp(itypi),i,restyp(itypj),j,
1872      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1873      &        chi1,chi2,chip1,chip2,
1874      &        eps1,eps2rt**2,eps3rt**2,
1875      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1876      &        evdwij+e_augm
1877             endif
1878 C Calculate gradient components.
1879             e1=e1*eps1*eps2rt**2*eps3rt**2
1880             fac=-expon*(e1+evdwij)*rij_shift
1881             sigder=fac*sigder
1882             fac=rij*fac-2*expon*rrij*e_augm
1883 C Calculate the radial part of the gradient
1884             gg(1)=xj*fac
1885             gg(2)=yj*fac
1886             gg(3)=zj*fac
1887 C Calculate angular part of the gradient.
1888 #ifdef TSCSC
1889             if (bb(itypi,itypj).gt.0) then
1890                call sc_grad
1891             else
1892                call sc_grad_T
1893             endif
1894 #else
1895             call sc_grad
1896 #endif
1897           enddo      ! j
1898         enddo        ! iint
1899       enddo          ! i
1900       end
1901 C-----------------------------------------------------------------------------
1902       subroutine sc_angular
1903 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1904 C om12. Called by ebp, egb, and egbv.
1905       implicit none
1906       include 'COMMON.CALC'
1907       include 'COMMON.IOUNITS'
1908       erij(1)=xj*rij
1909       erij(2)=yj*rij
1910       erij(3)=zj*rij
1911       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1912       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1913       om12=dxi*dxj+dyi*dyj+dzi*dzj
1914       chiom12=chi12*om12
1915 C Calculate eps1(om12) and its derivative in om12
1916       faceps1=1.0D0-om12*chiom12
1917       faceps1_inv=1.0D0/faceps1
1918       eps1=dsqrt(faceps1_inv)
1919 C Following variable is eps1*deps1/dom12
1920       eps1_om12=faceps1_inv*chiom12
1921 c diagnostics only
1922 c      faceps1_inv=om12
1923 c      eps1=om12
1924 c      eps1_om12=1.0d0
1925 c      write (iout,*) "om12",om12," eps1",eps1
1926 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1927 C and om12.
1928       om1om2=om1*om2
1929       chiom1=chi1*om1
1930       chiom2=chi2*om2
1931       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1932       sigsq=1.0D0-facsig*faceps1_inv
1933       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1934       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1935       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1936 c diagnostics only
1937 c      sigsq=1.0d0
1938 c      sigsq_om1=0.0d0
1939 c      sigsq_om2=0.0d0
1940 c      sigsq_om12=0.0d0
1941 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1942 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1943 c     &    " eps1",eps1
1944 C Calculate eps2 and its derivatives in om1, om2, and om12.
1945       chipom1=chip1*om1
1946       chipom2=chip2*om2
1947       chipom12=chip12*om12
1948       facp=1.0D0-om12*chipom12
1949       facp_inv=1.0D0/facp
1950       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1951 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1952 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1953 C Following variable is the square root of eps2
1954       eps2rt=1.0D0-facp1*facp_inv
1955 C Following three variables are the derivatives of the square root of eps
1956 C in om1, om2, and om12.
1957       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1958       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1959       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1960 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1961       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1962 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1963 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1964 c     &  " eps2rt_om12",eps2rt_om12
1965 C Calculate whole angle-dependent part of epsilon and contributions
1966 C to its derivatives
1967       return
1968       end
1969
1970 C----------------------------------------------------------------------------
1971       subroutine sc_grad_T
1972       implicit real*8 (a-h,o-z)
1973       include 'DIMENSIONS'
1974       include 'COMMON.CHAIN'
1975       include 'COMMON.DERIV'
1976       include 'COMMON.CALC'
1977       include 'COMMON.IOUNITS'
1978       double precision dcosom1(3),dcosom2(3)
1979       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1980       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1981       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1982      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1983 c diagnostics only
1984 c      eom1=0.0d0
1985 c      eom2=0.0d0
1986 c      eom12=evdwij*eps1_om12
1987 c end diagnostics
1988 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1989 c     &  " sigder",sigder
1990 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1991 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1992       do k=1,3
1993         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1994         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1995       enddo
1996       do k=1,3
1997         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1998       enddo
1999 c      write (iout,*) "gg",(gg(k),k=1,3)
2000       do k=1,3
2001         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2002      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2003      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2004         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2005      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2006      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2007 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2008 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2009 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2010 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2011       enddo
2012 C
2013 C Calculate the components of the gradient in DC and X
2014 C
2015 cgrad      do k=i,j-1
2016 cgrad        do l=1,3
2017 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2018 cgrad        enddo
2019 cgrad      enddo
2020       do l=1,3
2021         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2022         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2023       enddo
2024       return
2025       end
2026
2027 C----------------------------------------------------------------------------
2028       subroutine sc_grad
2029       implicit real*8 (a-h,o-z)
2030       include 'DIMENSIONS'
2031       include 'COMMON.CHAIN'
2032       include 'COMMON.DERIV'
2033       include 'COMMON.CALC'
2034       include 'COMMON.IOUNITS'
2035       double precision dcosom1(3),dcosom2(3)
2036       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2037       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2038       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2039      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2040 c diagnostics only
2041 c      eom1=0.0d0
2042 c      eom2=0.0d0
2043 c      eom12=evdwij*eps1_om12
2044 c end diagnostics
2045 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2046 c     &  " sigder",sigder
2047 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2048 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2049       do k=1,3
2050         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2051         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2052       enddo
2053       do k=1,3
2054         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2055       enddo
2056 c      write (iout,*) "gg",(gg(k),k=1,3)
2057       do k=1,3
2058         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2059      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2060      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2061         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2062      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2063      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2064 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2065 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2066 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2067 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2068       enddo
2069 C
2070 C Calculate the components of the gradient in DC and X
2071 C
2072 cgrad      do k=i,j-1
2073 cgrad        do l=1,3
2074 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2075 cgrad        enddo
2076 cgrad      enddo
2077       do l=1,3
2078         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2079         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2080       enddo
2081       return
2082       end
2083 C-----------------------------------------------------------------------
2084       subroutine e_softsphere(evdw)
2085 C
2086 C This subroutine calculates the interaction energy of nonbonded side chains
2087 C assuming the LJ potential of interaction.
2088 C
2089       implicit real*8 (a-h,o-z)
2090       include 'DIMENSIONS'
2091       parameter (accur=1.0d-10)
2092       include 'COMMON.GEO'
2093       include 'COMMON.VAR'
2094       include 'COMMON.LOCAL'
2095       include 'COMMON.CHAIN'
2096       include 'COMMON.DERIV'
2097       include 'COMMON.INTERACT'
2098       include 'COMMON.TORSION'
2099       include 'COMMON.SBRIDGE'
2100       include 'COMMON.NAMES'
2101       include 'COMMON.IOUNITS'
2102       include 'COMMON.CONTACTS'
2103       dimension gg(3)
2104 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2105       evdw=0.0D0
2106       do i=iatsc_s,iatsc_e
2107         itypi=itype(i)
2108         itypi1=itype(i+1)
2109         xi=c(1,nres+i)
2110         yi=c(2,nres+i)
2111         zi=c(3,nres+i)
2112 C
2113 C Calculate SC interaction energy.
2114 C
2115         do iint=1,nint_gr(i)
2116 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2117 cd   &                  'iend=',iend(i,iint)
2118           do j=istart(i,iint),iend(i,iint)
2119             itypj=itype(j)
2120             xj=c(1,nres+j)-xi
2121             yj=c(2,nres+j)-yi
2122             zj=c(3,nres+j)-zi
2123             rij=xj*xj+yj*yj+zj*zj
2124 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2125             r0ij=r0(itypi,itypj)
2126             r0ijsq=r0ij*r0ij
2127 c            print *,i,j,r0ij,dsqrt(rij)
2128             if (rij.lt.r0ijsq) then
2129               evdwij=0.25d0*(rij-r0ijsq)**2
2130               fac=rij-r0ijsq
2131             else
2132               evdwij=0.0d0
2133               fac=0.0d0
2134             endif
2135             evdw=evdw+evdwij
2136 C
2137 C Calculate the components of the gradient in DC and X
2138 C
2139             gg(1)=xj*fac
2140             gg(2)=yj*fac
2141             gg(3)=zj*fac
2142             do k=1,3
2143               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2144               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2145               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2146               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2147             enddo
2148 cgrad            do k=i,j-1
2149 cgrad              do l=1,3
2150 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2151 cgrad              enddo
2152 cgrad            enddo
2153           enddo ! j
2154         enddo ! iint
2155       enddo ! i
2156       return
2157       end
2158 C--------------------------------------------------------------------------
2159       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2160      &              eello_turn4)
2161 C
2162 C Soft-sphere potential of p-p interaction
2163 C
2164       implicit real*8 (a-h,o-z)
2165       include 'DIMENSIONS'
2166       include 'COMMON.CONTROL'
2167       include 'COMMON.IOUNITS'
2168       include 'COMMON.GEO'
2169       include 'COMMON.VAR'
2170       include 'COMMON.LOCAL'
2171       include 'COMMON.CHAIN'
2172       include 'COMMON.DERIV'
2173       include 'COMMON.INTERACT'
2174       include 'COMMON.CONTACTS'
2175       include 'COMMON.TORSION'
2176       include 'COMMON.VECTORS'
2177       include 'COMMON.FFIELD'
2178       dimension ggg(3)
2179 cd      write(iout,*) 'In EELEC_soft_sphere'
2180       ees=0.0D0
2181       evdw1=0.0D0
2182       eel_loc=0.0d0
2183       eello_turn3=0.0d0
2184       eello_turn4=0.0d0
2185       ind=0
2186       do i=iatel_s,iatel_e
2187         dxi=dc(1,i)
2188         dyi=dc(2,i)
2189         dzi=dc(3,i)
2190         xmedi=c(1,i)+0.5d0*dxi
2191         ymedi=c(2,i)+0.5d0*dyi
2192         zmedi=c(3,i)+0.5d0*dzi
2193         num_conti=0
2194 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2195         do j=ielstart(i),ielend(i)
2196           ind=ind+1
2197           iteli=itel(i)
2198           itelj=itel(j)
2199           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2200           r0ij=rpp(iteli,itelj)
2201           r0ijsq=r0ij*r0ij
2202           dxj=dc(1,j)
2203           dyj=dc(2,j)
2204           dzj=dc(3,j)
2205           xj=c(1,j)+0.5D0*dxj-xmedi
2206           yj=c(2,j)+0.5D0*dyj-ymedi
2207           zj=c(3,j)+0.5D0*dzj-zmedi
2208           rij=xj*xj+yj*yj+zj*zj
2209           if (rij.lt.r0ijsq) then
2210             evdw1ij=0.25d0*(rij-r0ijsq)**2
2211             fac=rij-r0ijsq
2212           else
2213             evdw1ij=0.0d0
2214             fac=0.0d0
2215           endif
2216           evdw1=evdw1+evdw1ij
2217 C
2218 C Calculate contributions to the Cartesian gradient.
2219 C
2220           ggg(1)=fac*xj
2221           ggg(2)=fac*yj
2222           ggg(3)=fac*zj
2223           do k=1,3
2224             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2225             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2226           enddo
2227 *
2228 * Loop over residues i+1 thru j-1.
2229 *
2230 cgrad          do k=i+1,j-1
2231 cgrad            do l=1,3
2232 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2233 cgrad            enddo
2234 cgrad          enddo
2235         enddo ! j
2236       enddo   ! i
2237 cgrad      do i=nnt,nct-1
2238 cgrad        do k=1,3
2239 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2240 cgrad        enddo
2241 cgrad        do j=i+1,nct-1
2242 cgrad          do k=1,3
2243 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2244 cgrad          enddo
2245 cgrad        enddo
2246 cgrad      enddo
2247       return
2248       end
2249 c------------------------------------------------------------------------------
2250       subroutine vec_and_deriv
2251       implicit real*8 (a-h,o-z)
2252       include 'DIMENSIONS'
2253 #ifdef MPI
2254       include 'mpif.h'
2255 #endif
2256       include 'COMMON.IOUNITS'
2257       include 'COMMON.GEO'
2258       include 'COMMON.VAR'
2259       include 'COMMON.LOCAL'
2260       include 'COMMON.CHAIN'
2261       include 'COMMON.VECTORS'
2262       include 'COMMON.SETUP'
2263       include 'COMMON.TIME1'
2264       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2265 C Compute the local reference systems. For reference system (i), the
2266 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2267 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2268 #ifdef PARVEC
2269       do i=ivec_start,ivec_end
2270 #else
2271       do i=1,nres-1
2272 #endif
2273           if (i.eq.nres-1) then
2274 C Case of the last full residue
2275 C Compute the Z-axis
2276             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2277             costh=dcos(pi-theta(nres))
2278             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2279             do k=1,3
2280               uz(k,i)=fac*uz(k,i)
2281             enddo
2282 C Compute the derivatives of uz
2283             uzder(1,1,1)= 0.0d0
2284             uzder(2,1,1)=-dc_norm(3,i-1)
2285             uzder(3,1,1)= dc_norm(2,i-1)
2286             uzder(1,2,1)= dc_norm(3,i-1)
2287             uzder(2,2,1)= 0.0d0
2288             uzder(3,2,1)=-dc_norm(1,i-1)
2289             uzder(1,3,1)=-dc_norm(2,i-1)
2290             uzder(2,3,1)= dc_norm(1,i-1)
2291             uzder(3,3,1)= 0.0d0
2292             uzder(1,1,2)= 0.0d0
2293             uzder(2,1,2)= dc_norm(3,i)
2294             uzder(3,1,2)=-dc_norm(2,i)
2295             uzder(1,2,2)=-dc_norm(3,i)
2296             uzder(2,2,2)= 0.0d0
2297             uzder(3,2,2)= dc_norm(1,i)
2298             uzder(1,3,2)= dc_norm(2,i)
2299             uzder(2,3,2)=-dc_norm(1,i)
2300             uzder(3,3,2)= 0.0d0
2301 C Compute the Y-axis
2302             facy=fac
2303             do k=1,3
2304               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2305             enddo
2306 C Compute the derivatives of uy
2307             do j=1,3
2308               do k=1,3
2309                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2310      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2311                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2312               enddo
2313               uyder(j,j,1)=uyder(j,j,1)-costh
2314               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2315             enddo
2316             do j=1,2
2317               do k=1,3
2318                 do l=1,3
2319                   uygrad(l,k,j,i)=uyder(l,k,j)
2320                   uzgrad(l,k,j,i)=uzder(l,k,j)
2321                 enddo
2322               enddo
2323             enddo
2324             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2325             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2326             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2327             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2328           else
2329 C Other residues
2330 C Compute the Z-axis
2331             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2332             costh=dcos(pi-theta(i+2))
2333             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2334             do k=1,3
2335               uz(k,i)=fac*uz(k,i)
2336             enddo
2337 C Compute the derivatives of uz
2338             uzder(1,1,1)= 0.0d0
2339             uzder(2,1,1)=-dc_norm(3,i+1)
2340             uzder(3,1,1)= dc_norm(2,i+1)
2341             uzder(1,2,1)= dc_norm(3,i+1)
2342             uzder(2,2,1)= 0.0d0
2343             uzder(3,2,1)=-dc_norm(1,i+1)
2344             uzder(1,3,1)=-dc_norm(2,i+1)
2345             uzder(2,3,1)= dc_norm(1,i+1)
2346             uzder(3,3,1)= 0.0d0
2347             uzder(1,1,2)= 0.0d0
2348             uzder(2,1,2)= dc_norm(3,i)
2349             uzder(3,1,2)=-dc_norm(2,i)
2350             uzder(1,2,2)=-dc_norm(3,i)
2351             uzder(2,2,2)= 0.0d0
2352             uzder(3,2,2)= dc_norm(1,i)
2353             uzder(1,3,2)= dc_norm(2,i)
2354             uzder(2,3,2)=-dc_norm(1,i)
2355             uzder(3,3,2)= 0.0d0
2356 C Compute the Y-axis
2357             facy=fac
2358             do k=1,3
2359               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2360             enddo
2361 C Compute the derivatives of uy
2362             do j=1,3
2363               do k=1,3
2364                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2365      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2366                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2367               enddo
2368               uyder(j,j,1)=uyder(j,j,1)-costh
2369               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2370             enddo
2371             do j=1,2
2372               do k=1,3
2373                 do l=1,3
2374                   uygrad(l,k,j,i)=uyder(l,k,j)
2375                   uzgrad(l,k,j,i)=uzder(l,k,j)
2376                 enddo
2377               enddo
2378             enddo
2379             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2380             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2381             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2382             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2383           endif
2384       enddo
2385       do i=1,nres-1
2386         vbld_inv_temp(1)=vbld_inv(i+1)
2387         if (i.lt.nres-1) then
2388           vbld_inv_temp(2)=vbld_inv(i+2)
2389           else
2390           vbld_inv_temp(2)=vbld_inv(i)
2391           endif
2392         do j=1,2
2393           do k=1,3
2394             do l=1,3
2395               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2396               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2397             enddo
2398           enddo
2399         enddo
2400       enddo
2401 #if defined(PARVEC) && defined(MPI)
2402       if (nfgtasks1.gt.1) then
2403         time00=MPI_Wtime()
2404 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2405 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2406 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2407         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2408      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2409      &   FG_COMM1,IERR)
2410         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2411      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2412      &   FG_COMM1,IERR)
2413         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2414      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2415      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2416         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2417      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2418      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2419         time_gather=time_gather+MPI_Wtime()-time00
2420       endif
2421 c      if (fg_rank.eq.0) then
2422 c        write (iout,*) "Arrays UY and UZ"
2423 c        do i=1,nres-1
2424 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2425 c     &     (uz(k,i),k=1,3)
2426 c        enddo
2427 c      endif
2428 #endif
2429       return
2430       end
2431 C-----------------------------------------------------------------------------
2432       subroutine check_vecgrad
2433       implicit real*8 (a-h,o-z)
2434       include 'DIMENSIONS'
2435       include 'COMMON.IOUNITS'
2436       include 'COMMON.GEO'
2437       include 'COMMON.VAR'
2438       include 'COMMON.LOCAL'
2439       include 'COMMON.CHAIN'
2440       include 'COMMON.VECTORS'
2441       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2442       dimension uyt(3,maxres),uzt(3,maxres)
2443       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2444       double precision delta /1.0d-7/
2445       call vec_and_deriv
2446 cd      do i=1,nres
2447 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2448 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2449 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2450 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2451 cd     &     (dc_norm(if90,i),if90=1,3)
2452 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2453 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2454 cd          write(iout,'(a)')
2455 cd      enddo
2456       do i=1,nres
2457         do j=1,2
2458           do k=1,3
2459             do l=1,3
2460               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2461               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2462             enddo
2463           enddo
2464         enddo
2465       enddo
2466       call vec_and_deriv
2467       do i=1,nres
2468         do j=1,3
2469           uyt(j,i)=uy(j,i)
2470           uzt(j,i)=uz(j,i)
2471         enddo
2472       enddo
2473       do i=1,nres
2474 cd        write (iout,*) 'i=',i
2475         do k=1,3
2476           erij(k)=dc_norm(k,i)
2477         enddo
2478         do j=1,3
2479           do k=1,3
2480             dc_norm(k,i)=erij(k)
2481           enddo
2482           dc_norm(j,i)=dc_norm(j,i)+delta
2483 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2484 c          do k=1,3
2485 c            dc_norm(k,i)=dc_norm(k,i)/fac
2486 c          enddo
2487 c          write (iout,*) (dc_norm(k,i),k=1,3)
2488 c          write (iout,*) (erij(k),k=1,3)
2489           call vec_and_deriv
2490           do k=1,3
2491             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2492             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2493             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2494             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2495           enddo
2496 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2497 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2498 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2499         enddo
2500         do k=1,3
2501           dc_norm(k,i)=erij(k)
2502         enddo
2503 cd        do k=1,3
2504 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2505 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2506 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2507 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2508 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2509 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2510 cd          write (iout,'(a)')
2511 cd        enddo
2512       enddo
2513       return
2514       end
2515 C--------------------------------------------------------------------------
2516       subroutine set_matrices
2517       implicit real*8 (a-h,o-z)
2518       include 'DIMENSIONS'
2519 #ifdef MPI
2520       include "mpif.h"
2521       include "COMMON.SETUP"
2522       integer IERR
2523       integer status(MPI_STATUS_SIZE)
2524 #endif
2525       include 'COMMON.IOUNITS'
2526       include 'COMMON.GEO'
2527       include 'COMMON.VAR'
2528       include 'COMMON.LOCAL'
2529       include 'COMMON.CHAIN'
2530       include 'COMMON.DERIV'
2531       include 'COMMON.INTERACT'
2532       include 'COMMON.CONTACTS'
2533       include 'COMMON.TORSION'
2534       include 'COMMON.VECTORS'
2535       include 'COMMON.FFIELD'
2536       double precision auxvec(2),auxmat(2,2)
2537 C
2538 C Compute the virtual-bond-torsional-angle dependent quantities needed
2539 C to calculate the el-loc multibody terms of various order.
2540 C
2541 #ifdef PARMAT
2542       do i=ivec_start+2,ivec_end+2
2543 #else
2544       do i=3,nres+1
2545 #endif
2546         if (i .lt. nres+1) then
2547           sin1=dsin(phi(i))
2548           cos1=dcos(phi(i))
2549           sintab(i-2)=sin1
2550           costab(i-2)=cos1
2551           obrot(1,i-2)=cos1
2552           obrot(2,i-2)=sin1
2553           sin2=dsin(2*phi(i))
2554           cos2=dcos(2*phi(i))
2555           sintab2(i-2)=sin2
2556           costab2(i-2)=cos2
2557           obrot2(1,i-2)=cos2
2558           obrot2(2,i-2)=sin2
2559           Ug(1,1,i-2)=-cos1
2560           Ug(1,2,i-2)=-sin1
2561           Ug(2,1,i-2)=-sin1
2562           Ug(2,2,i-2)= cos1
2563           Ug2(1,1,i-2)=-cos2
2564           Ug2(1,2,i-2)=-sin2
2565           Ug2(2,1,i-2)=-sin2
2566           Ug2(2,2,i-2)= cos2
2567         else
2568           costab(i-2)=1.0d0
2569           sintab(i-2)=0.0d0
2570           obrot(1,i-2)=1.0d0
2571           obrot(2,i-2)=0.0d0
2572           obrot2(1,i-2)=0.0d0
2573           obrot2(2,i-2)=0.0d0
2574           Ug(1,1,i-2)=1.0d0
2575           Ug(1,2,i-2)=0.0d0
2576           Ug(2,1,i-2)=0.0d0
2577           Ug(2,2,i-2)=1.0d0
2578           Ug2(1,1,i-2)=0.0d0
2579           Ug2(1,2,i-2)=0.0d0
2580           Ug2(2,1,i-2)=0.0d0
2581           Ug2(2,2,i-2)=0.0d0
2582         endif
2583         if (i .gt. 3 .and. i .lt. nres+1) then
2584           obrot_der(1,i-2)=-sin1
2585           obrot_der(2,i-2)= cos1
2586           Ugder(1,1,i-2)= sin1
2587           Ugder(1,2,i-2)=-cos1
2588           Ugder(2,1,i-2)=-cos1
2589           Ugder(2,2,i-2)=-sin1
2590           dwacos2=cos2+cos2
2591           dwasin2=sin2+sin2
2592           obrot2_der(1,i-2)=-dwasin2
2593           obrot2_der(2,i-2)= dwacos2
2594           Ug2der(1,1,i-2)= dwasin2
2595           Ug2der(1,2,i-2)=-dwacos2
2596           Ug2der(2,1,i-2)=-dwacos2
2597           Ug2der(2,2,i-2)=-dwasin2
2598         else
2599           obrot_der(1,i-2)=0.0d0
2600           obrot_der(2,i-2)=0.0d0
2601           Ugder(1,1,i-2)=0.0d0
2602           Ugder(1,2,i-2)=0.0d0
2603           Ugder(2,1,i-2)=0.0d0
2604           Ugder(2,2,i-2)=0.0d0
2605           obrot2_der(1,i-2)=0.0d0
2606           obrot2_der(2,i-2)=0.0d0
2607           Ug2der(1,1,i-2)=0.0d0
2608           Ug2der(1,2,i-2)=0.0d0
2609           Ug2der(2,1,i-2)=0.0d0
2610           Ug2der(2,2,i-2)=0.0d0
2611         endif
2612 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2613         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2614           iti = itortyp(itype(i-2))
2615         else
2616           iti=ntortyp+1
2617         endif
2618 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2619         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2620           iti1 = itortyp(itype(i-1))
2621         else
2622           iti1=ntortyp+1
2623         endif
2624 cd        write (iout,*) '*******i',i,' iti1',iti
2625 cd        write (iout,*) 'b1',b1(:,iti)
2626 cd        write (iout,*) 'b2',b2(:,iti)
2627 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2628 c        if (i .gt. iatel_s+2) then
2629         if (i .gt. nnt+2) then
2630           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2631           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2632           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2633      &    then
2634           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2635           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2636           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2637           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2638           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2639           endif
2640         else
2641           do k=1,2
2642             Ub2(k,i-2)=0.0d0
2643             Ctobr(k,i-2)=0.0d0
2644             Dtobr2(k,i-2)=0.0d0
2645             do l=1,2
2646               EUg(l,k,i-2)=0.0d0
2647               CUg(l,k,i-2)=0.0d0
2648               DUg(l,k,i-2)=0.0d0
2649               DtUg2(l,k,i-2)=0.0d0
2650             enddo
2651           enddo
2652         endif
2653         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2654         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2655         do k=1,2
2656           muder(k,i-2)=Ub2der(k,i-2)
2657         enddo
2658 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2659         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2660           iti1 = itortyp(itype(i-1))
2661         else
2662           iti1=ntortyp+1
2663         endif
2664         do k=1,2
2665           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2666         enddo
2667 cd        write (iout,*) 'mu ',mu(:,i-2)
2668 cd        write (iout,*) 'mu1',mu1(:,i-2)
2669 cd        write (iout,*) 'mu2',mu2(:,i-2)
2670         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2671      &  then
2672         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2673         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2674         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2675         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2676         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2677 C Vectors and matrices dependent on a single virtual-bond dihedral.
2678         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2679         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2680         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2681         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2682         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2683         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2684         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2685         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2686         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2687         endif
2688       enddo
2689 C Matrices dependent on two consecutive virtual-bond dihedrals.
2690 C The order of matrices is from left to right.
2691       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2692      &then
2693 c      do i=max0(ivec_start,2),ivec_end
2694       do i=2,nres-1
2695         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2696         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2697         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2698         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2699         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2700         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2701         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2702         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2703       enddo
2704       endif
2705 #if defined(MPI) && defined(PARMAT)
2706 #ifdef DEBUG
2707 c      if (fg_rank.eq.0) then
2708         write (iout,*) "Arrays UG and UGDER before GATHER"
2709         do i=1,nres-1
2710           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2711      &     ((ug(l,k,i),l=1,2),k=1,2),
2712      &     ((ugder(l,k,i),l=1,2),k=1,2)
2713         enddo
2714         write (iout,*) "Arrays UG2 and UG2DER"
2715         do i=1,nres-1
2716           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2717      &     ((ug2(l,k,i),l=1,2),k=1,2),
2718      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2719         enddo
2720         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2721         do i=1,nres-1
2722           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2723      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2724      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2725         enddo
2726         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2727         do i=1,nres-1
2728           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2729      &     costab(i),sintab(i),costab2(i),sintab2(i)
2730         enddo
2731         write (iout,*) "Array MUDER"
2732         do i=1,nres-1
2733           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2734         enddo
2735 c      endif
2736 #endif
2737       if (nfgtasks.gt.1) then
2738         time00=MPI_Wtime()
2739 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2740 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2741 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2742 #ifdef MATGATHER
2743         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2744      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2745      &   FG_COMM1,IERR)
2746         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2747      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2748      &   FG_COMM1,IERR)
2749         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2750      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2751      &   FG_COMM1,IERR)
2752         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2753      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2754      &   FG_COMM1,IERR)
2755         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2756      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2757      &   FG_COMM1,IERR)
2758         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2759      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2762      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2763      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2764         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2765      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2766      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2767         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2768      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2769      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2770         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2771      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2772      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2773         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2774      &  then
2775         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2776      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2777      &   FG_COMM1,IERR)
2778         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2779      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2782      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2783      &   FG_COMM1,IERR)
2784        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2785      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2791      &   ivec_count(fg_rank1),
2792      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2793      &   FG_COMM1,IERR)
2794         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2795      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2796      &   FG_COMM1,IERR)
2797         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2798      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2799      &   FG_COMM1,IERR)
2800         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2801      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2802      &   FG_COMM1,IERR)
2803         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2804      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2805      &   FG_COMM1,IERR)
2806         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2807      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2808      &   FG_COMM1,IERR)
2809         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2811      &   FG_COMM1,IERR)
2812         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2816      &   ivec_count(fg_rank1),
2817      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2818      &   FG_COMM1,IERR)
2819         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2820      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2821      &   FG_COMM1,IERR)
2822        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2823      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2824      &   FG_COMM1,IERR)
2825         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2826      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2827      &   FG_COMM1,IERR)
2828        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2829      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2830      &   FG_COMM1,IERR)
2831         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2832      &   ivec_count(fg_rank1),
2833      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2834      &   FG_COMM1,IERR)
2835         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2836      &   ivec_count(fg_rank1),
2837      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2838      &   FG_COMM1,IERR)
2839         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2840      &   ivec_count(fg_rank1),
2841      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2842      &   MPI_MAT2,FG_COMM1,IERR)
2843         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2844      &   ivec_count(fg_rank1),
2845      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2846      &   MPI_MAT2,FG_COMM1,IERR)
2847         endif
2848 #else
2849 c Passes matrix info through the ring
2850       isend=fg_rank1
2851       irecv=fg_rank1-1
2852       if (irecv.lt.0) irecv=nfgtasks1-1
2853       iprev=irecv
2854       inext=fg_rank1+1
2855       if (inext.ge.nfgtasks1) inext=0
2856       do i=1,nfgtasks1-1
2857 c        write (iout,*) "isend",isend," irecv",irecv
2858 c        call flush(iout)
2859         lensend=lentyp(isend)
2860         lenrecv=lentyp(irecv)
2861 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2862 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2863 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2864 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2865 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2866 c        write (iout,*) "Gather ROTAT1"
2867 c        call flush(iout)
2868 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2869 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2870 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2871 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2872 c        write (iout,*) "Gather ROTAT2"
2873 c        call flush(iout)
2874         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2875      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2876      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2877      &   iprev,4400+irecv,FG_COMM,status,IERR)
2878 c        write (iout,*) "Gather ROTAT_OLD"
2879 c        call flush(iout)
2880         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2881      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2882      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2883      &   iprev,5500+irecv,FG_COMM,status,IERR)
2884 c        write (iout,*) "Gather PRECOMP11"
2885 c        call flush(iout)
2886         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2887      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2888      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2889      &   iprev,6600+irecv,FG_COMM,status,IERR)
2890 c        write (iout,*) "Gather PRECOMP12"
2891 c        call flush(iout)
2892         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2893      &  then
2894         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2895      &   MPI_ROTAT2(lensend),inext,7700+isend,
2896      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2897      &   iprev,7700+irecv,FG_COMM,status,IERR)
2898 c        write (iout,*) "Gather PRECOMP21"
2899 c        call flush(iout)
2900         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2901      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2902      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2903      &   iprev,8800+irecv,FG_COMM,status,IERR)
2904 c        write (iout,*) "Gather PRECOMP22"
2905 c        call flush(iout)
2906         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2907      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2908      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2909      &   MPI_PRECOMP23(lenrecv),
2910      &   iprev,9900+irecv,FG_COMM,status,IERR)
2911 c        write (iout,*) "Gather PRECOMP23"
2912 c        call flush(iout)
2913         endif
2914         isend=irecv
2915         irecv=irecv-1
2916         if (irecv.lt.0) irecv=nfgtasks1-1
2917       enddo
2918 #endif
2919         time_gather=time_gather+MPI_Wtime()-time00
2920       endif
2921 #ifdef DEBUG
2922 c      if (fg_rank.eq.0) then
2923         write (iout,*) "Arrays UG and UGDER"
2924         do i=1,nres-1
2925           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2926      &     ((ug(l,k,i),l=1,2),k=1,2),
2927      &     ((ugder(l,k,i),l=1,2),k=1,2)
2928         enddo
2929         write (iout,*) "Arrays UG2 and UG2DER"
2930         do i=1,nres-1
2931           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2932      &     ((ug2(l,k,i),l=1,2),k=1,2),
2933      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2934         enddo
2935         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2936         do i=1,nres-1
2937           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2938      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2939      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2940         enddo
2941         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2942         do i=1,nres-1
2943           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2944      &     costab(i),sintab(i),costab2(i),sintab2(i)
2945         enddo
2946         write (iout,*) "Array MUDER"
2947         do i=1,nres-1
2948           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2949         enddo
2950 c      endif
2951 #endif
2952 #endif
2953 cd      do i=1,nres
2954 cd        iti = itortyp(itype(i))
2955 cd        write (iout,*) i
2956 cd        do j=1,2
2957 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2958 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2959 cd        enddo
2960 cd      enddo
2961       return
2962       end
2963 C--------------------------------------------------------------------------
2964       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2965 C
2966 C This subroutine calculates the average interaction energy and its gradient
2967 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2968 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2969 C The potential depends both on the distance of peptide-group centers and on
2970 C the orientation of the CA-CA virtual bonds.
2971 C
2972       implicit real*8 (a-h,o-z)
2973 #ifdef MPI
2974       include 'mpif.h'
2975 #endif
2976       include 'DIMENSIONS'
2977       include 'COMMON.CONTROL'
2978       include 'COMMON.SETUP'
2979       include 'COMMON.IOUNITS'
2980       include 'COMMON.GEO'
2981       include 'COMMON.VAR'
2982       include 'COMMON.LOCAL'
2983       include 'COMMON.CHAIN'
2984       include 'COMMON.DERIV'
2985       include 'COMMON.INTERACT'
2986       include 'COMMON.CONTACTS'
2987       include 'COMMON.TORSION'
2988       include 'COMMON.VECTORS'
2989       include 'COMMON.FFIELD'
2990       include 'COMMON.TIME1'
2991       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2992      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2993       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2994      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2995       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2996      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2997      &    num_conti,j1,j2
2998 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2999 #ifdef MOMENT
3000       double precision scal_el /1.0d0/
3001 #else
3002       double precision scal_el /0.5d0/
3003 #endif
3004 C 12/13/98
3005 C 13-go grudnia roku pamietnego...
3006       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3007      &                   0.0d0,1.0d0,0.0d0,
3008      &                   0.0d0,0.0d0,1.0d0/
3009 cd      write(iout,*) 'In EELEC'
3010 cd      do i=1,nloctyp
3011 cd        write(iout,*) 'Type',i
3012 cd        write(iout,*) 'B1',B1(:,i)
3013 cd        write(iout,*) 'B2',B2(:,i)
3014 cd        write(iout,*) 'CC',CC(:,:,i)
3015 cd        write(iout,*) 'DD',DD(:,:,i)
3016 cd        write(iout,*) 'EE',EE(:,:,i)
3017 cd      enddo
3018 cd      call check_vecgrad
3019 cd      stop
3020       if (icheckgrad.eq.1) then
3021         do i=1,nres-1
3022           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3023           do k=1,3
3024             dc_norm(k,i)=dc(k,i)*fac
3025           enddo
3026 c          write (iout,*) 'i',i,' fac',fac
3027         enddo
3028       endif
3029       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3030      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3031      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3032 c        call vec_and_deriv
3033 #ifdef TIMING
3034         time01=MPI_Wtime()
3035 #endif
3036         call set_matrices
3037 #ifdef TIMING
3038         time_mat=time_mat+MPI_Wtime()-time01
3039 #endif
3040       endif
3041 cd      do i=1,nres-1
3042 cd        write (iout,*) 'i=',i
3043 cd        do k=1,3
3044 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3045 cd        enddo
3046 cd        do k=1,3
3047 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3048 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3049 cd        enddo
3050 cd      enddo
3051       t_eelecij=0.0d0
3052       ees=0.0D0
3053       evdw1=0.0D0
3054       eel_loc=0.0d0
3055       eello_turn3=0.0d0
3056       eello_turn4=0.0d0
3057       ind=0
3058       do i=1,nres
3059         num_cont_hb(i)=0
3060       enddo
3061 cd      print '(a)','Enter EELEC'
3062 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3063       do i=1,nres
3064         gel_loc_loc(i)=0.0d0
3065         gcorr_loc(i)=0.0d0
3066       enddo
3067 c
3068 c
3069 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3070 C
3071 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3072 C
3073       do i=iturn3_start,iturn3_end
3074         dxi=dc(1,i)
3075         dyi=dc(2,i)
3076         dzi=dc(3,i)
3077         dx_normi=dc_norm(1,i)
3078         dy_normi=dc_norm(2,i)
3079         dz_normi=dc_norm(3,i)
3080         xmedi=c(1,i)+0.5d0*dxi
3081         ymedi=c(2,i)+0.5d0*dyi
3082         zmedi=c(3,i)+0.5d0*dzi
3083         num_conti=0
3084         call eelecij(i,i+2,ees,evdw1,eel_loc)
3085         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3086         num_cont_hb(i)=num_conti
3087       enddo
3088       do i=iturn4_start,iturn4_end
3089         dxi=dc(1,i)
3090         dyi=dc(2,i)
3091         dzi=dc(3,i)
3092         dx_normi=dc_norm(1,i)
3093         dy_normi=dc_norm(2,i)
3094         dz_normi=dc_norm(3,i)
3095         xmedi=c(1,i)+0.5d0*dxi
3096         ymedi=c(2,i)+0.5d0*dyi
3097         zmedi=c(3,i)+0.5d0*dzi
3098         num_conti=num_cont_hb(i)
3099         call eelecij(i,i+3,ees,evdw1,eel_loc)
3100         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3101         num_cont_hb(i)=num_conti
3102       enddo   ! i
3103 c
3104 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3105 c
3106       do i=iatel_s,iatel_e
3107         dxi=dc(1,i)
3108         dyi=dc(2,i)
3109         dzi=dc(3,i)
3110         dx_normi=dc_norm(1,i)
3111         dy_normi=dc_norm(2,i)
3112         dz_normi=dc_norm(3,i)
3113         xmedi=c(1,i)+0.5d0*dxi
3114         ymedi=c(2,i)+0.5d0*dyi
3115         zmedi=c(3,i)+0.5d0*dzi
3116 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3117         num_conti=num_cont_hb(i)
3118         do j=ielstart(i),ielend(i)
3119           call eelecij(i,j,ees,evdw1,eel_loc)
3120         enddo ! j
3121         num_cont_hb(i)=num_conti
3122       enddo   ! i
3123 c      write (iout,*) "Number of loop steps in EELEC:",ind
3124 cd      do i=1,nres
3125 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3126 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3127 cd      enddo
3128 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3129 ccc      eel_loc=eel_loc+eello_turn3
3130 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3131       return
3132       end
3133 C-------------------------------------------------------------------------------
3134       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3135       implicit real*8 (a-h,o-z)
3136       include 'DIMENSIONS'
3137 #ifdef MPI
3138       include "mpif.h"
3139 #endif
3140       include 'COMMON.CONTROL'
3141       include 'COMMON.IOUNITS'
3142       include 'COMMON.GEO'
3143       include 'COMMON.VAR'
3144       include 'COMMON.LOCAL'
3145       include 'COMMON.CHAIN'
3146       include 'COMMON.DERIV'
3147       include 'COMMON.INTERACT'
3148       include 'COMMON.CONTACTS'
3149       include 'COMMON.TORSION'
3150       include 'COMMON.VECTORS'
3151       include 'COMMON.FFIELD'
3152       include 'COMMON.TIME1'
3153       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3154      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3155       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3156      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3157       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3158      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3159      &    num_conti,j1,j2
3160 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3161 #ifdef MOMENT
3162       double precision scal_el /1.0d0/
3163 #else
3164       double precision scal_el /0.5d0/
3165 #endif
3166 C 12/13/98
3167 C 13-go grudnia roku pamietnego...
3168       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3169      &                   0.0d0,1.0d0,0.0d0,
3170      &                   0.0d0,0.0d0,1.0d0/
3171 c          time00=MPI_Wtime()
3172 cd      write (iout,*) "eelecij",i,j
3173 c          ind=ind+1
3174           iteli=itel(i)
3175           itelj=itel(j)
3176           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3177           aaa=app(iteli,itelj)
3178           bbb=bpp(iteli,itelj)
3179           ael6i=ael6(iteli,itelj)
3180           ael3i=ael3(iteli,itelj)
3181           dxj=dc(1,j)
3182           dyj=dc(2,j)
3183           dzj=dc(3,j)
3184           dx_normj=dc_norm(1,j)
3185           dy_normj=dc_norm(2,j)
3186           dz_normj=dc_norm(3,j)
3187           xj=c(1,j)+0.5D0*dxj-xmedi
3188           yj=c(2,j)+0.5D0*dyj-ymedi
3189           zj=c(3,j)+0.5D0*dzj-zmedi
3190           rij=xj*xj+yj*yj+zj*zj
3191           rrmij=1.0D0/rij
3192           rij=dsqrt(rij)
3193           rmij=1.0D0/rij
3194           r3ij=rrmij*rmij
3195           r6ij=r3ij*r3ij
3196           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3197           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3198           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3199           fac=cosa-3.0D0*cosb*cosg
3200           ev1=aaa*r6ij*r6ij
3201 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3202           if (j.eq.i+2) ev1=scal_el*ev1
3203           ev2=bbb*r6ij
3204           fac3=ael6i*r6ij
3205           fac4=ael3i*r3ij
3206           evdwij=ev1+ev2
3207           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3208           el2=fac4*fac
3209           eesij=el1+el2
3210 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3211           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3212           ees=ees+eesij
3213           evdw1=evdw1+evdwij
3214 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3215 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3216 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3217 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3218
3219           if (energy_dec) then
3220               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3221               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3222           endif
3223
3224 C
3225 C Calculate contributions to the Cartesian gradient.
3226 C
3227 #ifdef SPLITELE
3228           facvdw=-6*rrmij*(ev1+evdwij)
3229           facel=-3*rrmij*(el1+eesij)
3230           fac1=fac
3231           erij(1)=xj*rmij
3232           erij(2)=yj*rmij
3233           erij(3)=zj*rmij
3234 *
3235 * Radial derivatives. First process both termini of the fragment (i,j)
3236 *
3237           ggg(1)=facel*xj
3238           ggg(2)=facel*yj
3239           ggg(3)=facel*zj
3240 c          do k=1,3
3241 c            ghalf=0.5D0*ggg(k)
3242 c            gelc(k,i)=gelc(k,i)+ghalf
3243 c            gelc(k,j)=gelc(k,j)+ghalf
3244 c          enddo
3245 c 9/28/08 AL Gradient compotents will be summed only at the end
3246           do k=1,3
3247             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3248             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3249           enddo
3250 *
3251 * Loop over residues i+1 thru j-1.
3252 *
3253 cgrad          do k=i+1,j-1
3254 cgrad            do l=1,3
3255 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3256 cgrad            enddo
3257 cgrad          enddo
3258           ggg(1)=facvdw*xj
3259           ggg(2)=facvdw*yj
3260           ggg(3)=facvdw*zj
3261 c          do k=1,3
3262 c            ghalf=0.5D0*ggg(k)
3263 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3264 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3265 c          enddo
3266 c 9/28/08 AL Gradient compotents will be summed only at the end
3267           do k=1,3
3268             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3269             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3270           enddo
3271 *
3272 * Loop over residues i+1 thru j-1.
3273 *
3274 cgrad          do k=i+1,j-1
3275 cgrad            do l=1,3
3276 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3277 cgrad            enddo
3278 cgrad          enddo
3279 #else
3280           facvdw=ev1+evdwij
3281           facel=el1+eesij
3282           fac1=fac
3283           fac=-3*rrmij*(facvdw+facvdw+facel)
3284           erij(1)=xj*rmij
3285           erij(2)=yj*rmij
3286           erij(3)=zj*rmij
3287 *
3288 * Radial derivatives. First process both termini of the fragment (i,j)
3289 *
3290           ggg(1)=fac*xj
3291           ggg(2)=fac*yj
3292           ggg(3)=fac*zj
3293 c          do k=1,3
3294 c            ghalf=0.5D0*ggg(k)
3295 c            gelc(k,i)=gelc(k,i)+ghalf
3296 c            gelc(k,j)=gelc(k,j)+ghalf
3297 c          enddo
3298 c 9/28/08 AL Gradient compotents will be summed only at the end
3299           do k=1,3
3300             gelc_long(k,j)=gelc(k,j)+ggg(k)
3301             gelc_long(k,i)=gelc(k,i)-ggg(k)
3302           enddo
3303 *
3304 * Loop over residues i+1 thru j-1.
3305 *
3306 cgrad          do k=i+1,j-1
3307 cgrad            do l=1,3
3308 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3309 cgrad            enddo
3310 cgrad          enddo
3311 c 9/28/08 AL Gradient compotents will be summed only at the end
3312           ggg(1)=facvdw*xj
3313           ggg(2)=facvdw*yj
3314           ggg(3)=facvdw*zj
3315           do k=1,3
3316             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3317             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3318           enddo
3319 #endif
3320 *
3321 * Angular part
3322 *
3323           ecosa=2.0D0*fac3*fac1+fac4
3324           fac4=-3.0D0*fac4
3325           fac3=-6.0D0*fac3
3326           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3327           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3328           do k=1,3
3329             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3330             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3331           enddo
3332 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3333 cd   &          (dcosg(k),k=1,3)
3334           do k=1,3
3335             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3336           enddo
3337 c          do k=1,3
3338 c            ghalf=0.5D0*ggg(k)
3339 c            gelc(k,i)=gelc(k,i)+ghalf
3340 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3341 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3342 c            gelc(k,j)=gelc(k,j)+ghalf
3343 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3344 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3345 c          enddo
3346 cgrad          do k=i+1,j-1
3347 cgrad            do l=1,3
3348 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3349 cgrad            enddo
3350 cgrad          enddo
3351           do k=1,3
3352             gelc(k,i)=gelc(k,i)
3353      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3354      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3355             gelc(k,j)=gelc(k,j)
3356      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3357      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3358             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3359             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3360           enddo
3361           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3362      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3363      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3364 C
3365 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3366 C   energy of a peptide unit is assumed in the form of a second-order
3367 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3368 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3369 C   are computed for EVERY pair of non-contiguous peptide groups.
3370 C
3371           if (j.lt.nres-1) then
3372             j1=j+1
3373             j2=j-1
3374           else
3375             j1=j-1
3376             j2=j-2
3377           endif
3378           kkk=0
3379           do k=1,2
3380             do l=1,2
3381               kkk=kkk+1
3382               muij(kkk)=mu(k,i)*mu(l,j)
3383             enddo
3384           enddo
3385 cd         write (iout,*) 'EELEC: i',i,' j',j
3386 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3387 cd          write(iout,*) 'muij',muij
3388           ury=scalar(uy(1,i),erij)
3389           urz=scalar(uz(1,i),erij)
3390           vry=scalar(uy(1,j),erij)
3391           vrz=scalar(uz(1,j),erij)
3392           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3393           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3394           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3395           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3396           fac=dsqrt(-ael6i)*r3ij
3397           a22=a22*fac
3398           a23=a23*fac
3399           a32=a32*fac
3400           a33=a33*fac
3401 cd          write (iout,'(4i5,4f10.5)')
3402 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3403 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3404 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3405 cd     &      uy(:,j),uz(:,j)
3406 cd          write (iout,'(4f10.5)')
3407 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3408 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3409 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3410 cd           write (iout,'(9f10.5/)')
3411 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3412 C Derivatives of the elements of A in virtual-bond vectors
3413           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3414           do k=1,3
3415             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3416             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3417             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3418             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3419             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3420             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3421             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3422             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3423             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3424             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3425             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3426             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3427           enddo
3428 C Compute radial contributions to the gradient
3429           facr=-3.0d0*rrmij
3430           a22der=a22*facr
3431           a23der=a23*facr
3432           a32der=a32*facr
3433           a33der=a33*facr
3434           agg(1,1)=a22der*xj
3435           agg(2,1)=a22der*yj
3436           agg(3,1)=a22der*zj
3437           agg(1,2)=a23der*xj
3438           agg(2,2)=a23der*yj
3439           agg(3,2)=a23der*zj
3440           agg(1,3)=a32der*xj
3441           agg(2,3)=a32der*yj
3442           agg(3,3)=a32der*zj
3443           agg(1,4)=a33der*xj
3444           agg(2,4)=a33der*yj
3445           agg(3,4)=a33der*zj
3446 C Add the contributions coming from er
3447           fac3=-3.0d0*fac
3448           do k=1,3
3449             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3450             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3451             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3452             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3453           enddo
3454           do k=1,3
3455 C Derivatives in DC(i)
3456 cgrad            ghalf1=0.5d0*agg(k,1)
3457 cgrad            ghalf2=0.5d0*agg(k,2)
3458 cgrad            ghalf3=0.5d0*agg(k,3)
3459 cgrad            ghalf4=0.5d0*agg(k,4)
3460             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3461      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3462             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3463      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3464             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3465      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3466             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3467      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3468 C Derivatives in DC(i+1)
3469             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3470      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3471             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3472      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3473             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3474      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3475             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3476      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3477 C Derivatives in DC(j)
3478             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3479      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3480             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3481      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3482             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3483      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3484             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3485      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3486 C Derivatives in DC(j+1) or DC(nres-1)
3487             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3488      &      -3.0d0*vryg(k,3)*ury)
3489             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3490      &      -3.0d0*vrzg(k,3)*ury)
3491             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3492      &      -3.0d0*vryg(k,3)*urz)
3493             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3494      &      -3.0d0*vrzg(k,3)*urz)
3495 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3496 cgrad              do l=1,4
3497 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3498 cgrad              enddo
3499 cgrad            endif
3500           enddo
3501           acipa(1,1)=a22
3502           acipa(1,2)=a23
3503           acipa(2,1)=a32
3504           acipa(2,2)=a33
3505           a22=-a22
3506           a23=-a23
3507           do l=1,2
3508             do k=1,3
3509               agg(k,l)=-agg(k,l)
3510               aggi(k,l)=-aggi(k,l)
3511               aggi1(k,l)=-aggi1(k,l)
3512               aggj(k,l)=-aggj(k,l)
3513               aggj1(k,l)=-aggj1(k,l)
3514             enddo
3515           enddo
3516           if (j.lt.nres-1) then
3517             a22=-a22
3518             a32=-a32
3519             do l=1,3,2
3520               do k=1,3
3521                 agg(k,l)=-agg(k,l)
3522                 aggi(k,l)=-aggi(k,l)
3523                 aggi1(k,l)=-aggi1(k,l)
3524                 aggj(k,l)=-aggj(k,l)
3525                 aggj1(k,l)=-aggj1(k,l)
3526               enddo
3527             enddo
3528           else
3529             a22=-a22
3530             a23=-a23
3531             a32=-a32
3532             a33=-a33
3533             do l=1,4
3534               do k=1,3
3535                 agg(k,l)=-agg(k,l)
3536                 aggi(k,l)=-aggi(k,l)
3537                 aggi1(k,l)=-aggi1(k,l)
3538                 aggj(k,l)=-aggj(k,l)
3539                 aggj1(k,l)=-aggj1(k,l)
3540               enddo
3541             enddo
3542           endif
3543           ENDIF ! WCORR
3544           IF (wel_loc.gt.0.0d0) THEN
3545 C Contribution to the local-electrostatic energy coming from the i-j pair
3546           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3547      &     +a33*muij(4)
3548 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3549
3550           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3551      &            'eelloc',i,j,eel_loc_ij
3552
3553           eel_loc=eel_loc+eel_loc_ij
3554 C Partial derivatives in virtual-bond dihedral angles gamma
3555           if (i.gt.1)
3556      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3557      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3558      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3559           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3560      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3561      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3562 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3563           do l=1,3
3564             ggg(l)=agg(l,1)*muij(1)+
3565      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3566             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3567             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3568 cgrad            ghalf=0.5d0*ggg(l)
3569 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3570 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3571           enddo
3572 cgrad          do k=i+1,j2
3573 cgrad            do l=1,3
3574 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3575 cgrad            enddo
3576 cgrad          enddo
3577 C Remaining derivatives of eello
3578           do l=1,3
3579             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3580      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3581             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3582      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3583             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3584      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3585             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3586      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3587           enddo
3588           ENDIF
3589 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3590 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3591           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3592      &       .and. num_conti.le.maxconts) then
3593 c            write (iout,*) i,j," entered corr"
3594 C
3595 C Calculate the contact function. The ith column of the array JCONT will
3596 C contain the numbers of atoms that make contacts with the atom I (of numbers
3597 C greater than I). The arrays FACONT and GACONT will contain the values of
3598 C the contact function and its derivative.
3599 c           r0ij=1.02D0*rpp(iteli,itelj)
3600 c           r0ij=1.11D0*rpp(iteli,itelj)
3601             r0ij=2.20D0*rpp(iteli,itelj)
3602 c           r0ij=1.55D0*rpp(iteli,itelj)
3603             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3604             if (fcont.gt.0.0D0) then
3605               num_conti=num_conti+1
3606               if (num_conti.gt.maxconts) then
3607                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3608      &                         ' will skip next contacts for this conf.'
3609               else
3610                 jcont_hb(num_conti,i)=j
3611 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3612 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3613                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3614      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3615 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3616 C  terms.
3617                 d_cont(num_conti,i)=rij
3618 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3619 C     --- Electrostatic-interaction matrix ---
3620                 a_chuj(1,1,num_conti,i)=a22
3621                 a_chuj(1,2,num_conti,i)=a23
3622                 a_chuj(2,1,num_conti,i)=a32
3623                 a_chuj(2,2,num_conti,i)=a33
3624 C     --- Gradient of rij
3625                 do kkk=1,3
3626                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3627                 enddo
3628                 kkll=0
3629                 do k=1,2
3630                   do l=1,2
3631                     kkll=kkll+1
3632                     do m=1,3
3633                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3634                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3635                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3636                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3637                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3638                     enddo
3639                   enddo
3640                 enddo
3641                 ENDIF
3642                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3643 C Calculate contact energies
3644                 cosa4=4.0D0*cosa
3645                 wij=cosa-3.0D0*cosb*cosg
3646                 cosbg1=cosb+cosg
3647                 cosbg2=cosb-cosg
3648 c               fac3=dsqrt(-ael6i)/r0ij**3
3649                 fac3=dsqrt(-ael6i)*r3ij
3650 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3651                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3652                 if (ees0tmp.gt.0) then
3653                   ees0pij=dsqrt(ees0tmp)
3654                 else
3655                   ees0pij=0
3656                 endif
3657 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3658                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3659                 if (ees0tmp.gt.0) then
3660                   ees0mij=dsqrt(ees0tmp)
3661                 else
3662                   ees0mij=0
3663                 endif
3664 c               ees0mij=0.0D0
3665                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3666                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3667 C Diagnostics. Comment out or remove after debugging!
3668 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3669 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3670 c               ees0m(num_conti,i)=0.0D0
3671 C End diagnostics.
3672 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3673 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3674 C Angular derivatives of the contact function
3675                 ees0pij1=fac3/ees0pij
3676                 ees0mij1=fac3/ees0mij
3677                 fac3p=-3.0D0*fac3*rrmij
3678                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3679                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3680 c               ees0mij1=0.0D0
3681                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3682                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3683                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3684                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3685                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3686                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3687                 ecosap=ecosa1+ecosa2
3688                 ecosbp=ecosb1+ecosb2
3689                 ecosgp=ecosg1+ecosg2
3690                 ecosam=ecosa1-ecosa2
3691                 ecosbm=ecosb1-ecosb2
3692                 ecosgm=ecosg1-ecosg2
3693 C Diagnostics
3694 c               ecosap=ecosa1
3695 c               ecosbp=ecosb1
3696 c               ecosgp=ecosg1
3697 c               ecosam=0.0D0
3698 c               ecosbm=0.0D0
3699 c               ecosgm=0.0D0
3700 C End diagnostics
3701                 facont_hb(num_conti,i)=fcont
3702                 fprimcont=fprimcont/rij
3703 cd              facont_hb(num_conti,i)=1.0D0
3704 C Following line is for diagnostics.
3705 cd              fprimcont=0.0D0
3706                 do k=1,3
3707                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3708                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3709                 enddo
3710                 do k=1,3
3711                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3712                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3713                 enddo
3714                 gggp(1)=gggp(1)+ees0pijp*xj
3715                 gggp(2)=gggp(2)+ees0pijp*yj
3716                 gggp(3)=gggp(3)+ees0pijp*zj
3717                 gggm(1)=gggm(1)+ees0mijp*xj
3718                 gggm(2)=gggm(2)+ees0mijp*yj
3719                 gggm(3)=gggm(3)+ees0mijp*zj
3720 C Derivatives due to the contact function
3721                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3722                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3723                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3724                 do k=1,3
3725 c
3726 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3727 c          following the change of gradient-summation algorithm.
3728 c
3729 cgrad                  ghalfp=0.5D0*gggp(k)
3730 cgrad                  ghalfm=0.5D0*gggm(k)
3731                   gacontp_hb1(k,num_conti,i)=!ghalfp
3732      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3733      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3734                   gacontp_hb2(k,num_conti,i)=!ghalfp
3735      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3736      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3737                   gacontp_hb3(k,num_conti,i)=gggp(k)
3738                   gacontm_hb1(k,num_conti,i)=!ghalfm
3739      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3740      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3741                   gacontm_hb2(k,num_conti,i)=!ghalfm
3742      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3743      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3744                   gacontm_hb3(k,num_conti,i)=gggm(k)
3745                 enddo
3746 C Diagnostics. Comment out or remove after debugging!
3747 cdiag           do k=1,3
3748 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3749 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3750 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3751 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3752 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3753 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3754 cdiag           enddo
3755               ENDIF ! wcorr
3756               endif  ! num_conti.le.maxconts
3757             endif  ! fcont.gt.0
3758           endif    ! j.gt.i+1
3759           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3760             do k=1,4
3761               do l=1,3
3762                 ghalf=0.5d0*agg(l,k)
3763                 aggi(l,k)=aggi(l,k)+ghalf
3764                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3765                 aggj(l,k)=aggj(l,k)+ghalf
3766               enddo
3767             enddo
3768             if (j.eq.nres-1 .and. i.lt.j-2) then
3769               do k=1,4
3770                 do l=1,3
3771                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3772                 enddo
3773               enddo
3774             endif
3775           endif
3776 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3777       return
3778       end
3779 C-----------------------------------------------------------------------------
3780       subroutine eturn3(i,eello_turn3)
3781 C Third- and fourth-order contributions from turns
3782       implicit real*8 (a-h,o-z)
3783       include 'DIMENSIONS'
3784       include 'COMMON.IOUNITS'
3785       include 'COMMON.GEO'
3786       include 'COMMON.VAR'
3787       include 'COMMON.LOCAL'
3788       include 'COMMON.CHAIN'
3789       include 'COMMON.DERIV'
3790       include 'COMMON.INTERACT'
3791       include 'COMMON.CONTACTS'
3792       include 'COMMON.TORSION'
3793       include 'COMMON.VECTORS'
3794       include 'COMMON.FFIELD'
3795       include 'COMMON.CONTROL'
3796       dimension ggg(3)
3797       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3798      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3799      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3800       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3801      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3802       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3803      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3804      &    num_conti,j1,j2
3805       j=i+2
3806 c      write (iout,*) "eturn3",i,j,j1,j2
3807       a_temp(1,1)=a22
3808       a_temp(1,2)=a23
3809       a_temp(2,1)=a32
3810       a_temp(2,2)=a33
3811 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3812 C
3813 C               Third-order contributions
3814 C
3815 C                 (i+2)o----(i+3)
3816 C                      | |
3817 C                      | |
3818 C                 (i+1)o----i
3819 C
3820 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3821 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3822         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3823         call transpose2(auxmat(1,1),auxmat1(1,1))
3824         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3825         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3826         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3827      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3828 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3829 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3830 cd     &    ' eello_turn3_num',4*eello_turn3_num
3831 C Derivatives in gamma(i)
3832         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3833         call transpose2(auxmat2(1,1),auxmat3(1,1))
3834         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3835         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3836 C Derivatives in gamma(i+1)
3837         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3838         call transpose2(auxmat2(1,1),auxmat3(1,1))
3839         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3840         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3841      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3842 C Cartesian derivatives
3843         do l=1,3
3844 c            ghalf1=0.5d0*agg(l,1)
3845 c            ghalf2=0.5d0*agg(l,2)
3846 c            ghalf3=0.5d0*agg(l,3)
3847 c            ghalf4=0.5d0*agg(l,4)
3848           a_temp(1,1)=aggi(l,1)!+ghalf1
3849           a_temp(1,2)=aggi(l,2)!+ghalf2
3850           a_temp(2,1)=aggi(l,3)!+ghalf3
3851           a_temp(2,2)=aggi(l,4)!+ghalf4
3852           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3853           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3854      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3855           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3856           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3857           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3858           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3859           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3860           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3861      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3862           a_temp(1,1)=aggj(l,1)!+ghalf1
3863           a_temp(1,2)=aggj(l,2)!+ghalf2
3864           a_temp(2,1)=aggj(l,3)!+ghalf3
3865           a_temp(2,2)=aggj(l,4)!+ghalf4
3866           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3867           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3868      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3869           a_temp(1,1)=aggj1(l,1)
3870           a_temp(1,2)=aggj1(l,2)
3871           a_temp(2,1)=aggj1(l,3)
3872           a_temp(2,2)=aggj1(l,4)
3873           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3874           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3875      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3876         enddo
3877       return
3878       end
3879 C-------------------------------------------------------------------------------
3880       subroutine eturn4(i,eello_turn4)
3881 C Third- and fourth-order contributions from turns
3882       implicit real*8 (a-h,o-z)
3883       include 'DIMENSIONS'
3884       include 'COMMON.IOUNITS'
3885       include 'COMMON.GEO'
3886       include 'COMMON.VAR'
3887       include 'COMMON.LOCAL'
3888       include 'COMMON.CHAIN'
3889       include 'COMMON.DERIV'
3890       include 'COMMON.INTERACT'
3891       include 'COMMON.CONTACTS'
3892       include 'COMMON.TORSION'
3893       include 'COMMON.VECTORS'
3894       include 'COMMON.FFIELD'
3895       include 'COMMON.CONTROL'
3896       dimension ggg(3)
3897       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3898      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3899      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3900       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3901      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3902       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3903      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3904      &    num_conti,j1,j2
3905       j=i+3
3906 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3907 C
3908 C               Fourth-order contributions
3909 C
3910 C                 (i+3)o----(i+4)
3911 C                     /  |
3912 C               (i+2)o   |
3913 C                     \  |
3914 C                 (i+1)o----i
3915 C
3916 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3917 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3918 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3919         a_temp(1,1)=a22
3920         a_temp(1,2)=a23
3921         a_temp(2,1)=a32
3922         a_temp(2,2)=a33
3923         iti1=itortyp(itype(i+1))
3924         iti2=itortyp(itype(i+2))
3925         iti3=itortyp(itype(i+3))
3926 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3927         call transpose2(EUg(1,1,i+1),e1t(1,1))
3928         call transpose2(Eug(1,1,i+2),e2t(1,1))
3929         call transpose2(Eug(1,1,i+3),e3t(1,1))
3930         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3931         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3932         s1=scalar2(b1(1,iti2),auxvec(1))
3933         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3934         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3935         s2=scalar2(b1(1,iti1),auxvec(1))
3936         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3937         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3938         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3939         eello_turn4=eello_turn4-(s1+s2+s3)
3940         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3941      &      'eturn4',i,j,-(s1+s2+s3)
3942 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3943 cd     &    ' eello_turn4_num',8*eello_turn4_num
3944 C Derivatives in gamma(i)
3945         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3946         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3947         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3948         s1=scalar2(b1(1,iti2),auxvec(1))
3949         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3950         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3951         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3952 C Derivatives in gamma(i+1)
3953         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3954         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3955         s2=scalar2(b1(1,iti1),auxvec(1))
3956         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3957         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3958         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3959         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3960 C Derivatives in gamma(i+2)
3961         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3962         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3963         s1=scalar2(b1(1,iti2),auxvec(1))
3964         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3965         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3966         s2=scalar2(b1(1,iti1),auxvec(1))
3967         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3968         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3969         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3970         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3971 C Cartesian derivatives
3972 C Derivatives of this turn contributions in DC(i+2)
3973         if (j.lt.nres-1) then
3974           do l=1,3
3975             a_temp(1,1)=agg(l,1)
3976             a_temp(1,2)=agg(l,2)
3977             a_temp(2,1)=agg(l,3)
3978             a_temp(2,2)=agg(l,4)
3979             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3980             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3981             s1=scalar2(b1(1,iti2),auxvec(1))
3982             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3983             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3984             s2=scalar2(b1(1,iti1),auxvec(1))
3985             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3986             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3987             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3988             ggg(l)=-(s1+s2+s3)
3989             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3990           enddo
3991         endif
3992 C Remaining derivatives of this turn contribution
3993         do l=1,3
3994           a_temp(1,1)=aggi(l,1)
3995           a_temp(1,2)=aggi(l,2)
3996           a_temp(2,1)=aggi(l,3)
3997           a_temp(2,2)=aggi(l,4)
3998           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3999           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4000           s1=scalar2(b1(1,iti2),auxvec(1))
4001           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4002           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4003           s2=scalar2(b1(1,iti1),auxvec(1))
4004           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4005           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4006           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4007           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4008           a_temp(1,1)=aggi1(l,1)
4009           a_temp(1,2)=aggi1(l,2)
4010           a_temp(2,1)=aggi1(l,3)
4011           a_temp(2,2)=aggi1(l,4)
4012           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4013           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4014           s1=scalar2(b1(1,iti2),auxvec(1))
4015           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4016           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4017           s2=scalar2(b1(1,iti1),auxvec(1))
4018           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4019           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4020           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4021           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4022           a_temp(1,1)=aggj(l,1)
4023           a_temp(1,2)=aggj(l,2)
4024           a_temp(2,1)=aggj(l,3)
4025           a_temp(2,2)=aggj(l,4)
4026           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4027           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4028           s1=scalar2(b1(1,iti2),auxvec(1))
4029           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4030           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4031           s2=scalar2(b1(1,iti1),auxvec(1))
4032           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4033           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4034           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4035           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4036           a_temp(1,1)=aggj1(l,1)
4037           a_temp(1,2)=aggj1(l,2)
4038           a_temp(2,1)=aggj1(l,3)
4039           a_temp(2,2)=aggj1(l,4)
4040           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4041           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4042           s1=scalar2(b1(1,iti2),auxvec(1))
4043           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4044           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4045           s2=scalar2(b1(1,iti1),auxvec(1))
4046           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4047           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4048           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4049 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4050           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4051         enddo
4052       return
4053       end
4054 C-----------------------------------------------------------------------------
4055       subroutine vecpr(u,v,w)
4056       implicit real*8(a-h,o-z)
4057       dimension u(3),v(3),w(3)
4058       w(1)=u(2)*v(3)-u(3)*v(2)
4059       w(2)=-u(1)*v(3)+u(3)*v(1)
4060       w(3)=u(1)*v(2)-u(2)*v(1)
4061       return
4062       end
4063 C-----------------------------------------------------------------------------
4064       subroutine unormderiv(u,ugrad,unorm,ungrad)
4065 C This subroutine computes the derivatives of a normalized vector u, given
4066 C the derivatives computed without normalization conditions, ugrad. Returns
4067 C ungrad.
4068       implicit none
4069       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4070       double precision vec(3)
4071       double precision scalar
4072       integer i,j
4073 c      write (2,*) 'ugrad',ugrad
4074 c      write (2,*) 'u',u
4075       do i=1,3
4076         vec(i)=scalar(ugrad(1,i),u(1))
4077       enddo
4078 c      write (2,*) 'vec',vec
4079       do i=1,3
4080         do j=1,3
4081           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4082         enddo
4083       enddo
4084 c      write (2,*) 'ungrad',ungrad
4085       return
4086       end
4087 C-----------------------------------------------------------------------------
4088       subroutine escp_soft_sphere(evdw2,evdw2_14)
4089 C
4090 C This subroutine calculates the excluded-volume interaction energy between
4091 C peptide-group centers and side chains and its gradient in virtual-bond and
4092 C side-chain vectors.
4093 C
4094       implicit real*8 (a-h,o-z)
4095       include 'DIMENSIONS'
4096       include 'COMMON.GEO'
4097       include 'COMMON.VAR'
4098       include 'COMMON.LOCAL'
4099       include 'COMMON.CHAIN'
4100       include 'COMMON.DERIV'
4101       include 'COMMON.INTERACT'
4102       include 'COMMON.FFIELD'
4103       include 'COMMON.IOUNITS'
4104       include 'COMMON.CONTROL'
4105       dimension ggg(3)
4106       evdw2=0.0D0
4107       evdw2_14=0.0d0
4108       r0_scp=4.5d0
4109 cd    print '(a)','Enter ESCP'
4110 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4111       do i=iatscp_s,iatscp_e
4112         iteli=itel(i)
4113         xi=0.5D0*(c(1,i)+c(1,i+1))
4114         yi=0.5D0*(c(2,i)+c(2,i+1))
4115         zi=0.5D0*(c(3,i)+c(3,i+1))
4116
4117         do iint=1,nscp_gr(i)
4118
4119         do j=iscpstart(i,iint),iscpend(i,iint)
4120           itypj=itype(j)
4121 C Uncomment following three lines for SC-p interactions
4122 c         xj=c(1,nres+j)-xi
4123 c         yj=c(2,nres+j)-yi
4124 c         zj=c(3,nres+j)-zi
4125 C Uncomment following three lines for Ca-p interactions
4126           xj=c(1,j)-xi
4127           yj=c(2,j)-yi
4128           zj=c(3,j)-zi
4129           rij=xj*xj+yj*yj+zj*zj
4130           r0ij=r0_scp
4131           r0ijsq=r0ij*r0ij
4132           if (rij.lt.r0ijsq) then
4133             evdwij=0.25d0*(rij-r0ijsq)**2
4134             fac=rij-r0ijsq
4135           else
4136             evdwij=0.0d0
4137             fac=0.0d0
4138           endif
4139           evdw2=evdw2+evdwij
4140 C
4141 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4142 C
4143           ggg(1)=xj*fac
4144           ggg(2)=yj*fac
4145           ggg(3)=zj*fac
4146 cgrad          if (j.lt.i) then
4147 cd          write (iout,*) 'j<i'
4148 C Uncomment following three lines for SC-p interactions
4149 c           do k=1,3
4150 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4151 c           enddo
4152 cgrad          else
4153 cd          write (iout,*) 'j>i'
4154 cgrad            do k=1,3
4155 cgrad              ggg(k)=-ggg(k)
4156 C Uncomment following line for SC-p interactions
4157 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4158 cgrad            enddo
4159 cgrad          endif
4160 cgrad          do k=1,3
4161 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4162 cgrad          enddo
4163 cgrad          kstart=min0(i+1,j)
4164 cgrad          kend=max0(i-1,j-1)
4165 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4166 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4167 cgrad          do k=kstart,kend
4168 cgrad            do l=1,3
4169 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4170 cgrad            enddo
4171 cgrad          enddo
4172           do k=1,3
4173             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4174             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4175           enddo
4176         enddo
4177
4178         enddo ! iint
4179       enddo ! i
4180       return
4181       end
4182 C-----------------------------------------------------------------------------
4183       subroutine escp(evdw2,evdw2_14)
4184 C
4185 C This subroutine calculates the excluded-volume interaction energy between
4186 C peptide-group centers and side chains and its gradient in virtual-bond and
4187 C side-chain vectors.
4188 C
4189       implicit real*8 (a-h,o-z)
4190       include 'DIMENSIONS'
4191       include 'COMMON.GEO'
4192       include 'COMMON.VAR'
4193       include 'COMMON.LOCAL'
4194       include 'COMMON.CHAIN'
4195       include 'COMMON.DERIV'
4196       include 'COMMON.INTERACT'
4197       include 'COMMON.FFIELD'
4198       include 'COMMON.IOUNITS'
4199       include 'COMMON.CONTROL'
4200       dimension ggg(3)
4201       evdw2=0.0D0
4202       evdw2_14=0.0d0
4203 cd    print '(a)','Enter ESCP'
4204 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4205       do i=iatscp_s,iatscp_e
4206         iteli=itel(i)
4207         xi=0.5D0*(c(1,i)+c(1,i+1))
4208         yi=0.5D0*(c(2,i)+c(2,i+1))
4209         zi=0.5D0*(c(3,i)+c(3,i+1))
4210
4211         do iint=1,nscp_gr(i)
4212
4213         do j=iscpstart(i,iint),iscpend(i,iint)
4214           itypj=itype(j)
4215 C Uncomment following three lines for SC-p interactions
4216 c         xj=c(1,nres+j)-xi
4217 c         yj=c(2,nres+j)-yi
4218 c         zj=c(3,nres+j)-zi
4219 C Uncomment following three lines for Ca-p interactions
4220           xj=c(1,j)-xi
4221           yj=c(2,j)-yi
4222           zj=c(3,j)-zi
4223           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4224           fac=rrij**expon2
4225           e1=fac*fac*aad(itypj,iteli)
4226           e2=fac*bad(itypj,iteli)
4227           if (iabs(j-i) .le. 2) then
4228             e1=scal14*e1
4229             e2=scal14*e2
4230             evdw2_14=evdw2_14+e1+e2
4231           endif
4232           evdwij=e1+e2
4233           evdw2=evdw2+evdwij
4234           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4235      &        'evdw2',i,j,evdwij
4236 C
4237 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4238 C
4239           fac=-(evdwij+e1)*rrij
4240           ggg(1)=xj*fac
4241           ggg(2)=yj*fac
4242           ggg(3)=zj*fac
4243 cgrad          if (j.lt.i) then
4244 cd          write (iout,*) 'j<i'
4245 C Uncomment following three lines for SC-p interactions
4246 c           do k=1,3
4247 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4248 c           enddo
4249 cgrad          else
4250 cd          write (iout,*) 'j>i'
4251 cgrad            do k=1,3
4252 cgrad              ggg(k)=-ggg(k)
4253 C Uncomment following line for SC-p interactions
4254 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4255 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4256 cgrad            enddo
4257 cgrad          endif
4258 cgrad          do k=1,3
4259 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4260 cgrad          enddo
4261 cgrad          kstart=min0(i+1,j)
4262 cgrad          kend=max0(i-1,j-1)
4263 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4264 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4265 cgrad          do k=kstart,kend
4266 cgrad            do l=1,3
4267 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4268 cgrad            enddo
4269 cgrad          enddo
4270           do k=1,3
4271             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4272             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4273           enddo
4274         enddo
4275
4276         enddo ! iint
4277       enddo ! i
4278       do i=1,nct
4279         do j=1,3
4280           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4281           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4282           gradx_scp(j,i)=expon*gradx_scp(j,i)
4283         enddo
4284       enddo
4285 C******************************************************************************
4286 C
4287 C                              N O T E !!!
4288 C
4289 C To save time the factor EXPON has been extracted from ALL components
4290 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4291 C use!
4292 C
4293 C******************************************************************************
4294       return
4295       end
4296 C--------------------------------------------------------------------------
4297       subroutine edis(ehpb)
4298 C
4299 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4300 C
4301       implicit real*8 (a-h,o-z)
4302       include 'DIMENSIONS'
4303       include 'COMMON.SBRIDGE'
4304       include 'COMMON.CHAIN'
4305       include 'COMMON.DERIV'
4306       include 'COMMON.VAR'
4307       include 'COMMON.INTERACT'
4308       include 'COMMON.IOUNITS'
4309       dimension ggg(3)
4310       ehpb=0.0D0
4311 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4312 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4313       if (link_end.eq.0) return
4314       do i=link_start,link_end
4315 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4316 C CA-CA distance used in regularization of structure.
4317         ii=ihpb(i)
4318         jj=jhpb(i)
4319 C iii and jjj point to the residues for which the distance is assigned.
4320         if (ii.gt.nres) then
4321           iii=ii-nres
4322           jjj=jj-nres
4323         else
4324           iii=ii
4325           jjj=jj
4326         endif
4327 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4328 c     &    dhpb(i),dhpb1(i),forcon(i)
4329 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4330 C    distance and angle dependent SS bond potential.
4331         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4332           call ssbond_ene(iii,jjj,eij)
4333           ehpb=ehpb+2*eij
4334 cd          write (iout,*) "eij",eij
4335         else if (ii.gt.nres .and. jj.gt.nres) then
4336 c Restraints from contact prediction
4337           dd=dist(ii,jj)
4338           if (dhpb1(i).gt.0.0d0) then
4339             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4340             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4341 c            write (iout,*) "beta nmr",
4342 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4343           else
4344             dd=dist(ii,jj)
4345             rdis=dd-dhpb(i)
4346 C Get the force constant corresponding to this distance.
4347             waga=forcon(i)
4348 C Calculate the contribution to energy.
4349             ehpb=ehpb+waga*rdis*rdis
4350 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4351 C
4352 C Evaluate gradient.
4353 C
4354             fac=waga*rdis/dd
4355           endif
4356           do j=1,3
4357             ggg(j)=fac*(c(j,jj)-c(j,ii))
4358           enddo
4359           do j=1,3
4360             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4361             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4362           enddo
4363           do k=1,3
4364             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4365             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4366           enddo
4367         else
4368 C Calculate the distance between the two points and its difference from the
4369 C target distance.
4370           dd=dist(ii,jj)
4371           if (dhpb1(i).gt.0.0d0) then
4372             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4373             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4374 c            write (iout,*) "alph nmr",
4375 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4376           else
4377             rdis=dd-dhpb(i)
4378 C Get the force constant corresponding to this distance.
4379             waga=forcon(i)
4380 C Calculate the contribution to energy.
4381             ehpb=ehpb+waga*rdis*rdis
4382 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4383 C
4384 C Evaluate gradient.
4385 C
4386             fac=waga*rdis/dd
4387           endif
4388 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4389 cd   &   ' waga=',waga,' fac=',fac
4390             do j=1,3
4391               ggg(j)=fac*(c(j,jj)-c(j,ii))
4392             enddo
4393 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4394 C If this is a SC-SC distance, we need to calculate the contributions to the
4395 C Cartesian gradient in the SC vectors (ghpbx).
4396           if (iii.lt.ii) then
4397           do j=1,3
4398             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4399             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4400           enddo
4401           endif
4402 cgrad        do j=iii,jjj-1
4403 cgrad          do k=1,3
4404 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4405 cgrad          enddo
4406 cgrad        enddo
4407           do k=1,3
4408             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4409             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4410           enddo
4411         endif
4412       enddo
4413       ehpb=0.5D0*ehpb
4414       return
4415       end
4416 C--------------------------------------------------------------------------
4417       subroutine ssbond_ene(i,j,eij)
4418 C
4419 C Calculate the distance and angle dependent SS-bond potential energy
4420 C using a free-energy function derived based on RHF/6-31G** ab initio
4421 C calculations of diethyl disulfide.
4422 C
4423 C A. Liwo and U. Kozlowska, 11/24/03
4424 C
4425       implicit real*8 (a-h,o-z)
4426       include 'DIMENSIONS'
4427       include 'COMMON.SBRIDGE'
4428       include 'COMMON.CHAIN'
4429       include 'COMMON.DERIV'
4430       include 'COMMON.LOCAL'
4431       include 'COMMON.INTERACT'
4432       include 'COMMON.VAR'
4433       include 'COMMON.IOUNITS'
4434       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4435       itypi=itype(i)
4436       xi=c(1,nres+i)
4437       yi=c(2,nres+i)
4438       zi=c(3,nres+i)
4439       dxi=dc_norm(1,nres+i)
4440       dyi=dc_norm(2,nres+i)
4441       dzi=dc_norm(3,nres+i)
4442 c      dsci_inv=dsc_inv(itypi)
4443       dsci_inv=vbld_inv(nres+i)
4444       itypj=itype(j)
4445 c      dscj_inv=dsc_inv(itypj)
4446       dscj_inv=vbld_inv(nres+j)
4447       xj=c(1,nres+j)-xi
4448       yj=c(2,nres+j)-yi
4449       zj=c(3,nres+j)-zi
4450       dxj=dc_norm(1,nres+j)
4451       dyj=dc_norm(2,nres+j)
4452       dzj=dc_norm(3,nres+j)
4453       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4454       rij=dsqrt(rrij)
4455       erij(1)=xj*rij
4456       erij(2)=yj*rij
4457       erij(3)=zj*rij
4458       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4459       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4460       om12=dxi*dxj+dyi*dyj+dzi*dzj
4461       do k=1,3
4462         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4463         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4464       enddo
4465       rij=1.0d0/rij
4466       deltad=rij-d0cm
4467       deltat1=1.0d0-om1
4468       deltat2=1.0d0+om2
4469       deltat12=om2-om1+2.0d0
4470       cosphi=om12-om1*om2
4471       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4472      &  +akct*deltad*deltat12
4473      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4474 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4475 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4476 c     &  " deltat12",deltat12," eij",eij
4477       ed=2*akcm*deltad+akct*deltat12
4478       pom1=akct*deltad
4479       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4480       eom1=-2*akth*deltat1-pom1-om2*pom2
4481       eom2= 2*akth*deltat2+pom1-om1*pom2
4482       eom12=pom2
4483       do k=1,3
4484         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4485         ghpbx(k,i)=ghpbx(k,i)-ggk
4486      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4487      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4488         ghpbx(k,j)=ghpbx(k,j)+ggk
4489      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4490      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4491         ghpbc(k,i)=ghpbc(k,i)-ggk
4492         ghpbc(k,j)=ghpbc(k,j)+ggk
4493       enddo
4494 C
4495 C Calculate the components of the gradient in DC and X
4496 C
4497 cgrad      do k=i,j-1
4498 cgrad        do l=1,3
4499 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4500 cgrad        enddo
4501 cgrad      enddo
4502       return
4503       end
4504 C--------------------------------------------------------------------------
4505       subroutine ebond(estr)
4506 c
4507 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4508 c
4509       implicit real*8 (a-h,o-z)
4510       include 'DIMENSIONS'
4511       include 'COMMON.LOCAL'
4512       include 'COMMON.GEO'
4513       include 'COMMON.INTERACT'
4514       include 'COMMON.DERIV'
4515       include 'COMMON.VAR'
4516       include 'COMMON.CHAIN'
4517       include 'COMMON.IOUNITS'
4518       include 'COMMON.NAMES'
4519       include 'COMMON.FFIELD'
4520       include 'COMMON.CONTROL'
4521       include 'COMMON.SETUP'
4522       double precision u(3),ud(3)
4523       estr=0.0d0
4524       do i=ibondp_start,ibondp_end
4525         diff = vbld(i)-vbldp0
4526 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4527         estr=estr+diff*diff
4528         do j=1,3
4529           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4530         enddo
4531 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4532       enddo
4533       estr=0.5d0*AKP*estr
4534 c
4535 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4536 c
4537       do i=ibond_start,ibond_end
4538         iti=itype(i)
4539         if (iti.ne.10) then
4540           nbi=nbondterm(iti)
4541           if (nbi.eq.1) then
4542             diff=vbld(i+nres)-vbldsc0(1,iti)
4543 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4544 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4545             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4546             do j=1,3
4547               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4548             enddo
4549           else
4550             do j=1,nbi
4551               diff=vbld(i+nres)-vbldsc0(j,iti)
4552               ud(j)=aksc(j,iti)*diff
4553               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4554             enddo
4555             uprod=u(1)
4556             do j=2,nbi
4557               uprod=uprod*u(j)
4558             enddo
4559             usum=0.0d0
4560             usumsqder=0.0d0
4561             do j=1,nbi
4562               uprod1=1.0d0
4563               uprod2=1.0d0
4564               do k=1,nbi
4565                 if (k.ne.j) then
4566                   uprod1=uprod1*u(k)
4567                   uprod2=uprod2*u(k)*u(k)
4568                 endif
4569               enddo
4570               usum=usum+uprod1
4571               usumsqder=usumsqder+ud(j)*uprod2
4572             enddo
4573             estr=estr+uprod/usum
4574             do j=1,3
4575              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4576             enddo
4577           endif
4578         endif
4579       enddo
4580       return
4581       end
4582 #ifdef CRYST_THETA
4583 C--------------------------------------------------------------------------
4584       subroutine ebend(etheta)
4585 C
4586 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4587 C angles gamma and its derivatives in consecutive thetas and gammas.
4588 C
4589       implicit real*8 (a-h,o-z)
4590       include 'DIMENSIONS'
4591       include 'COMMON.LOCAL'
4592       include 'COMMON.GEO'
4593       include 'COMMON.INTERACT'
4594       include 'COMMON.DERIV'
4595       include 'COMMON.VAR'
4596       include 'COMMON.CHAIN'
4597       include 'COMMON.IOUNITS'
4598       include 'COMMON.NAMES'
4599       include 'COMMON.FFIELD'
4600       include 'COMMON.CONTROL'
4601       common /calcthet/ term1,term2,termm,diffak,ratak,
4602      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4603      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4604       double precision y(2),z(2)
4605       delta=0.02d0*pi
4606 c      time11=dexp(-2*time)
4607 c      time12=1.0d0
4608       etheta=0.0D0
4609 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4610       do i=ithet_start,ithet_end
4611 C Zero the energy function and its derivative at 0 or pi.
4612         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4613         it=itype(i-1)
4614         if (i.gt.3) then
4615 #ifdef OSF
4616           phii=phi(i)
4617           if (phii.ne.phii) phii=150.0
4618 #else
4619           phii=phi(i)
4620 #endif
4621           y(1)=dcos(phii)
4622           y(2)=dsin(phii)
4623         else
4624           y(1)=0.0D0
4625           y(2)=0.0D0
4626         endif
4627         if (i.lt.nres) then
4628 #ifdef OSF
4629           phii1=phi(i+1)
4630           if (phii1.ne.phii1) phii1=150.0
4631           phii1=pinorm(phii1)
4632           z(1)=cos(phii1)
4633 #else
4634           phii1=phi(i+1)
4635           z(1)=dcos(phii1)
4636 #endif
4637           z(2)=dsin(phii1)
4638         else
4639           z(1)=0.0D0
4640           z(2)=0.0D0
4641         endif
4642 C Calculate the "mean" value of theta from the part of the distribution
4643 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4644 C In following comments this theta will be referred to as t_c.
4645         thet_pred_mean=0.0d0
4646         do k=1,2
4647           athetk=athet(k,it)
4648           bthetk=bthet(k,it)
4649           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4650         enddo
4651         dthett=thet_pred_mean*ssd
4652         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4653 C Derivatives of the "mean" values in gamma1 and gamma2.
4654         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4655         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4656         if (theta(i).gt.pi-delta) then
4657           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4658      &         E_tc0)
4659           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4660           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4661           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4662      &        E_theta)
4663           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4664      &        E_tc)
4665         else if (theta(i).lt.delta) then
4666           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4667           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4668           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4669      &        E_theta)
4670           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4671           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4672      &        E_tc)
4673         else
4674           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4675      &        E_theta,E_tc)
4676         endif
4677         etheta=etheta+ethetai
4678         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4679      &      'ebend',i,ethetai
4680         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4681         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4682         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4683       enddo
4684 C Ufff.... We've done all this!!!
4685       return
4686       end
4687 C---------------------------------------------------------------------------
4688       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4689      &     E_tc)
4690       implicit real*8 (a-h,o-z)
4691       include 'DIMENSIONS'
4692       include 'COMMON.LOCAL'
4693       include 'COMMON.IOUNITS'
4694       common /calcthet/ term1,term2,termm,diffak,ratak,
4695      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4696      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4697 C Calculate the contributions to both Gaussian lobes.
4698 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4699 C The "polynomial part" of the "standard deviation" of this part of
4700 C the distribution.
4701         sig=polthet(3,it)
4702         do j=2,0,-1
4703           sig=sig*thet_pred_mean+polthet(j,it)
4704         enddo
4705 C Derivative of the "interior part" of the "standard deviation of the"
4706 C gamma-dependent Gaussian lobe in t_c.
4707         sigtc=3*polthet(3,it)
4708         do j=2,1,-1
4709           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4710         enddo
4711         sigtc=sig*sigtc
4712 C Set the parameters of both Gaussian lobes of the distribution.
4713 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4714         fac=sig*sig+sigc0(it)
4715         sigcsq=fac+fac
4716         sigc=1.0D0/sigcsq
4717 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4718         sigsqtc=-4.0D0*sigcsq*sigtc
4719 c       print *,i,sig,sigtc,sigsqtc
4720 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4721         sigtc=-sigtc/(fac*fac)
4722 C Following variable is sigma(t_c)**(-2)
4723         sigcsq=sigcsq*sigcsq
4724         sig0i=sig0(it)
4725         sig0inv=1.0D0/sig0i**2
4726         delthec=thetai-thet_pred_mean
4727         delthe0=thetai-theta0i
4728         term1=-0.5D0*sigcsq*delthec*delthec
4729         term2=-0.5D0*sig0inv*delthe0*delthe0
4730 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4731 C NaNs in taking the logarithm. We extract the largest exponent which is added
4732 C to the energy (this being the log of the distribution) at the end of energy
4733 C term evaluation for this virtual-bond angle.
4734         if (term1.gt.term2) then
4735           termm=term1
4736           term2=dexp(term2-termm)
4737           term1=1.0d0
4738         else
4739           termm=term2
4740           term1=dexp(term1-termm)
4741           term2=1.0d0
4742         endif
4743 C The ratio between the gamma-independent and gamma-dependent lobes of
4744 C the distribution is a Gaussian function of thet_pred_mean too.
4745         diffak=gthet(2,it)-thet_pred_mean
4746         ratak=diffak/gthet(3,it)**2
4747         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4748 C Let's differentiate it in thet_pred_mean NOW.
4749         aktc=ak*ratak
4750 C Now put together the distribution terms to make complete distribution.
4751         termexp=term1+ak*term2
4752         termpre=sigc+ak*sig0i
4753 C Contribution of the bending energy from this theta is just the -log of
4754 C the sum of the contributions from the two lobes and the pre-exponential
4755 C factor. Simple enough, isn't it?
4756         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4757 C NOW the derivatives!!!
4758 C 6/6/97 Take into account the deformation.
4759         E_theta=(delthec*sigcsq*term1
4760      &       +ak*delthe0*sig0inv*term2)/termexp
4761         E_tc=((sigtc+aktc*sig0i)/termpre
4762      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4763      &       aktc*term2)/termexp)
4764       return
4765       end
4766 c-----------------------------------------------------------------------------
4767       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4768       implicit real*8 (a-h,o-z)
4769       include 'DIMENSIONS'
4770       include 'COMMON.LOCAL'
4771       include 'COMMON.IOUNITS'
4772       common /calcthet/ term1,term2,termm,diffak,ratak,
4773      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4774      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4775       delthec=thetai-thet_pred_mean
4776       delthe0=thetai-theta0i
4777 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4778       t3 = thetai-thet_pred_mean
4779       t6 = t3**2
4780       t9 = term1
4781       t12 = t3*sigcsq
4782       t14 = t12+t6*sigsqtc
4783       t16 = 1.0d0
4784       t21 = thetai-theta0i
4785       t23 = t21**2
4786       t26 = term2
4787       t27 = t21*t26
4788       t32 = termexp
4789       t40 = t32**2
4790       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4791      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4792      & *(-t12*t9-ak*sig0inv*t27)
4793       return
4794       end
4795 #else
4796 C--------------------------------------------------------------------------
4797       subroutine ebend(etheta)
4798 C
4799 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4800 C angles gamma and its derivatives in consecutive thetas and gammas.
4801 C ab initio-derived potentials from
4802 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4803 C
4804       implicit real*8 (a-h,o-z)
4805       include 'DIMENSIONS'
4806       include 'COMMON.LOCAL'
4807       include 'COMMON.GEO'
4808       include 'COMMON.INTERACT'
4809       include 'COMMON.DERIV'
4810       include 'COMMON.VAR'
4811       include 'COMMON.CHAIN'
4812       include 'COMMON.IOUNITS'
4813       include 'COMMON.NAMES'
4814       include 'COMMON.FFIELD'
4815       include 'COMMON.CONTROL'
4816       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4817      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4818      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4819      & sinph1ph2(maxdouble,maxdouble)
4820       logical lprn /.false./, lprn1 /.false./
4821       etheta=0.0D0
4822       do i=ithet_start,ithet_end
4823         dethetai=0.0d0
4824         dephii=0.0d0
4825         dephii1=0.0d0
4826         theti2=0.5d0*theta(i)
4827         ityp2=ithetyp(itype(i-1))
4828         do k=1,nntheterm
4829           coskt(k)=dcos(k*theti2)
4830           sinkt(k)=dsin(k*theti2)
4831         enddo
4832         if (i.gt.3) then
4833 #ifdef OSF
4834           phii=phi(i)
4835           if (phii.ne.phii) phii=150.0
4836 #else
4837           phii=phi(i)
4838 #endif
4839           ityp1=ithetyp(itype(i-2))
4840           do k=1,nsingle
4841             cosph1(k)=dcos(k*phii)
4842             sinph1(k)=dsin(k*phii)
4843           enddo
4844         else
4845           phii=0.0d0
4846           ityp1=nthetyp+1
4847           do k=1,nsingle
4848             cosph1(k)=0.0d0
4849             sinph1(k)=0.0d0
4850           enddo
4851         endif
4852         if (i.lt.nres) then
4853 #ifdef OSF
4854           phii1=phi(i+1)
4855           if (phii1.ne.phii1) phii1=150.0
4856           phii1=pinorm(phii1)
4857 #else
4858           phii1=phi(i+1)
4859 #endif
4860           ityp3=ithetyp(itype(i))
4861           do k=1,nsingle
4862             cosph2(k)=dcos(k*phii1)
4863             sinph2(k)=dsin(k*phii1)
4864           enddo
4865         else
4866           phii1=0.0d0
4867           ityp3=nthetyp+1
4868           do k=1,nsingle
4869             cosph2(k)=0.0d0
4870             sinph2(k)=0.0d0
4871           enddo
4872         endif
4873         ethetai=aa0thet(ityp1,ityp2,ityp3)
4874         do k=1,ndouble
4875           do l=1,k-1
4876             ccl=cosph1(l)*cosph2(k-l)
4877             ssl=sinph1(l)*sinph2(k-l)
4878             scl=sinph1(l)*cosph2(k-l)
4879             csl=cosph1(l)*sinph2(k-l)
4880             cosph1ph2(l,k)=ccl-ssl
4881             cosph1ph2(k,l)=ccl+ssl
4882             sinph1ph2(l,k)=scl+csl
4883             sinph1ph2(k,l)=scl-csl
4884           enddo
4885         enddo
4886         if (lprn) then
4887         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4888      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4889         write (iout,*) "coskt and sinkt"
4890         do k=1,nntheterm
4891           write (iout,*) k,coskt(k),sinkt(k)
4892         enddo
4893         endif
4894         do k=1,ntheterm
4895           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4896           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4897      &      *coskt(k)
4898           if (lprn)
4899      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4900      &     " ethetai",ethetai
4901         enddo
4902         if (lprn) then
4903         write (iout,*) "cosph and sinph"
4904         do k=1,nsingle
4905           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4906         enddo
4907         write (iout,*) "cosph1ph2 and sinph2ph2"
4908         do k=2,ndouble
4909           do l=1,k-1
4910             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4911      &         sinph1ph2(l,k),sinph1ph2(k,l)
4912           enddo
4913         enddo
4914         write(iout,*) "ethetai",ethetai
4915         endif
4916         do m=1,ntheterm2
4917           do k=1,nsingle
4918             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4919      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4920      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4921      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4922             ethetai=ethetai+sinkt(m)*aux
4923             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4924             dephii=dephii+k*sinkt(m)*(
4925      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4926      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4927             dephii1=dephii1+k*sinkt(m)*(
4928      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4929      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4930             if (lprn)
4931      &      write (iout,*) "m",m," k",k," bbthet",
4932      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4933      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4934      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4935      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4936           enddo
4937         enddo
4938         if (lprn)
4939      &  write(iout,*) "ethetai",ethetai
4940         do m=1,ntheterm3
4941           do k=2,ndouble
4942             do l=1,k-1
4943               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4944      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4945      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4946      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4947               ethetai=ethetai+sinkt(m)*aux
4948               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4949               dephii=dephii+l*sinkt(m)*(
4950      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4951      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4952      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4953      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4954               dephii1=dephii1+(k-l)*sinkt(m)*(
4955      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4956      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4957      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4958      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4959               if (lprn) then
4960               write (iout,*) "m",m," k",k," l",l," ffthet",
4961      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4962      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4963      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4964      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4965               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4966      &            cosph1ph2(k,l)*sinkt(m),
4967      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4968               endif
4969             enddo
4970           enddo
4971         enddo
4972 10      continue
4973         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4974      &   i,theta(i)*rad2deg,phii*rad2deg,
4975      &   phii1*rad2deg,ethetai
4976         etheta=etheta+ethetai
4977         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4978         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4979         gloc(nphi+i-2,icg)=wang*dethetai
4980       enddo
4981       return
4982       end
4983 #endif
4984 #ifdef CRYST_SC
4985 c-----------------------------------------------------------------------------
4986       subroutine esc(escloc)
4987 C Calculate the local energy of a side chain and its derivatives in the
4988 C corresponding virtual-bond valence angles THETA and the spherical angles
4989 C ALPHA and OMEGA.
4990       implicit real*8 (a-h,o-z)
4991       include 'DIMENSIONS'
4992       include 'COMMON.GEO'
4993       include 'COMMON.LOCAL'
4994       include 'COMMON.VAR'
4995       include 'COMMON.INTERACT'
4996       include 'COMMON.DERIV'
4997       include 'COMMON.CHAIN'
4998       include 'COMMON.IOUNITS'
4999       include 'COMMON.NAMES'
5000       include 'COMMON.FFIELD'
5001       include 'COMMON.CONTROL'
5002       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5003      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5004       common /sccalc/ time11,time12,time112,theti,it,nlobit
5005       delta=0.02d0*pi
5006       escloc=0.0D0
5007 c     write (iout,'(a)') 'ESC'
5008       do i=loc_start,loc_end
5009         it=itype(i)
5010         if (it.eq.10) goto 1
5011         nlobit=nlob(it)
5012 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5013 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5014         theti=theta(i+1)-pipol
5015         x(1)=dtan(theti)
5016         x(2)=alph(i)
5017         x(3)=omeg(i)
5018
5019         if (x(2).gt.pi-delta) then
5020           xtemp(1)=x(1)
5021           xtemp(2)=pi-delta
5022           xtemp(3)=x(3)
5023           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5024           xtemp(2)=pi
5025           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5026           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5027      &        escloci,dersc(2))
5028           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5029      &        ddersc0(1),dersc(1))
5030           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5031      &        ddersc0(3),dersc(3))
5032           xtemp(2)=pi-delta
5033           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5034           xtemp(2)=pi
5035           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5036           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5037      &            dersc0(2),esclocbi,dersc02)
5038           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5039      &            dersc12,dersc01)
5040           call splinthet(x(2),0.5d0*delta,ss,ssd)
5041           dersc0(1)=dersc01
5042           dersc0(2)=dersc02
5043           dersc0(3)=0.0d0
5044           do k=1,3
5045             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5046           enddo
5047           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5048 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5049 c    &             esclocbi,ss,ssd
5050           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5051 c         escloci=esclocbi
5052 c         write (iout,*) escloci
5053         else if (x(2).lt.delta) then
5054           xtemp(1)=x(1)
5055           xtemp(2)=delta
5056           xtemp(3)=x(3)
5057           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5058           xtemp(2)=0.0d0
5059           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5060           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5061      &        escloci,dersc(2))
5062           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5063      &        ddersc0(1),dersc(1))
5064           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5065      &        ddersc0(3),dersc(3))
5066           xtemp(2)=delta
5067           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5068           xtemp(2)=0.0d0
5069           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5070           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5071      &            dersc0(2),esclocbi,dersc02)
5072           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5073      &            dersc12,dersc01)
5074           dersc0(1)=dersc01
5075           dersc0(2)=dersc02
5076           dersc0(3)=0.0d0
5077           call splinthet(x(2),0.5d0*delta,ss,ssd)
5078           do k=1,3
5079             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5080           enddo
5081           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5082 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5083 c    &             esclocbi,ss,ssd
5084           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5085 c         write (iout,*) escloci
5086         else
5087           call enesc(x,escloci,dersc,ddummy,.false.)
5088         endif
5089
5090         escloc=escloc+escloci
5091         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5092      &     'escloc',i,escloci
5093 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5094
5095         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5096      &   wscloc*dersc(1)
5097         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5098         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5099     1   continue
5100       enddo
5101       return
5102       end
5103 C---------------------------------------------------------------------------
5104       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5105       implicit real*8 (a-h,o-z)
5106       include 'DIMENSIONS'
5107       include 'COMMON.GEO'
5108       include 'COMMON.LOCAL'
5109       include 'COMMON.IOUNITS'
5110       common /sccalc/ time11,time12,time112,theti,it,nlobit
5111       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5112       double precision contr(maxlob,-1:1)
5113       logical mixed
5114 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5115         escloc_i=0.0D0
5116         do j=1,3
5117           dersc(j)=0.0D0
5118           if (mixed) ddersc(j)=0.0d0
5119         enddo
5120         x3=x(3)
5121
5122 C Because of periodicity of the dependence of the SC energy in omega we have
5123 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5124 C To avoid underflows, first compute & store the exponents.
5125
5126         do iii=-1,1
5127
5128           x(3)=x3+iii*dwapi
5129
5130           do j=1,nlobit
5131             do k=1,3
5132               z(k)=x(k)-censc(k,j,it)
5133             enddo
5134             do k=1,3
5135               Axk=0.0D0
5136               do l=1,3
5137                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5138               enddo
5139               Ax(k,j,iii)=Axk
5140             enddo
5141             expfac=0.0D0
5142             do k=1,3
5143               expfac=expfac+Ax(k,j,iii)*z(k)
5144             enddo
5145             contr(j,iii)=expfac
5146           enddo ! j
5147
5148         enddo ! iii
5149
5150         x(3)=x3
5151 C As in the case of ebend, we want to avoid underflows in exponentiation and
5152 C subsequent NaNs and INFs in energy calculation.
5153 C Find the largest exponent
5154         emin=contr(1,-1)
5155         do iii=-1,1
5156           do j=1,nlobit
5157             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5158           enddo
5159         enddo
5160         emin=0.5D0*emin
5161 cd      print *,'it=',it,' emin=',emin
5162
5163 C Compute the contribution to SC energy and derivatives
5164         do iii=-1,1
5165
5166           do j=1,nlobit
5167 #ifdef OSF
5168             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5169             if(adexp.ne.adexp) adexp=1.0
5170             expfac=dexp(adexp)
5171 #else
5172             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5173 #endif
5174 cd          print *,'j=',j,' expfac=',expfac
5175             escloc_i=escloc_i+expfac
5176             do k=1,3
5177               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5178             enddo
5179             if (mixed) then
5180               do k=1,3,2
5181                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5182      &            +gaussc(k,2,j,it))*expfac
5183               enddo
5184             endif
5185           enddo
5186
5187         enddo ! iii
5188
5189         dersc(1)=dersc(1)/cos(theti)**2
5190         ddersc(1)=ddersc(1)/cos(theti)**2
5191         ddersc(3)=ddersc(3)
5192
5193         escloci=-(dlog(escloc_i)-emin)
5194         do j=1,3
5195           dersc(j)=dersc(j)/escloc_i
5196         enddo
5197         if (mixed) then
5198           do j=1,3,2
5199             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5200           enddo
5201         endif
5202       return
5203       end
5204 C------------------------------------------------------------------------------
5205       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5206       implicit real*8 (a-h,o-z)
5207       include 'DIMENSIONS'
5208       include 'COMMON.GEO'
5209       include 'COMMON.LOCAL'
5210       include 'COMMON.IOUNITS'
5211       common /sccalc/ time11,time12,time112,theti,it,nlobit
5212       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5213       double precision contr(maxlob)
5214       logical mixed
5215
5216       escloc_i=0.0D0
5217
5218       do j=1,3
5219         dersc(j)=0.0D0
5220       enddo
5221
5222       do j=1,nlobit
5223         do k=1,2
5224           z(k)=x(k)-censc(k,j,it)
5225         enddo
5226         z(3)=dwapi
5227         do k=1,3
5228           Axk=0.0D0
5229           do l=1,3
5230             Axk=Axk+gaussc(l,k,j,it)*z(l)
5231           enddo
5232           Ax(k,j)=Axk
5233         enddo
5234         expfac=0.0D0
5235         do k=1,3
5236           expfac=expfac+Ax(k,j)*z(k)
5237         enddo
5238         contr(j)=expfac
5239       enddo ! j
5240
5241 C As in the case of ebend, we want to avoid underflows in exponentiation and
5242 C subsequent NaNs and INFs in energy calculation.
5243 C Find the largest exponent
5244       emin=contr(1)
5245       do j=1,nlobit
5246         if (emin.gt.contr(j)) emin=contr(j)
5247       enddo
5248       emin=0.5D0*emin
5249
5250 C Compute the contribution to SC energy and derivatives
5251
5252       dersc12=0.0d0
5253       do j=1,nlobit
5254         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5255         escloc_i=escloc_i+expfac
5256         do k=1,2
5257           dersc(k)=dersc(k)+Ax(k,j)*expfac
5258         enddo
5259         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5260      &            +gaussc(1,2,j,it))*expfac
5261         dersc(3)=0.0d0
5262       enddo
5263
5264       dersc(1)=dersc(1)/cos(theti)**2
5265       dersc12=dersc12/cos(theti)**2
5266       escloci=-(dlog(escloc_i)-emin)
5267       do j=1,2
5268         dersc(j)=dersc(j)/escloc_i
5269       enddo
5270       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5271       return
5272       end
5273 #else
5274 c----------------------------------------------------------------------------------
5275       subroutine esc(escloc)
5276 C Calculate the local energy of a side chain and its derivatives in the
5277 C corresponding virtual-bond valence angles THETA and the spherical angles
5278 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5279 C added by Urszula Kozlowska. 07/11/2007
5280 C
5281       implicit real*8 (a-h,o-z)
5282       include 'DIMENSIONS'
5283       include 'COMMON.GEO'
5284       include 'COMMON.LOCAL'
5285       include 'COMMON.VAR'
5286       include 'COMMON.SCROT'
5287       include 'COMMON.INTERACT'
5288       include 'COMMON.DERIV'
5289       include 'COMMON.CHAIN'
5290       include 'COMMON.IOUNITS'
5291       include 'COMMON.NAMES'
5292       include 'COMMON.FFIELD'
5293       include 'COMMON.CONTROL'
5294       include 'COMMON.VECTORS'
5295       double precision x_prime(3),y_prime(3),z_prime(3)
5296      &    , sumene,dsc_i,dp2_i,x(65),
5297      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5298      &    de_dxx,de_dyy,de_dzz,de_dt
5299       double precision s1_t,s1_6_t,s2_t,s2_6_t
5300       double precision
5301      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5302      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5303      & dt_dCi(3),dt_dCi1(3)
5304       common /sccalc/ time11,time12,time112,theti,it,nlobit
5305       delta=0.02d0*pi
5306       escloc=0.0D0
5307       do i=loc_start,loc_end
5308         costtab(i+1) =dcos(theta(i+1))
5309         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5310         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5311         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5312         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5313         cosfac=dsqrt(cosfac2)
5314         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5315         sinfac=dsqrt(sinfac2)
5316         it=itype(i)
5317         if (it.eq.10) goto 1
5318 c
5319 C  Compute the axes of tghe local cartesian coordinates system; store in
5320 c   x_prime, y_prime and z_prime
5321 c
5322         do j=1,3
5323           x_prime(j) = 0.00
5324           y_prime(j) = 0.00
5325           z_prime(j) = 0.00
5326         enddo
5327 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5328 C     &   dc_norm(3,i+nres)
5329         do j = 1,3
5330           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5331           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5332         enddo
5333         do j = 1,3
5334           z_prime(j) = -uz(j,i-1)
5335         enddo
5336 c       write (2,*) "i",i
5337 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5338 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5339 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5340 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5341 c      & " xy",scalar(x_prime(1),y_prime(1)),
5342 c      & " xz",scalar(x_prime(1),z_prime(1)),
5343 c      & " yy",scalar(y_prime(1),y_prime(1)),
5344 c      & " yz",scalar(y_prime(1),z_prime(1)),
5345 c      & " zz",scalar(z_prime(1),z_prime(1))
5346 c
5347 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5348 C to local coordinate system. Store in xx, yy, zz.
5349 c
5350         xx=0.0d0
5351         yy=0.0d0
5352         zz=0.0d0
5353         do j = 1,3
5354           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5355           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5356           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5357         enddo
5358
5359         xxtab(i)=xx
5360         yytab(i)=yy
5361         zztab(i)=zz
5362 C
5363 C Compute the energy of the ith side cbain
5364 C
5365 c        write (2,*) "xx",xx," yy",yy," zz",zz
5366         it=itype(i)
5367         do j = 1,65
5368           x(j) = sc_parmin(j,it)
5369         enddo
5370 #ifdef CHECK_COORD
5371 Cc diagnostics - remove later
5372         xx1 = dcos(alph(2))
5373         yy1 = dsin(alph(2))*dcos(omeg(2))
5374         zz1 = -dsin(alph(2))*dsin(omeg(2))
5375         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5376      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5377      &    xx1,yy1,zz1
5378 C,"  --- ", xx_w,yy_w,zz_w
5379 c end diagnostics
5380 #endif
5381         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5382      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5383      &   + x(10)*yy*zz
5384         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5385      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5386      & + x(20)*yy*zz
5387         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5388      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5389      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5390      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5391      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5392      &  +x(40)*xx*yy*zz
5393         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5394      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5395      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5396      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5397      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5398      &  +x(60)*xx*yy*zz
5399         dsc_i   = 0.743d0+x(61)
5400         dp2_i   = 1.9d0+x(62)
5401         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5402      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5403         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5404      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5405         s1=(1+x(63))/(0.1d0 + dscp1)
5406         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5407         s2=(1+x(65))/(0.1d0 + dscp2)
5408         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5409         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5410      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5411 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5412 c     &   sumene4,
5413 c     &   dscp1,dscp2,sumene
5414 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5415         escloc = escloc + sumene
5416 c        write (2,*) "i",i," escloc",sumene,escloc
5417 #ifdef DEBUG
5418 C
5419 C This section to check the numerical derivatives of the energy of ith side
5420 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5421 C #define DEBUG in the code to turn it on.
5422 C
5423         write (2,*) "sumene               =",sumene
5424         aincr=1.0d-7
5425         xxsave=xx
5426         xx=xx+aincr
5427         write (2,*) xx,yy,zz
5428         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5429         de_dxx_num=(sumenep-sumene)/aincr
5430         xx=xxsave
5431         write (2,*) "xx+ sumene from enesc=",sumenep
5432         yysave=yy
5433         yy=yy+aincr
5434         write (2,*) xx,yy,zz
5435         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5436         de_dyy_num=(sumenep-sumene)/aincr
5437         yy=yysave
5438         write (2,*) "yy+ sumene from enesc=",sumenep
5439         zzsave=zz
5440         zz=zz+aincr
5441         write (2,*) xx,yy,zz
5442         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5443         de_dzz_num=(sumenep-sumene)/aincr
5444         zz=zzsave
5445         write (2,*) "zz+ sumene from enesc=",sumenep
5446         costsave=cost2tab(i+1)
5447         sintsave=sint2tab(i+1)
5448         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5449         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5450         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5451         de_dt_num=(sumenep-sumene)/aincr
5452         write (2,*) " t+ sumene from enesc=",sumenep
5453         cost2tab(i+1)=costsave
5454         sint2tab(i+1)=sintsave
5455 C End of diagnostics section.
5456 #endif
5457 C
5458 C Compute the gradient of esc
5459 C
5460         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5461         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5462         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5463         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5464         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5465         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5466         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5467         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5468         pom1=(sumene3*sint2tab(i+1)+sumene1)
5469      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5470         pom2=(sumene4*cost2tab(i+1)+sumene2)
5471      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5472         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5473         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5474      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5475      &  +x(40)*yy*zz
5476         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5477         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5478      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5479      &  +x(60)*yy*zz
5480         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5481      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5482      &        +(pom1+pom2)*pom_dx
5483 #ifdef DEBUG
5484         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5485 #endif
5486 C
5487         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5488         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5489      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5490      &  +x(40)*xx*zz
5491         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5492         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5493      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5494      &  +x(59)*zz**2 +x(60)*xx*zz
5495         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5496      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5497      &        +(pom1-pom2)*pom_dy
5498 #ifdef DEBUG
5499         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5500 #endif
5501 C
5502         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5503      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5504      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5505      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5506      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5507      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5508      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5509      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5510 #ifdef DEBUG
5511         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5512 #endif
5513 C
5514         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5515      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5516      &  +pom1*pom_dt1+pom2*pom_dt2
5517 #ifdef DEBUG
5518         write(2,*), "de_dt = ", de_dt,de_dt_num
5519 #endif
5520 c
5521 C
5522        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5523        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5524        cosfac2xx=cosfac2*xx
5525        sinfac2yy=sinfac2*yy
5526        do k = 1,3
5527          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5528      &      vbld_inv(i+1)
5529          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5530      &      vbld_inv(i)
5531          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5532          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5533 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5534 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5535 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5536 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5537          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5538          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5539          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5540          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5541          dZZ_Ci1(k)=0.0d0
5542          dZZ_Ci(k)=0.0d0
5543          do j=1,3
5544            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5545            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5546          enddo
5547
5548          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5549          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5550          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5551 c
5552          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5553          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5554        enddo
5555
5556        do k=1,3
5557          dXX_Ctab(k,i)=dXX_Ci(k)
5558          dXX_C1tab(k,i)=dXX_Ci1(k)
5559          dYY_Ctab(k,i)=dYY_Ci(k)
5560          dYY_C1tab(k,i)=dYY_Ci1(k)
5561          dZZ_Ctab(k,i)=dZZ_Ci(k)
5562          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5563          dXX_XYZtab(k,i)=dXX_XYZ(k)
5564          dYY_XYZtab(k,i)=dYY_XYZ(k)
5565          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5566        enddo
5567
5568        do k = 1,3
5569 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5570 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5571 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5572 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5573 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5574 c     &    dt_dci(k)
5575 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5576 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5577          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5578      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5579          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5580      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5581          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5582      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5583        enddo
5584 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5585 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5586
5587 C to check gradient call subroutine check_grad
5588
5589     1 continue
5590       enddo
5591       return
5592       end
5593 c------------------------------------------------------------------------------
5594       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5595       implicit none
5596       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5597      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5598       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5599      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5600      &   + x(10)*yy*zz
5601       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5602      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5603      & + x(20)*yy*zz
5604       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5605      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5606      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5607      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5608      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5609      &  +x(40)*xx*yy*zz
5610       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5611      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5612      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5613      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5614      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5615      &  +x(60)*xx*yy*zz
5616       dsc_i   = 0.743d0+x(61)
5617       dp2_i   = 1.9d0+x(62)
5618       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5619      &          *(xx*cost2+yy*sint2))
5620       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5621      &          *(xx*cost2-yy*sint2))
5622       s1=(1+x(63))/(0.1d0 + dscp1)
5623       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5624       s2=(1+x(65))/(0.1d0 + dscp2)
5625       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5626       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5627      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5628       enesc=sumene
5629       return
5630       end
5631 #endif
5632 c------------------------------------------------------------------------------
5633       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5634 C
5635 C This procedure calculates two-body contact function g(rij) and its derivative:
5636 C
5637 C           eps0ij                                     !       x < -1
5638 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5639 C            0                                         !       x > 1
5640 C
5641 C where x=(rij-r0ij)/delta
5642 C
5643 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5644 C
5645       implicit none
5646       double precision rij,r0ij,eps0ij,fcont,fprimcont
5647       double precision x,x2,x4,delta
5648 c     delta=0.02D0*r0ij
5649 c      delta=0.2D0*r0ij
5650       x=(rij-r0ij)/delta
5651       if (x.lt.-1.0D0) then
5652         fcont=eps0ij
5653         fprimcont=0.0D0
5654       else if (x.le.1.0D0) then
5655         x2=x*x
5656         x4=x2*x2
5657         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5658         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5659       else
5660         fcont=0.0D0
5661         fprimcont=0.0D0
5662       endif
5663       return
5664       end
5665 c------------------------------------------------------------------------------
5666       subroutine splinthet(theti,delta,ss,ssder)
5667       implicit real*8 (a-h,o-z)
5668       include 'DIMENSIONS'
5669       include 'COMMON.VAR'
5670       include 'COMMON.GEO'
5671       thetup=pi-delta
5672       thetlow=delta
5673       if (theti.gt.pipol) then
5674         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5675       else
5676         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5677         ssder=-ssder
5678       endif
5679       return
5680       end
5681 c------------------------------------------------------------------------------
5682       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5683       implicit none
5684       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5685       double precision ksi,ksi2,ksi3,a1,a2,a3
5686       a1=fprim0*delta/(f1-f0)
5687       a2=3.0d0-2.0d0*a1
5688       a3=a1-2.0d0
5689       ksi=(x-x0)/delta
5690       ksi2=ksi*ksi
5691       ksi3=ksi2*ksi
5692       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5693       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5694       return
5695       end
5696 c------------------------------------------------------------------------------
5697       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5698       implicit none
5699       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5700       double precision ksi,ksi2,ksi3,a1,a2,a3
5701       ksi=(x-x0)/delta
5702       ksi2=ksi*ksi
5703       ksi3=ksi2*ksi
5704       a1=fprim0x*delta
5705       a2=3*(f1x-f0x)-2*fprim0x*delta
5706       a3=fprim0x*delta-2*(f1x-f0x)
5707       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5708       return
5709       end
5710 C-----------------------------------------------------------------------------
5711 #ifdef CRYST_TOR
5712 C-----------------------------------------------------------------------------
5713       subroutine etor(etors,edihcnstr)
5714       implicit real*8 (a-h,o-z)
5715       include 'DIMENSIONS'
5716       include 'COMMON.VAR'
5717       include 'COMMON.GEO'
5718       include 'COMMON.LOCAL'
5719       include 'COMMON.TORSION'
5720       include 'COMMON.INTERACT'
5721       include 'COMMON.DERIV'
5722       include 'COMMON.CHAIN'
5723       include 'COMMON.NAMES'
5724       include 'COMMON.IOUNITS'
5725       include 'COMMON.FFIELD'
5726       include 'COMMON.TORCNSTR'
5727       include 'COMMON.CONTROL'
5728       logical lprn
5729 C Set lprn=.true. for debugging
5730       lprn=.false.
5731 c      lprn=.true.
5732       etors=0.0D0
5733       do i=iphi_start,iphi_end
5734       etors_ii=0.0D0
5735         itori=itortyp(itype(i-2))
5736         itori1=itortyp(itype(i-1))
5737         phii=phi(i)
5738         gloci=0.0D0
5739 C Proline-Proline pair is a special case...
5740         if (itori.eq.3 .and. itori1.eq.3) then
5741           if (phii.gt.-dwapi3) then
5742             cosphi=dcos(3*phii)
5743             fac=1.0D0/(1.0D0-cosphi)
5744             etorsi=v1(1,3,3)*fac
5745             etorsi=etorsi+etorsi
5746             etors=etors+etorsi-v1(1,3,3)
5747             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5748             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5749           endif
5750           do j=1,3
5751             v1ij=v1(j+1,itori,itori1)
5752             v2ij=v2(j+1,itori,itori1)
5753             cosphi=dcos(j*phii)
5754             sinphi=dsin(j*phii)
5755             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5756             if (energy_dec) etors_ii=etors_ii+
5757      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5758             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5759           enddo
5760         else
5761           do j=1,nterm_old
5762             v1ij=v1(j,itori,itori1)
5763             v2ij=v2(j,itori,itori1)
5764             cosphi=dcos(j*phii)
5765             sinphi=dsin(j*phii)
5766             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5767             if (energy_dec) etors_ii=etors_ii+
5768      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5769             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5770           enddo
5771         endif
5772         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5773      &        'etor',i,etors_ii
5774         if (lprn)
5775      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5776      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5777      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5778         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5779         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5780       enddo
5781 ! 6/20/98 - dihedral angle constraints
5782       edihcnstr=0.0d0
5783       do i=1,ndih_constr
5784         itori=idih_constr(i)
5785         phii=phi(itori)
5786         difi=phii-phi0(i)
5787         if (difi.gt.drange(i)) then
5788           difi=difi-drange(i)
5789           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5790           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5791         else if (difi.lt.-drange(i)) then
5792           difi=difi+drange(i)
5793           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5794           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5795         endif
5796 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5797 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5798       enddo
5799 !      write (iout,*) 'edihcnstr',edihcnstr
5800       return
5801       end
5802 c------------------------------------------------------------------------------
5803       subroutine etor_d(etors_d)
5804       etors_d=0.0d0
5805       return
5806       end
5807 c----------------------------------------------------------------------------
5808 #else
5809       subroutine etor(etors,edihcnstr)
5810       implicit real*8 (a-h,o-z)
5811       include 'DIMENSIONS'
5812       include 'COMMON.VAR'
5813       include 'COMMON.GEO'
5814       include 'COMMON.LOCAL'
5815       include 'COMMON.TORSION'
5816       include 'COMMON.INTERACT'
5817       include 'COMMON.DERIV'
5818       include 'COMMON.CHAIN'
5819       include 'COMMON.NAMES'
5820       include 'COMMON.IOUNITS'
5821       include 'COMMON.FFIELD'
5822       include 'COMMON.TORCNSTR'
5823       include 'COMMON.CONTROL'
5824       logical lprn
5825 C Set lprn=.true. for debugging
5826       lprn=.false.
5827 c     lprn=.true.
5828       etors=0.0D0
5829       do i=iphi_start,iphi_end
5830       etors_ii=0.0D0
5831         itori=itortyp(itype(i-2))
5832         itori1=itortyp(itype(i-1))
5833         phii=phi(i)
5834         gloci=0.0D0
5835 C Regular cosine and sine terms
5836         do j=1,nterm(itori,itori1)
5837           v1ij=v1(j,itori,itori1)
5838           v2ij=v2(j,itori,itori1)
5839           cosphi=dcos(j*phii)
5840           sinphi=dsin(j*phii)
5841           etors=etors+v1ij*cosphi+v2ij*sinphi
5842           if (energy_dec) etors_ii=etors_ii+
5843      &                v1ij*cosphi+v2ij*sinphi
5844           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5845         enddo
5846 C Lorentz terms
5847 C                         v1
5848 C  E = SUM ----------------------------------- - v1
5849 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5850 C
5851         cosphi=dcos(0.5d0*phii)
5852         sinphi=dsin(0.5d0*phii)
5853         do j=1,nlor(itori,itori1)
5854           vl1ij=vlor1(j,itori,itori1)
5855           vl2ij=vlor2(j,itori,itori1)
5856           vl3ij=vlor3(j,itori,itori1)
5857           pom=vl2ij*cosphi+vl3ij*sinphi
5858           pom1=1.0d0/(pom*pom+1.0d0)
5859           etors=etors+vl1ij*pom1
5860           if (energy_dec) etors_ii=etors_ii+
5861      &                vl1ij*pom1
5862           pom=-pom*pom1*pom1
5863           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5864         enddo
5865 C Subtract the constant term
5866         etors=etors-v0(itori,itori1)
5867           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5868      &         'etor',i,etors_ii-v0(itori,itori1)
5869         if (lprn)
5870      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5871      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5872      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5873         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5874 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5875       enddo
5876 ! 6/20/98 - dihedral angle constraints
5877       edihcnstr=0.0d0
5878 c      do i=1,ndih_constr
5879       do i=idihconstr_start,idihconstr_end
5880         itori=idih_constr(i)
5881         phii=phi(itori)
5882         difi=pinorm(phii-phi0(i))
5883         if (difi.gt.drange(i)) then
5884           difi=difi-drange(i)
5885           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5886           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5887         else if (difi.lt.-drange(i)) then
5888           difi=difi+drange(i)
5889           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5890           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5891         else
5892           difi=0.0
5893         endif
5894 c        write (iout,*) "gloci", gloc(i-3,icg)
5895 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5896 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5897 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5898       enddo
5899 cd       write (iout,*) 'edihcnstr',edihcnstr
5900       return
5901       end
5902 c----------------------------------------------------------------------------
5903       subroutine etor_d(etors_d)
5904 C 6/23/01 Compute double torsional energy
5905       implicit real*8 (a-h,o-z)
5906       include 'DIMENSIONS'
5907       include 'COMMON.VAR'
5908       include 'COMMON.GEO'
5909       include 'COMMON.LOCAL'
5910       include 'COMMON.TORSION'
5911       include 'COMMON.INTERACT'
5912       include 'COMMON.DERIV'
5913       include 'COMMON.CHAIN'
5914       include 'COMMON.NAMES'
5915       include 'COMMON.IOUNITS'
5916       include 'COMMON.FFIELD'
5917       include 'COMMON.TORCNSTR'
5918       logical lprn
5919 C Set lprn=.true. for debugging
5920       lprn=.false.
5921 c     lprn=.true.
5922       etors_d=0.0D0
5923       do i=iphid_start,iphid_end
5924         itori=itortyp(itype(i-2))
5925         itori1=itortyp(itype(i-1))
5926         itori2=itortyp(itype(i))
5927         phii=phi(i)
5928         phii1=phi(i+1)
5929         gloci1=0.0D0
5930         gloci2=0.0D0
5931         do j=1,ntermd_1(itori,itori1,itori2)
5932           v1cij=v1c(1,j,itori,itori1,itori2)
5933           v1sij=v1s(1,j,itori,itori1,itori2)
5934           v2cij=v1c(2,j,itori,itori1,itori2)
5935           v2sij=v1s(2,j,itori,itori1,itori2)
5936           cosphi1=dcos(j*phii)
5937           sinphi1=dsin(j*phii)
5938           cosphi2=dcos(j*phii1)
5939           sinphi2=dsin(j*phii1)
5940           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5941      &     v2cij*cosphi2+v2sij*sinphi2
5942           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5943           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5944         enddo
5945         do k=2,ntermd_2(itori,itori1,itori2)
5946           do l=1,k-1
5947             v1cdij = v2c(k,l,itori,itori1,itori2)
5948             v2cdij = v2c(l,k,itori,itori1,itori2)
5949             v1sdij = v2s(k,l,itori,itori1,itori2)
5950             v2sdij = v2s(l,k,itori,itori1,itori2)
5951             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5952             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5953             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5954             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5955             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5956      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5957             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5958      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5959             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5960      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5961           enddo
5962         enddo
5963         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5964         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5965 c        write (iout,*) "gloci", gloc(i-3,icg)
5966       enddo
5967       return
5968       end
5969 #endif
5970 c------------------------------------------------------------------------------
5971       subroutine eback_sc_corr(esccor)
5972 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5973 c        conformational states; temporarily implemented as differences
5974 c        between UNRES torsional potentials (dependent on three types of
5975 c        residues) and the torsional potentials dependent on all 20 types
5976 c        of residues computed from AM1  energy surfaces of terminally-blocked
5977 c        amino-acid residues.
5978       implicit real*8 (a-h,o-z)
5979       include 'DIMENSIONS'
5980       include 'COMMON.VAR'
5981       include 'COMMON.GEO'
5982       include 'COMMON.LOCAL'
5983       include 'COMMON.TORSION'
5984       include 'COMMON.SCCOR'
5985       include 'COMMON.INTERACT'
5986       include 'COMMON.DERIV'
5987       include 'COMMON.CHAIN'
5988       include 'COMMON.NAMES'
5989       include 'COMMON.IOUNITS'
5990       include 'COMMON.FFIELD'
5991       include 'COMMON.CONTROL'
5992       logical lprn
5993 C Set lprn=.true. for debugging
5994       lprn=.false.
5995 c      lprn=.true.
5996 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5997       esccor=0.0D0
5998       do i=itau_start,itau_end
5999         esccor_ii=0.0D0
6000         isccori=isccortyp(itype(i-2))
6001         isccori1=isccortyp(itype(i-1))
6002         phii=phi(i)
6003 cccc  Added 9 May 2012
6004 cc Tauangle is torsional engle depending on the value of first digit
6005 c(see comment below)
6006 cc Omicron is flat angle depending on the value of first digit
6007 c(see comment below)
6008
6009
6010         do intertyp=1,3 !intertyp
6011 cc Added 09 May 2012 (Adasko)
6012 cc  Intertyp means interaction type of backbone mainchain correlation:
6013 c   1 = SC...Ca...Ca...Ca
6014 c   2 = Ca...Ca...Ca...SC
6015 c   3 = SC...Ca...Ca...SCi
6016         gloci=0.0D0
6017         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6018      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6019      &      (itype(i-1).eq.21)))
6020      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6021      &     .or.(itype(i-2).eq.21)))
6022      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6023      &      (itype(i-1).eq.21)))) cycle
6024         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6025         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6026      & cycle
6027         do j=1,nterm_sccor(isccori,isccori1)
6028           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6029           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6030           cosphi=dcos(j*tauangle(intertyp,i))
6031           sinphi=dsin(j*tauangle(intertyp,i))
6032           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6033           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6034         enddo
6035         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6036 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6037 c     &gloc_sc(intertyp,i-3,icg)
6038         if (lprn)
6039      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6040      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6041      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6042      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6043         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6044        enddo !intertyp
6045       enddo
6046 c        do i=1,nres
6047 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6048 c        enddo
6049       return
6050       end
6051 c----------------------------------------------------------------------------
6052       subroutine multibody(ecorr)
6053 C This subroutine calculates multi-body contributions to energy following
6054 C the idea of Skolnick et al. If side chains I and J make a contact and
6055 C at the same time side chains I+1 and J+1 make a contact, an extra
6056 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6057       implicit real*8 (a-h,o-z)
6058       include 'DIMENSIONS'
6059       include 'COMMON.IOUNITS'
6060       include 'COMMON.DERIV'
6061       include 'COMMON.INTERACT'
6062       include 'COMMON.CONTACTS'
6063       double precision gx(3),gx1(3)
6064       logical lprn
6065
6066 C Set lprn=.true. for debugging
6067       lprn=.false.
6068
6069       if (lprn) then
6070         write (iout,'(a)') 'Contact function values:'
6071         do i=nnt,nct-2
6072           write (iout,'(i2,20(1x,i2,f10.5))')
6073      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6074         enddo
6075       endif
6076       ecorr=0.0D0
6077       do i=nnt,nct
6078         do j=1,3
6079           gradcorr(j,i)=0.0D0
6080           gradxorr(j,i)=0.0D0
6081         enddo
6082       enddo
6083       do i=nnt,nct-2
6084
6085         DO ISHIFT = 3,4
6086
6087         i1=i+ishift
6088         num_conti=num_cont(i)
6089         num_conti1=num_cont(i1)
6090         do jj=1,num_conti
6091           j=jcont(jj,i)
6092           do kk=1,num_conti1
6093             j1=jcont(kk,i1)
6094             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6095 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6096 cd   &                   ' ishift=',ishift
6097 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6098 C The system gains extra energy.
6099               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6100             endif   ! j1==j+-ishift
6101           enddo     ! kk
6102         enddo       ! jj
6103
6104         ENDDO ! ISHIFT
6105
6106       enddo         ! i
6107       return
6108       end
6109 c------------------------------------------------------------------------------
6110       double precision function esccorr(i,j,k,l,jj,kk)
6111       implicit real*8 (a-h,o-z)
6112       include 'DIMENSIONS'
6113       include 'COMMON.IOUNITS'
6114       include 'COMMON.DERIV'
6115       include 'COMMON.INTERACT'
6116       include 'COMMON.CONTACTS'
6117       double precision gx(3),gx1(3)
6118       logical lprn
6119       lprn=.false.
6120       eij=facont(jj,i)
6121       ekl=facont(kk,k)
6122 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6123 C Calculate the multi-body contribution to energy.
6124 C Calculate multi-body contributions to the gradient.
6125 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6126 cd   & k,l,(gacont(m,kk,k),m=1,3)
6127       do m=1,3
6128         gx(m) =ekl*gacont(m,jj,i)
6129         gx1(m)=eij*gacont(m,kk,k)
6130         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6131         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6132         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6133         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6134       enddo
6135       do m=i,j-1
6136         do ll=1,3
6137           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6138         enddo
6139       enddo
6140       do m=k,l-1
6141         do ll=1,3
6142           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6143         enddo
6144       enddo
6145       esccorr=-eij*ekl
6146       return
6147       end
6148 c------------------------------------------------------------------------------
6149       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6150 C This subroutine calculates multi-body contributions to hydrogen-bonding
6151       implicit real*8 (a-h,o-z)
6152       include 'DIMENSIONS'
6153       include 'COMMON.IOUNITS'
6154 #ifdef MPI
6155       include "mpif.h"
6156       parameter (max_cont=maxconts)
6157       parameter (max_dim=26)
6158       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6159       double precision zapas(max_dim,maxconts,max_fg_procs),
6160      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6161       common /przechowalnia/ zapas
6162       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6163      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6164 #endif
6165       include 'COMMON.SETUP'
6166       include 'COMMON.FFIELD'
6167       include 'COMMON.DERIV'
6168       include 'COMMON.INTERACT'
6169       include 'COMMON.CONTACTS'
6170       include 'COMMON.CONTROL'
6171       include 'COMMON.LOCAL'
6172       double precision gx(3),gx1(3),time00
6173       logical lprn,ldone
6174
6175 C Set lprn=.true. for debugging
6176       lprn=.false.
6177 #ifdef MPI
6178       n_corr=0
6179       n_corr1=0
6180       if (nfgtasks.le.1) goto 30
6181       if (lprn) then
6182         write (iout,'(a)') 'Contact function values before RECEIVE:'
6183         do i=nnt,nct-2
6184           write (iout,'(2i3,50(1x,i2,f5.2))')
6185      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6186      &    j=1,num_cont_hb(i))
6187         enddo
6188       endif
6189       call flush(iout)
6190       do i=1,ntask_cont_from
6191         ncont_recv(i)=0
6192       enddo
6193       do i=1,ntask_cont_to
6194         ncont_sent(i)=0
6195       enddo
6196 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6197 c     & ntask_cont_to
6198 C Make the list of contacts to send to send to other procesors
6199 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6200 c      call flush(iout)
6201       do i=iturn3_start,iturn3_end
6202 c        write (iout,*) "make contact list turn3",i," num_cont",
6203 c     &    num_cont_hb(i)
6204         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6205       enddo
6206       do i=iturn4_start,iturn4_end
6207 c        write (iout,*) "make contact list turn4",i," num_cont",
6208 c     &   num_cont_hb(i)
6209         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6210       enddo
6211       do ii=1,nat_sent
6212         i=iat_sent(ii)
6213 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6214 c     &    num_cont_hb(i)
6215         do j=1,num_cont_hb(i)
6216         do k=1,4
6217           jjc=jcont_hb(j,i)
6218           iproc=iint_sent_local(k,jjc,ii)
6219 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6220           if (iproc.gt.0) then
6221             ncont_sent(iproc)=ncont_sent(iproc)+1
6222             nn=ncont_sent(iproc)
6223             zapas(1,nn,iproc)=i
6224             zapas(2,nn,iproc)=jjc
6225             zapas(3,nn,iproc)=facont_hb(j,i)
6226             zapas(4,nn,iproc)=ees0p(j,i)
6227             zapas(5,nn,iproc)=ees0m(j,i)
6228             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6229             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6230             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6231             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6232             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6233             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6234             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6235             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6236             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6237             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6238             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6239             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6240             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6241             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6242             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6243             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6244             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6245             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6246             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6247             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6248             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6249           endif
6250         enddo
6251         enddo
6252       enddo
6253       if (lprn) then
6254       write (iout,*)
6255      &  "Numbers of contacts to be sent to other processors",
6256      &  (ncont_sent(i),i=1,ntask_cont_to)
6257       write (iout,*) "Contacts sent"
6258       do ii=1,ntask_cont_to
6259         nn=ncont_sent(ii)
6260         iproc=itask_cont_to(ii)
6261         write (iout,*) nn," contacts to processor",iproc,
6262      &   " of CONT_TO_COMM group"
6263         do i=1,nn
6264           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6265         enddo
6266       enddo
6267       call flush(iout)
6268       endif
6269       CorrelType=477
6270       CorrelID=fg_rank+1
6271       CorrelType1=478
6272       CorrelID1=nfgtasks+fg_rank+1
6273       ireq=0
6274 C Receive the numbers of needed contacts from other processors
6275       do ii=1,ntask_cont_from
6276         iproc=itask_cont_from(ii)
6277         ireq=ireq+1
6278         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6279      &    FG_COMM,req(ireq),IERR)
6280       enddo
6281 c      write (iout,*) "IRECV ended"
6282 c      call flush(iout)
6283 C Send the number of contacts needed by other processors
6284       do ii=1,ntask_cont_to
6285         iproc=itask_cont_to(ii)
6286         ireq=ireq+1
6287         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6288      &    FG_COMM,req(ireq),IERR)
6289       enddo
6290 c      write (iout,*) "ISEND ended"
6291 c      write (iout,*) "number of requests (nn)",ireq
6292       call flush(iout)
6293       if (ireq.gt.0)
6294      &  call MPI_Waitall(ireq,req,status_array,ierr)
6295 c      write (iout,*)
6296 c     &  "Numbers of contacts to be received from other processors",
6297 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6298 c      call flush(iout)
6299 C Receive contacts
6300       ireq=0
6301       do ii=1,ntask_cont_from
6302         iproc=itask_cont_from(ii)
6303         nn=ncont_recv(ii)
6304 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6305 c     &   " of CONT_TO_COMM group"
6306         call flush(iout)
6307         if (nn.gt.0) then
6308           ireq=ireq+1
6309           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6310      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6311 c          write (iout,*) "ireq,req",ireq,req(ireq)
6312         endif
6313       enddo
6314 C Send the contacts to processors that need them
6315       do ii=1,ntask_cont_to
6316         iproc=itask_cont_to(ii)
6317         nn=ncont_sent(ii)
6318 c        write (iout,*) nn," contacts to processor",iproc,
6319 c     &   " of CONT_TO_COMM group"
6320         if (nn.gt.0) then
6321           ireq=ireq+1
6322           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6323      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6324 c          write (iout,*) "ireq,req",ireq,req(ireq)
6325 c          do i=1,nn
6326 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6327 c          enddo
6328         endif
6329       enddo
6330 c      write (iout,*) "number of requests (contacts)",ireq
6331 c      write (iout,*) "req",(req(i),i=1,4)
6332 c      call flush(iout)
6333       if (ireq.gt.0)
6334      & call MPI_Waitall(ireq,req,status_array,ierr)
6335       do iii=1,ntask_cont_from
6336         iproc=itask_cont_from(iii)
6337         nn=ncont_recv(iii)
6338         if (lprn) then
6339         write (iout,*) "Received",nn," contacts from processor",iproc,
6340      &   " of CONT_FROM_COMM group"
6341         call flush(iout)
6342         do i=1,nn
6343           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6344         enddo
6345         call flush(iout)
6346         endif
6347         do i=1,nn
6348           ii=zapas_recv(1,i,iii)
6349 c Flag the received contacts to prevent double-counting
6350           jj=-zapas_recv(2,i,iii)
6351 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6352 c          call flush(iout)
6353           nnn=num_cont_hb(ii)+1
6354           num_cont_hb(ii)=nnn
6355           jcont_hb(nnn,ii)=jj
6356           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6357           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6358           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6359           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6360           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6361           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6362           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6363           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6364           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6365           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6366           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6367           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6368           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6369           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6370           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6371           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6372           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6373           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6374           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6375           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6376           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6377           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6378           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6379           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6380         enddo
6381       enddo
6382       call flush(iout)
6383       if (lprn) then
6384         write (iout,'(a)') 'Contact function values after receive:'
6385         do i=nnt,nct-2
6386           write (iout,'(2i3,50(1x,i3,f5.2))')
6387      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6388      &    j=1,num_cont_hb(i))
6389         enddo
6390         call flush(iout)
6391       endif
6392    30 continue
6393 #endif
6394       if (lprn) then
6395         write (iout,'(a)') 'Contact function values:'
6396         do i=nnt,nct-2
6397           write (iout,'(2i3,50(1x,i3,f5.2))')
6398      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6399      &    j=1,num_cont_hb(i))
6400         enddo
6401       endif
6402       ecorr=0.0D0
6403 C Remove the loop below after debugging !!!
6404       do i=nnt,nct
6405         do j=1,3
6406           gradcorr(j,i)=0.0D0
6407           gradxorr(j,i)=0.0D0
6408         enddo
6409       enddo
6410 C Calculate the local-electrostatic correlation terms
6411       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6412         i1=i+1
6413         num_conti=num_cont_hb(i)
6414         num_conti1=num_cont_hb(i+1)
6415         do jj=1,num_conti
6416           j=jcont_hb(jj,i)
6417           jp=iabs(j)
6418           do kk=1,num_conti1
6419             j1=jcont_hb(kk,i1)
6420             jp1=iabs(j1)
6421 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6422 c     &         ' jj=',jj,' kk=',kk
6423             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6424      &          .or. j.lt.0 .and. j1.gt.0) .and.
6425      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6426 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6427 C The system gains extra energy.
6428               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6429               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6430      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6431               n_corr=n_corr+1
6432             else if (j1.eq.j) then
6433 C Contacts I-J and I-(J+1) occur simultaneously.
6434 C The system loses extra energy.
6435 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6436             endif
6437           enddo ! kk
6438           do kk=1,num_conti
6439             j1=jcont_hb(kk,i)
6440 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6441 c    &         ' jj=',jj,' kk=',kk
6442             if (j1.eq.j+1) then
6443 C Contacts I-J and (I+1)-J occur simultaneously.
6444 C The system loses extra energy.
6445 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6446             endif ! j1==j+1
6447           enddo ! kk
6448         enddo ! jj
6449       enddo ! i
6450       return
6451       end
6452 c------------------------------------------------------------------------------
6453       subroutine add_hb_contact(ii,jj,itask)
6454       implicit real*8 (a-h,o-z)
6455       include "DIMENSIONS"
6456       include "COMMON.IOUNITS"
6457       integer max_cont
6458       integer max_dim
6459       parameter (max_cont=maxconts)
6460       parameter (max_dim=26)
6461       include "COMMON.CONTACTS"
6462       double precision zapas(max_dim,maxconts,max_fg_procs),
6463      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6464       common /przechowalnia/ zapas
6465       integer i,j,ii,jj,iproc,itask(4),nn
6466 c      write (iout,*) "itask",itask
6467       do i=1,2
6468         iproc=itask(i)
6469         if (iproc.gt.0) then
6470           do j=1,num_cont_hb(ii)
6471             jjc=jcont_hb(j,ii)
6472 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6473             if (jjc.eq.jj) then
6474               ncont_sent(iproc)=ncont_sent(iproc)+1
6475               nn=ncont_sent(iproc)
6476               zapas(1,nn,iproc)=ii
6477               zapas(2,nn,iproc)=jjc
6478               zapas(3,nn,iproc)=facont_hb(j,ii)
6479               zapas(4,nn,iproc)=ees0p(j,ii)
6480               zapas(5,nn,iproc)=ees0m(j,ii)
6481               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6482               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6483               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6484               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6485               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6486               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6487               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6488               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6489               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6490               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6491               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6492               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6493               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6494               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6495               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6496               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6497               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6498               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6499               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6500               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6501               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6502               exit
6503             endif
6504           enddo
6505         endif
6506       enddo
6507       return
6508       end
6509 c------------------------------------------------------------------------------
6510       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6511      &  n_corr1)
6512 C This subroutine calculates multi-body contributions to hydrogen-bonding
6513       implicit real*8 (a-h,o-z)
6514       include 'DIMENSIONS'
6515       include 'COMMON.IOUNITS'
6516 #ifdef MPI
6517       include "mpif.h"
6518       parameter (max_cont=maxconts)
6519       parameter (max_dim=70)
6520       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6521       double precision zapas(max_dim,maxconts,max_fg_procs),
6522      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6523       common /przechowalnia/ zapas
6524       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6525      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6526 #endif
6527       include 'COMMON.SETUP'
6528       include 'COMMON.FFIELD'
6529       include 'COMMON.DERIV'
6530       include 'COMMON.LOCAL'
6531       include 'COMMON.INTERACT'
6532       include 'COMMON.CONTACTS'
6533       include 'COMMON.CHAIN'
6534       include 'COMMON.CONTROL'
6535       double precision gx(3),gx1(3)
6536       integer num_cont_hb_old(maxres)
6537       logical lprn,ldone
6538       double precision eello4,eello5,eelo6,eello_turn6
6539       external eello4,eello5,eello6,eello_turn6
6540 C Set lprn=.true. for debugging
6541       lprn=.false.
6542       eturn6=0.0d0
6543 #ifdef MPI
6544       do i=1,nres
6545         num_cont_hb_old(i)=num_cont_hb(i)
6546       enddo
6547       n_corr=0
6548       n_corr1=0
6549       if (nfgtasks.le.1) goto 30
6550       if (lprn) then
6551         write (iout,'(a)') 'Contact function values before RECEIVE:'
6552         do i=nnt,nct-2
6553           write (iout,'(2i3,50(1x,i2,f5.2))')
6554      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6555      &    j=1,num_cont_hb(i))
6556         enddo
6557       endif
6558       call flush(iout)
6559       do i=1,ntask_cont_from
6560         ncont_recv(i)=0
6561       enddo
6562       do i=1,ntask_cont_to
6563         ncont_sent(i)=0
6564       enddo
6565 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6566 c     & ntask_cont_to
6567 C Make the list of contacts to send to send to other procesors
6568       do i=iturn3_start,iturn3_end
6569 c        write (iout,*) "make contact list turn3",i," num_cont",
6570 c     &    num_cont_hb(i)
6571         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6572       enddo
6573       do i=iturn4_start,iturn4_end
6574 c        write (iout,*) "make contact list turn4",i," num_cont",
6575 c     &   num_cont_hb(i)
6576         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6577       enddo
6578       do ii=1,nat_sent
6579         i=iat_sent(ii)
6580 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6581 c     &    num_cont_hb(i)
6582         do j=1,num_cont_hb(i)
6583         do k=1,4
6584           jjc=jcont_hb(j,i)
6585           iproc=iint_sent_local(k,jjc,ii)
6586 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6587           if (iproc.ne.0) then
6588             ncont_sent(iproc)=ncont_sent(iproc)+1
6589             nn=ncont_sent(iproc)
6590             zapas(1,nn,iproc)=i
6591             zapas(2,nn,iproc)=jjc
6592             zapas(3,nn,iproc)=d_cont(j,i)
6593             ind=3
6594             do kk=1,3
6595               ind=ind+1
6596               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6597             enddo
6598             do kk=1,2
6599               do ll=1,2
6600                 ind=ind+1
6601                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6602               enddo
6603             enddo
6604             do jj=1,5
6605               do kk=1,3
6606                 do ll=1,2
6607                   do mm=1,2
6608                     ind=ind+1
6609                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6610                   enddo
6611                 enddo
6612               enddo
6613             enddo
6614           endif
6615         enddo
6616         enddo
6617       enddo
6618       if (lprn) then
6619       write (iout,*)
6620      &  "Numbers of contacts to be sent to other processors",
6621      &  (ncont_sent(i),i=1,ntask_cont_to)
6622       write (iout,*) "Contacts sent"
6623       do ii=1,ntask_cont_to
6624         nn=ncont_sent(ii)
6625         iproc=itask_cont_to(ii)
6626         write (iout,*) nn," contacts to processor",iproc,
6627      &   " of CONT_TO_COMM group"
6628         do i=1,nn
6629           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6630         enddo
6631       enddo
6632       call flush(iout)
6633       endif
6634       CorrelType=477
6635       CorrelID=fg_rank+1
6636       CorrelType1=478
6637       CorrelID1=nfgtasks+fg_rank+1
6638       ireq=0
6639 C Receive the numbers of needed contacts from other processors
6640       do ii=1,ntask_cont_from
6641         iproc=itask_cont_from(ii)
6642         ireq=ireq+1
6643         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6644      &    FG_COMM,req(ireq),IERR)
6645       enddo
6646 c      write (iout,*) "IRECV ended"
6647 c      call flush(iout)
6648 C Send the number of contacts needed by other processors
6649       do ii=1,ntask_cont_to
6650         iproc=itask_cont_to(ii)
6651         ireq=ireq+1
6652         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6653      &    FG_COMM,req(ireq),IERR)
6654       enddo
6655 c      write (iout,*) "ISEND ended"
6656 c      write (iout,*) "number of requests (nn)",ireq
6657       call flush(iout)
6658       if (ireq.gt.0)
6659      &  call MPI_Waitall(ireq,req,status_array,ierr)
6660 c      write (iout,*)
6661 c     &  "Numbers of contacts to be received from other processors",
6662 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6663 c      call flush(iout)
6664 C Receive contacts
6665       ireq=0
6666       do ii=1,ntask_cont_from
6667         iproc=itask_cont_from(ii)
6668         nn=ncont_recv(ii)
6669 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6670 c     &   " of CONT_TO_COMM group"
6671         call flush(iout)
6672         if (nn.gt.0) then
6673           ireq=ireq+1
6674           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6675      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6676 c          write (iout,*) "ireq,req",ireq,req(ireq)
6677         endif
6678       enddo
6679 C Send the contacts to processors that need them
6680       do ii=1,ntask_cont_to
6681         iproc=itask_cont_to(ii)
6682         nn=ncont_sent(ii)
6683 c        write (iout,*) nn," contacts to processor",iproc,
6684 c     &   " of CONT_TO_COMM group"
6685         if (nn.gt.0) then
6686           ireq=ireq+1
6687           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6688      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6689 c          write (iout,*) "ireq,req",ireq,req(ireq)
6690 c          do i=1,nn
6691 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6692 c          enddo
6693         endif
6694       enddo
6695 c      write (iout,*) "number of requests (contacts)",ireq
6696 c      write (iout,*) "req",(req(i),i=1,4)
6697 c      call flush(iout)
6698       if (ireq.gt.0)
6699      & call MPI_Waitall(ireq,req,status_array,ierr)
6700       do iii=1,ntask_cont_from
6701         iproc=itask_cont_from(iii)
6702         nn=ncont_recv(iii)
6703         if (lprn) then
6704         write (iout,*) "Received",nn," contacts from processor",iproc,
6705      &   " of CONT_FROM_COMM group"
6706         call flush(iout)
6707         do i=1,nn
6708           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6709         enddo
6710         call flush(iout)
6711         endif
6712         do i=1,nn
6713           ii=zapas_recv(1,i,iii)
6714 c Flag the received contacts to prevent double-counting
6715           jj=-zapas_recv(2,i,iii)
6716 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6717 c          call flush(iout)
6718           nnn=num_cont_hb(ii)+1
6719           num_cont_hb(ii)=nnn
6720           jcont_hb(nnn,ii)=jj
6721           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6722           ind=3
6723           do kk=1,3
6724             ind=ind+1
6725             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6726           enddo
6727           do kk=1,2
6728             do ll=1,2
6729               ind=ind+1
6730               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6731             enddo
6732           enddo
6733           do jj=1,5
6734             do kk=1,3
6735               do ll=1,2
6736                 do mm=1,2
6737                   ind=ind+1
6738                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6739                 enddo
6740               enddo
6741             enddo
6742           enddo
6743         enddo
6744       enddo
6745       call flush(iout)
6746       if (lprn) then
6747         write (iout,'(a)') 'Contact function values after receive:'
6748         do i=nnt,nct-2
6749           write (iout,'(2i3,50(1x,i3,5f6.3))')
6750      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6751      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6752         enddo
6753         call flush(iout)
6754       endif
6755    30 continue
6756 #endif
6757       if (lprn) then
6758         write (iout,'(a)') 'Contact function values:'
6759         do i=nnt,nct-2
6760           write (iout,'(2i3,50(1x,i2,5f6.3))')
6761      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6762      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6763         enddo
6764       endif
6765       ecorr=0.0D0
6766       ecorr5=0.0d0
6767       ecorr6=0.0d0
6768 C Remove the loop below after debugging !!!
6769       do i=nnt,nct
6770         do j=1,3
6771           gradcorr(j,i)=0.0D0
6772           gradxorr(j,i)=0.0D0
6773         enddo
6774       enddo
6775 C Calculate the dipole-dipole interaction energies
6776       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6777       do i=iatel_s,iatel_e+1
6778         num_conti=num_cont_hb(i)
6779         do jj=1,num_conti
6780           j=jcont_hb(jj,i)
6781 #ifdef MOMENT
6782           call dipole(i,j,jj)
6783 #endif
6784         enddo
6785       enddo
6786       endif
6787 C Calculate the local-electrostatic correlation terms
6788 c                write (iout,*) "gradcorr5 in eello5 before loop"
6789 c                do iii=1,nres
6790 c                  write (iout,'(i5,3f10.5)')
6791 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6792 c                enddo
6793       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6794 c        write (iout,*) "corr loop i",i
6795         i1=i+1
6796         num_conti=num_cont_hb(i)
6797         num_conti1=num_cont_hb(i+1)
6798         do jj=1,num_conti
6799           j=jcont_hb(jj,i)
6800           jp=iabs(j)
6801           do kk=1,num_conti1
6802             j1=jcont_hb(kk,i1)
6803             jp1=iabs(j1)
6804 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6805 c     &         ' jj=',jj,' kk=',kk
6806 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6807             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6808      &          .or. j.lt.0 .and. j1.gt.0) .and.
6809      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6810 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6811 C The system gains extra energy.
6812               n_corr=n_corr+1
6813               sqd1=dsqrt(d_cont(jj,i))
6814               sqd2=dsqrt(d_cont(kk,i1))
6815               sred_geom = sqd1*sqd2
6816               IF (sred_geom.lt.cutoff_corr) THEN
6817                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6818      &            ekont,fprimcont)
6819 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6820 cd     &         ' jj=',jj,' kk=',kk
6821                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6822                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6823                 do l=1,3
6824                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6825                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6826                 enddo
6827                 n_corr1=n_corr1+1
6828 cd               write (iout,*) 'sred_geom=',sred_geom,
6829 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6830 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6831 cd               write (iout,*) "g_contij",g_contij
6832 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6833 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6834                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6835                 if (wcorr4.gt.0.0d0)
6836      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6837                   if (energy_dec.and.wcorr4.gt.0.0d0)
6838      1                 write (iout,'(a6,4i5,0pf7.3)')
6839      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6840 c                write (iout,*) "gradcorr5 before 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 (wcorr5.gt.0.0d0)
6846      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6847 c                write (iout,*) "gradcorr5 after eello5"
6848 c                do iii=1,nres
6849 c                  write (iout,'(i5,3f10.5)')
6850 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6851 c                enddo
6852                   if (energy_dec.and.wcorr5.gt.0.0d0)
6853      1                 write (iout,'(a6,4i5,0pf7.3)')
6854      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6855 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6856 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6857                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6858      &               .or. wturn6.eq.0.0d0))then
6859 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6860                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6861                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6862      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6863 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6864 cd     &            'ecorr6=',ecorr6
6865 cd                write (iout,'(4e15.5)') sred_geom,
6866 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6867 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6868 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6869                 else if (wturn6.gt.0.0d0
6870      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6871 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6872                   eturn6=eturn6+eello_turn6(i,jj,kk)
6873                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6874      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6875 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6876                 endif
6877               ENDIF
6878 1111          continue
6879             endif
6880           enddo ! kk
6881         enddo ! jj
6882       enddo ! i
6883       do i=1,nres
6884         num_cont_hb(i)=num_cont_hb_old(i)
6885       enddo
6886 c                write (iout,*) "gradcorr5 in eello5"
6887 c                do iii=1,nres
6888 c                  write (iout,'(i5,3f10.5)')
6889 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6890 c                enddo
6891       return
6892       end
6893 c------------------------------------------------------------------------------
6894       subroutine add_hb_contact_eello(ii,jj,itask)
6895       implicit real*8 (a-h,o-z)
6896       include "DIMENSIONS"
6897       include "COMMON.IOUNITS"
6898       integer max_cont
6899       integer max_dim
6900       parameter (max_cont=maxconts)
6901       parameter (max_dim=70)
6902       include "COMMON.CONTACTS"
6903       double precision zapas(max_dim,maxconts,max_fg_procs),
6904      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6905       common /przechowalnia/ zapas
6906       integer i,j,ii,jj,iproc,itask(4),nn
6907 c      write (iout,*) "itask",itask
6908       do i=1,2
6909         iproc=itask(i)
6910         if (iproc.gt.0) then
6911           do j=1,num_cont_hb(ii)
6912             jjc=jcont_hb(j,ii)
6913 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6914             if (jjc.eq.jj) then
6915               ncont_sent(iproc)=ncont_sent(iproc)+1
6916               nn=ncont_sent(iproc)
6917               zapas(1,nn,iproc)=ii
6918               zapas(2,nn,iproc)=jjc
6919               zapas(3,nn,iproc)=d_cont(j,ii)
6920               ind=3
6921               do kk=1,3
6922                 ind=ind+1
6923                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6924               enddo
6925               do kk=1,2
6926                 do ll=1,2
6927                   ind=ind+1
6928                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6929                 enddo
6930               enddo
6931               do jj=1,5
6932                 do kk=1,3
6933                   do ll=1,2
6934                     do mm=1,2
6935                       ind=ind+1
6936                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6937                     enddo
6938                   enddo
6939                 enddo
6940               enddo
6941               exit
6942             endif
6943           enddo
6944         endif
6945       enddo
6946       return
6947       end
6948 c------------------------------------------------------------------------------
6949       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6950       implicit real*8 (a-h,o-z)
6951       include 'DIMENSIONS'
6952       include 'COMMON.IOUNITS'
6953       include 'COMMON.DERIV'
6954       include 'COMMON.INTERACT'
6955       include 'COMMON.CONTACTS'
6956       double precision gx(3),gx1(3)
6957       logical lprn
6958       lprn=.false.
6959       eij=facont_hb(jj,i)
6960       ekl=facont_hb(kk,k)
6961       ees0pij=ees0p(jj,i)
6962       ees0pkl=ees0p(kk,k)
6963       ees0mij=ees0m(jj,i)
6964       ees0mkl=ees0m(kk,k)
6965       ekont=eij*ekl
6966       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6967 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6968 C Following 4 lines for diagnostics.
6969 cd    ees0pkl=0.0D0
6970 cd    ees0pij=1.0D0
6971 cd    ees0mkl=0.0D0
6972 cd    ees0mij=1.0D0
6973 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6974 c     & 'Contacts ',i,j,
6975 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6976 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6977 c     & 'gradcorr_long'
6978 C Calculate the multi-body contribution to energy.
6979 c      ecorr=ecorr+ekont*ees
6980 C Calculate multi-body contributions to the gradient.
6981       coeffpees0pij=coeffp*ees0pij
6982       coeffmees0mij=coeffm*ees0mij
6983       coeffpees0pkl=coeffp*ees0pkl
6984       coeffmees0mkl=coeffm*ees0mkl
6985       do ll=1,3
6986 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6987         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6988      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6989      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6990         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6991      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6992      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6993 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6994         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6995      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6996      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6997         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6998      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6999      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7000         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7001      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7002      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7003         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7004         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7005         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7006      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7007      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7008         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7009         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7010 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7011       enddo
7012 c      write (iout,*)
7013 cgrad      do m=i+1,j-1
7014 cgrad        do ll=1,3
7015 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7016 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7017 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7018 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7019 cgrad        enddo
7020 cgrad      enddo
7021 cgrad      do m=k+1,l-1
7022 cgrad        do ll=1,3
7023 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7024 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7025 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7026 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7027 cgrad        enddo
7028 cgrad      enddo
7029 c      write (iout,*) "ehbcorr",ekont*ees
7030       ehbcorr=ekont*ees
7031       return
7032       end
7033 #ifdef MOMENT
7034 C---------------------------------------------------------------------------
7035       subroutine dipole(i,j,jj)
7036       implicit real*8 (a-h,o-z)
7037       include 'DIMENSIONS'
7038       include 'COMMON.IOUNITS'
7039       include 'COMMON.CHAIN'
7040       include 'COMMON.FFIELD'
7041       include 'COMMON.DERIV'
7042       include 'COMMON.INTERACT'
7043       include 'COMMON.CONTACTS'
7044       include 'COMMON.TORSION'
7045       include 'COMMON.VAR'
7046       include 'COMMON.GEO'
7047       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7048      &  auxmat(2,2)
7049       iti1 = itortyp(itype(i+1))
7050       if (j.lt.nres-1) then
7051         itj1 = itortyp(itype(j+1))
7052       else
7053         itj1=ntortyp+1
7054       endif
7055       do iii=1,2
7056         dipi(iii,1)=Ub2(iii,i)
7057         dipderi(iii)=Ub2der(iii,i)
7058         dipi(iii,2)=b1(iii,iti1)
7059         dipj(iii,1)=Ub2(iii,j)
7060         dipderj(iii)=Ub2der(iii,j)
7061         dipj(iii,2)=b1(iii,itj1)
7062       enddo
7063       kkk=0
7064       do iii=1,2
7065         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7066         do jjj=1,2
7067           kkk=kkk+1
7068           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7069         enddo
7070       enddo
7071       do kkk=1,5
7072         do lll=1,3
7073           mmm=0
7074           do iii=1,2
7075             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7076      &        auxvec(1))
7077             do jjj=1,2
7078               mmm=mmm+1
7079               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7080             enddo
7081           enddo
7082         enddo
7083       enddo
7084       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7085       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7086       do iii=1,2
7087         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7088       enddo
7089       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7090       do iii=1,2
7091         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7092       enddo
7093       return
7094       end
7095 #endif
7096 C---------------------------------------------------------------------------
7097       subroutine calc_eello(i,j,k,l,jj,kk)
7098 C
7099 C This subroutine computes matrices and vectors needed to calculate
7100 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7101 C
7102       implicit real*8 (a-h,o-z)
7103       include 'DIMENSIONS'
7104       include 'COMMON.IOUNITS'
7105       include 'COMMON.CHAIN'
7106       include 'COMMON.DERIV'
7107       include 'COMMON.INTERACT'
7108       include 'COMMON.CONTACTS'
7109       include 'COMMON.TORSION'
7110       include 'COMMON.VAR'
7111       include 'COMMON.GEO'
7112       include 'COMMON.FFIELD'
7113       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7114      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7115       logical lprn
7116       common /kutas/ lprn
7117 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7118 cd     & ' jj=',jj,' kk=',kk
7119 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7120 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7121 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7122       do iii=1,2
7123         do jjj=1,2
7124           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7125           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7126         enddo
7127       enddo
7128       call transpose2(aa1(1,1),aa1t(1,1))
7129       call transpose2(aa2(1,1),aa2t(1,1))
7130       do kkk=1,5
7131         do lll=1,3
7132           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7133      &      aa1tder(1,1,lll,kkk))
7134           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7135      &      aa2tder(1,1,lll,kkk))
7136         enddo
7137       enddo
7138       if (l.eq.j+1) then
7139 C parallel orientation of the two CA-CA-CA frames.
7140         if (i.gt.1) then
7141           iti=itortyp(itype(i))
7142         else
7143           iti=ntortyp+1
7144         endif
7145         itk1=itortyp(itype(k+1))
7146         itj=itortyp(itype(j))
7147         if (l.lt.nres-1) then
7148           itl1=itortyp(itype(l+1))
7149         else
7150           itl1=ntortyp+1
7151         endif
7152 C A1 kernel(j+1) A2T
7153 cd        do iii=1,2
7154 cd          write (iout,'(3f10.5,5x,3f10.5)')
7155 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7156 cd        enddo
7157         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7158      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7159      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7160 C Following matrices are needed only for 6-th order cumulants
7161         IF (wcorr6.gt.0.0d0) THEN
7162         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7163      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7164      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7165         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7166      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7167      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7168      &   ADtEAderx(1,1,1,1,1,1))
7169         lprn=.false.
7170         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7171      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7172      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7173      &   ADtEA1derx(1,1,1,1,1,1))
7174         ENDIF
7175 C End 6-th order cumulants
7176 cd        lprn=.false.
7177 cd        if (lprn) then
7178 cd        write (2,*) 'In calc_eello6'
7179 cd        do iii=1,2
7180 cd          write (2,*) 'iii=',iii
7181 cd          do kkk=1,5
7182 cd            write (2,*) 'kkk=',kkk
7183 cd            do jjj=1,2
7184 cd              write (2,'(3(2f10.5),5x)')
7185 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7186 cd            enddo
7187 cd          enddo
7188 cd        enddo
7189 cd        endif
7190         call transpose2(EUgder(1,1,k),auxmat(1,1))
7191         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7192         call transpose2(EUg(1,1,k),auxmat(1,1))
7193         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7194         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7195         do iii=1,2
7196           do kkk=1,5
7197             do lll=1,3
7198               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7199      &          EAEAderx(1,1,lll,kkk,iii,1))
7200             enddo
7201           enddo
7202         enddo
7203 C A1T kernel(i+1) A2
7204         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7205      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7206      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7207 C Following matrices are needed only for 6-th order cumulants
7208         IF (wcorr6.gt.0.0d0) THEN
7209         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7210      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7211      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7212         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7213      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7214      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7215      &   ADtEAderx(1,1,1,1,1,2))
7216         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7217      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7218      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7219      &   ADtEA1derx(1,1,1,1,1,2))
7220         ENDIF
7221 C End 6-th order cumulants
7222         call transpose2(EUgder(1,1,l),auxmat(1,1))
7223         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7224         call transpose2(EUg(1,1,l),auxmat(1,1))
7225         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7226         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7227         do iii=1,2
7228           do kkk=1,5
7229             do lll=1,3
7230               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7231      &          EAEAderx(1,1,lll,kkk,iii,2))
7232             enddo
7233           enddo
7234         enddo
7235 C AEAb1 and AEAb2
7236 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7237 C They are needed only when the fifth- or the sixth-order cumulants are
7238 C indluded.
7239         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7240         call transpose2(AEA(1,1,1),auxmat(1,1))
7241         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7242         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7243         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7244         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7245         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7246         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7247         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7248         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7249         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7250         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7251         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7252         call transpose2(AEA(1,1,2),auxmat(1,1))
7253         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7254         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7255         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7256         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7257         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7258         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7259         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7260         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7261         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7262         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7263         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7264 C Calculate the Cartesian derivatives of the vectors.
7265         do iii=1,2
7266           do kkk=1,5
7267             do lll=1,3
7268               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7269               call matvec2(auxmat(1,1),b1(1,iti),
7270      &          AEAb1derx(1,lll,kkk,iii,1,1))
7271               call matvec2(auxmat(1,1),Ub2(1,i),
7272      &          AEAb2derx(1,lll,kkk,iii,1,1))
7273               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7274      &          AEAb1derx(1,lll,kkk,iii,2,1))
7275               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7276      &          AEAb2derx(1,lll,kkk,iii,2,1))
7277               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7278               call matvec2(auxmat(1,1),b1(1,itj),
7279      &          AEAb1derx(1,lll,kkk,iii,1,2))
7280               call matvec2(auxmat(1,1),Ub2(1,j),
7281      &          AEAb2derx(1,lll,kkk,iii,1,2))
7282               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7283      &          AEAb1derx(1,lll,kkk,iii,2,2))
7284               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7285      &          AEAb2derx(1,lll,kkk,iii,2,2))
7286             enddo
7287           enddo
7288         enddo
7289         ENDIF
7290 C End vectors
7291       else
7292 C Antiparallel orientation of the two CA-CA-CA frames.
7293         if (i.gt.1) then
7294           iti=itortyp(itype(i))
7295         else
7296           iti=ntortyp+1
7297         endif
7298         itk1=itortyp(itype(k+1))
7299         itl=itortyp(itype(l))
7300         itj=itortyp(itype(j))
7301         if (j.lt.nres-1) then
7302           itj1=itortyp(itype(j+1))
7303         else
7304           itj1=ntortyp+1
7305         endif
7306 C A2 kernel(j-1)T A1T
7307         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7308      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7309      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7310 C Following matrices are needed only for 6-th order cumulants
7311         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7312      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7313         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7314      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7315      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7316         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7317      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7318      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7319      &   ADtEAderx(1,1,1,1,1,1))
7320         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7321      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7322      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7323      &   ADtEA1derx(1,1,1,1,1,1))
7324         ENDIF
7325 C End 6-th order cumulants
7326         call transpose2(EUgder(1,1,k),auxmat(1,1))
7327         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7328         call transpose2(EUg(1,1,k),auxmat(1,1))
7329         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7330         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7331         do iii=1,2
7332           do kkk=1,5
7333             do lll=1,3
7334               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7335      &          EAEAderx(1,1,lll,kkk,iii,1))
7336             enddo
7337           enddo
7338         enddo
7339 C A2T kernel(i+1)T A1
7340         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7341      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7342      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7343 C Following matrices are needed only for 6-th order cumulants
7344         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7345      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7346         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7347      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7348      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7349         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7350      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7351      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7352      &   ADtEAderx(1,1,1,1,1,2))
7353         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7354      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7355      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7356      &   ADtEA1derx(1,1,1,1,1,2))
7357         ENDIF
7358 C End 6-th order cumulants
7359         call transpose2(EUgder(1,1,j),auxmat(1,1))
7360         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7361         call transpose2(EUg(1,1,j),auxmat(1,1))
7362         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7363         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7364         do iii=1,2
7365           do kkk=1,5
7366             do lll=1,3
7367               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7368      &          EAEAderx(1,1,lll,kkk,iii,2))
7369             enddo
7370           enddo
7371         enddo
7372 C AEAb1 and AEAb2
7373 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7374 C They are needed only when the fifth- or the sixth-order cumulants are
7375 C indluded.
7376         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7377      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7378         call transpose2(AEA(1,1,1),auxmat(1,1))
7379         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7380         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7381         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7382         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7383         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7384         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7385         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7386         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7387         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7388         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7389         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7390         call transpose2(AEA(1,1,2),auxmat(1,1))
7391         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7392         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7393         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7394         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7395         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7396         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7397         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7398         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7399         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7400         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7401         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7402 C Calculate the Cartesian derivatives of the vectors.
7403         do iii=1,2
7404           do kkk=1,5
7405             do lll=1,3
7406               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7407               call matvec2(auxmat(1,1),b1(1,iti),
7408      &          AEAb1derx(1,lll,kkk,iii,1,1))
7409               call matvec2(auxmat(1,1),Ub2(1,i),
7410      &          AEAb2derx(1,lll,kkk,iii,1,1))
7411               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7412      &          AEAb1derx(1,lll,kkk,iii,2,1))
7413               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7414      &          AEAb2derx(1,lll,kkk,iii,2,1))
7415               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7416               call matvec2(auxmat(1,1),b1(1,itl),
7417      &          AEAb1derx(1,lll,kkk,iii,1,2))
7418               call matvec2(auxmat(1,1),Ub2(1,l),
7419      &          AEAb2derx(1,lll,kkk,iii,1,2))
7420               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7421      &          AEAb1derx(1,lll,kkk,iii,2,2))
7422               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7423      &          AEAb2derx(1,lll,kkk,iii,2,2))
7424             enddo
7425           enddo
7426         enddo
7427         ENDIF
7428 C End vectors
7429       endif
7430       return
7431       end
7432 C---------------------------------------------------------------------------
7433       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7434      &  KK,KKderg,AKA,AKAderg,AKAderx)
7435       implicit none
7436       integer nderg
7437       logical transp
7438       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7439      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7440      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7441       integer iii,kkk,lll
7442       integer jjj,mmm
7443       logical lprn
7444       common /kutas/ lprn
7445       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7446       do iii=1,nderg
7447         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7448      &    AKAderg(1,1,iii))
7449       enddo
7450 cd      if (lprn) write (2,*) 'In kernel'
7451       do kkk=1,5
7452 cd        if (lprn) write (2,*) 'kkk=',kkk
7453         do lll=1,3
7454           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7455      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7456 cd          if (lprn) then
7457 cd            write (2,*) 'lll=',lll
7458 cd            write (2,*) 'iii=1'
7459 cd            do jjj=1,2
7460 cd              write (2,'(3(2f10.5),5x)')
7461 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7462 cd            enddo
7463 cd          endif
7464           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7465      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7466 cd          if (lprn) then
7467 cd            write (2,*) 'lll=',lll
7468 cd            write (2,*) 'iii=2'
7469 cd            do jjj=1,2
7470 cd              write (2,'(3(2f10.5),5x)')
7471 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7472 cd            enddo
7473 cd          endif
7474         enddo
7475       enddo
7476       return
7477       end
7478 C---------------------------------------------------------------------------
7479       double precision function eello4(i,j,k,l,jj,kk)
7480       implicit real*8 (a-h,o-z)
7481       include 'DIMENSIONS'
7482       include 'COMMON.IOUNITS'
7483       include 'COMMON.CHAIN'
7484       include 'COMMON.DERIV'
7485       include 'COMMON.INTERACT'
7486       include 'COMMON.CONTACTS'
7487       include 'COMMON.TORSION'
7488       include 'COMMON.VAR'
7489       include 'COMMON.GEO'
7490       double precision pizda(2,2),ggg1(3),ggg2(3)
7491 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7492 cd        eello4=0.0d0
7493 cd        return
7494 cd      endif
7495 cd      print *,'eello4:',i,j,k,l,jj,kk
7496 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7497 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7498 cold      eij=facont_hb(jj,i)
7499 cold      ekl=facont_hb(kk,k)
7500 cold      ekont=eij*ekl
7501       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7502 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7503       gcorr_loc(k-1)=gcorr_loc(k-1)
7504      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7505       if (l.eq.j+1) then
7506         gcorr_loc(l-1)=gcorr_loc(l-1)
7507      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7508       else
7509         gcorr_loc(j-1)=gcorr_loc(j-1)
7510      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7511       endif
7512       do iii=1,2
7513         do kkk=1,5
7514           do lll=1,3
7515             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7516      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7517 cd            derx(lll,kkk,iii)=0.0d0
7518           enddo
7519         enddo
7520       enddo
7521 cd      gcorr_loc(l-1)=0.0d0
7522 cd      gcorr_loc(j-1)=0.0d0
7523 cd      gcorr_loc(k-1)=0.0d0
7524 cd      eel4=1.0d0
7525 cd      write (iout,*)'Contacts have occurred for peptide groups',
7526 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7527 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7528       if (j.lt.nres-1) then
7529         j1=j+1
7530         j2=j-1
7531       else
7532         j1=j-1
7533         j2=j-2
7534       endif
7535       if (l.lt.nres-1) then
7536         l1=l+1
7537         l2=l-1
7538       else
7539         l1=l-1
7540         l2=l-2
7541       endif
7542       do ll=1,3
7543 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7544 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7545         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7546         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7547 cgrad        ghalf=0.5d0*ggg1(ll)
7548         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7549         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7550         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7551         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7552         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7553         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7554 cgrad        ghalf=0.5d0*ggg2(ll)
7555         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7556         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7557         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7558         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7559         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7560         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7561       enddo
7562 cgrad      do m=i+1,j-1
7563 cgrad        do ll=1,3
7564 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7565 cgrad        enddo
7566 cgrad      enddo
7567 cgrad      do m=k+1,l-1
7568 cgrad        do ll=1,3
7569 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7570 cgrad        enddo
7571 cgrad      enddo
7572 cgrad      do m=i+2,j2
7573 cgrad        do ll=1,3
7574 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7575 cgrad        enddo
7576 cgrad      enddo
7577 cgrad      do m=k+2,l2
7578 cgrad        do ll=1,3
7579 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7580 cgrad        enddo
7581 cgrad      enddo
7582 cd      do iii=1,nres-3
7583 cd        write (2,*) iii,gcorr_loc(iii)
7584 cd      enddo
7585       eello4=ekont*eel4
7586 cd      write (2,*) 'ekont',ekont
7587 cd      write (iout,*) 'eello4',ekont*eel4
7588       return
7589       end
7590 C---------------------------------------------------------------------------
7591       double precision function eello5(i,j,k,l,jj,kk)
7592       implicit real*8 (a-h,o-z)
7593       include 'DIMENSIONS'
7594       include 'COMMON.IOUNITS'
7595       include 'COMMON.CHAIN'
7596       include 'COMMON.DERIV'
7597       include 'COMMON.INTERACT'
7598       include 'COMMON.CONTACTS'
7599       include 'COMMON.TORSION'
7600       include 'COMMON.VAR'
7601       include 'COMMON.GEO'
7602       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7603       double precision ggg1(3),ggg2(3)
7604 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7605 C                                                                              C
7606 C                            Parallel chains                                   C
7607 C                                                                              C
7608 C          o             o                   o             o                   C
7609 C         /l\           / \             \   / \           / \   /              C
7610 C        /   \         /   \             \ /   \         /   \ /               C
7611 C       j| o |l1       | o |              o| o |         | o |o                C
7612 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7613 C      \i/   \         /   \ /             /   \         /   \                 C
7614 C       o    k1             o                                                  C
7615 C         (I)          (II)                (III)          (IV)                 C
7616 C                                                                              C
7617 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7618 C                                                                              C
7619 C                            Antiparallel chains                               C
7620 C                                                                              C
7621 C          o             o                   o             o                   C
7622 C         /j\           / \             \   / \           / \   /              C
7623 C        /   \         /   \             \ /   \         /   \ /               C
7624 C      j1| o |l        | o |              o| o |         | o |o                C
7625 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7626 C      \i/   \         /   \ /             /   \         /   \                 C
7627 C       o     k1            o                                                  C
7628 C         (I)          (II)                (III)          (IV)                 C
7629 C                                                                              C
7630 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7631 C                                                                              C
7632 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7633 C                                                                              C
7634 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7635 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7636 cd        eello5=0.0d0
7637 cd        return
7638 cd      endif
7639 cd      write (iout,*)
7640 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7641 cd     &   ' and',k,l
7642       itk=itortyp(itype(k))
7643       itl=itortyp(itype(l))
7644       itj=itortyp(itype(j))
7645       eello5_1=0.0d0
7646       eello5_2=0.0d0
7647       eello5_3=0.0d0
7648       eello5_4=0.0d0
7649 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7650 cd     &   eel5_3_num,eel5_4_num)
7651       do iii=1,2
7652         do kkk=1,5
7653           do lll=1,3
7654             derx(lll,kkk,iii)=0.0d0
7655           enddo
7656         enddo
7657       enddo
7658 cd      eij=facont_hb(jj,i)
7659 cd      ekl=facont_hb(kk,k)
7660 cd      ekont=eij*ekl
7661 cd      write (iout,*)'Contacts have occurred for peptide groups',
7662 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7663 cd      goto 1111
7664 C Contribution from the graph I.
7665 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7666 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7667       call transpose2(EUg(1,1,k),auxmat(1,1))
7668       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7669       vv(1)=pizda(1,1)-pizda(2,2)
7670       vv(2)=pizda(1,2)+pizda(2,1)
7671       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7672      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7673 C Explicit gradient in virtual-dihedral angles.
7674       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7675      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7676      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7677       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7678       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7679       vv(1)=pizda(1,1)-pizda(2,2)
7680       vv(2)=pizda(1,2)+pizda(2,1)
7681       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7682      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7683      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7684       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7685       vv(1)=pizda(1,1)-pizda(2,2)
7686       vv(2)=pizda(1,2)+pizda(2,1)
7687       if (l.eq.j+1) then
7688         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7689      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7690      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7691       else
7692         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7693      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7694      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7695       endif
7696 C Cartesian gradient
7697       do iii=1,2
7698         do kkk=1,5
7699           do lll=1,3
7700             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7701      &        pizda(1,1))
7702             vv(1)=pizda(1,1)-pizda(2,2)
7703             vv(2)=pizda(1,2)+pizda(2,1)
7704             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7705      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7706      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7707           enddo
7708         enddo
7709       enddo
7710 c      goto 1112
7711 c1111  continue
7712 C Contribution from graph II
7713       call transpose2(EE(1,1,itk),auxmat(1,1))
7714       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7715       vv(1)=pizda(1,1)+pizda(2,2)
7716       vv(2)=pizda(2,1)-pizda(1,2)
7717       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7718      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7719 C Explicit gradient in virtual-dihedral angles.
7720       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7721      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7722       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7723       vv(1)=pizda(1,1)+pizda(2,2)
7724       vv(2)=pizda(2,1)-pizda(1,2)
7725       if (l.eq.j+1) then
7726         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7727      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7728      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7729       else
7730         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7731      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7732      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7733       endif
7734 C Cartesian gradient
7735       do iii=1,2
7736         do kkk=1,5
7737           do lll=1,3
7738             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7739      &        pizda(1,1))
7740             vv(1)=pizda(1,1)+pizda(2,2)
7741             vv(2)=pizda(2,1)-pizda(1,2)
7742             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7743      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7744      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7745           enddo
7746         enddo
7747       enddo
7748 cd      goto 1112
7749 cd1111  continue
7750       if (l.eq.j+1) then
7751 cd        goto 1110
7752 C Parallel orientation
7753 C Contribution from graph III
7754         call transpose2(EUg(1,1,l),auxmat(1,1))
7755         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7756         vv(1)=pizda(1,1)-pizda(2,2)
7757         vv(2)=pizda(1,2)+pizda(2,1)
7758         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7759      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7760 C Explicit gradient in virtual-dihedral angles.
7761         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7762      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7763      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7764         call matmat2(AEAderg(1,1,2),auxmat(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(k-1)=g_corr5_loc(k-1)
7768      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7769      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7770         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7771         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7772         vv(1)=pizda(1,1)-pizda(2,2)
7773         vv(2)=pizda(1,2)+pizda(2,1)
7774         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7775      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7776      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7777 C Cartesian gradient
7778         do iii=1,2
7779           do kkk=1,5
7780             do lll=1,3
7781               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7782      &          pizda(1,1))
7783               vv(1)=pizda(1,1)-pizda(2,2)
7784               vv(2)=pizda(1,2)+pizda(2,1)
7785               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7786      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7787      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7788             enddo
7789           enddo
7790         enddo
7791 cd        goto 1112
7792 C Contribution from graph IV
7793 cd1110    continue
7794         call transpose2(EE(1,1,itl),auxmat(1,1))
7795         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7796         vv(1)=pizda(1,1)+pizda(2,2)
7797         vv(2)=pizda(2,1)-pizda(1,2)
7798         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7799      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7800 C Explicit gradient in virtual-dihedral angles.
7801         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7802      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7803         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7804         vv(1)=pizda(1,1)+pizda(2,2)
7805         vv(2)=pizda(2,1)-pizda(1,2)
7806         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7807      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7808      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7809 C Cartesian gradient
7810         do iii=1,2
7811           do kkk=1,5
7812             do lll=1,3
7813               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7814      &          pizda(1,1))
7815               vv(1)=pizda(1,1)+pizda(2,2)
7816               vv(2)=pizda(2,1)-pizda(1,2)
7817               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7818      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7819      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7820             enddo
7821           enddo
7822         enddo
7823       else
7824 C Antiparallel orientation
7825 C Contribution from graph III
7826 c        goto 1110
7827         call transpose2(EUg(1,1,j),auxmat(1,1))
7828         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7829         vv(1)=pizda(1,1)-pizda(2,2)
7830         vv(2)=pizda(1,2)+pizda(2,1)
7831         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7832      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7833 C Explicit gradient in virtual-dihedral angles.
7834         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7835      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7836      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7837         call matmat2(AEAderg(1,1,2),auxmat(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(k-1)=g_corr5_loc(k-1)
7841      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7842      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7843         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7844         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7845         vv(1)=pizda(1,1)-pizda(2,2)
7846         vv(2)=pizda(1,2)+pizda(2,1)
7847         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7848      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7849      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7850 C Cartesian gradient
7851         do iii=1,2
7852           do kkk=1,5
7853             do lll=1,3
7854               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7855      &          pizda(1,1))
7856               vv(1)=pizda(1,1)-pizda(2,2)
7857               vv(2)=pizda(1,2)+pizda(2,1)
7858               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7859      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7860      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7861             enddo
7862           enddo
7863         enddo
7864 cd        goto 1112
7865 C Contribution from graph IV
7866 1110    continue
7867         call transpose2(EE(1,1,itj),auxmat(1,1))
7868         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7869         vv(1)=pizda(1,1)+pizda(2,2)
7870         vv(2)=pizda(2,1)-pizda(1,2)
7871         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7872      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7873 C Explicit gradient in virtual-dihedral angles.
7874         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7875      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7876         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7877         vv(1)=pizda(1,1)+pizda(2,2)
7878         vv(2)=pizda(2,1)-pizda(1,2)
7879         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7880      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7881      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7882 C Cartesian gradient
7883         do iii=1,2
7884           do kkk=1,5
7885             do lll=1,3
7886               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7887      &          pizda(1,1))
7888               vv(1)=pizda(1,1)+pizda(2,2)
7889               vv(2)=pizda(2,1)-pizda(1,2)
7890               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7891      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7892      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7893             enddo
7894           enddo
7895         enddo
7896       endif
7897 1112  continue
7898       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7899 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7900 cd        write (2,*) 'ijkl',i,j,k,l
7901 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7902 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7903 cd      endif
7904 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7905 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7906 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7907 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7908       if (j.lt.nres-1) then
7909         j1=j+1
7910         j2=j-1
7911       else
7912         j1=j-1
7913         j2=j-2
7914       endif
7915       if (l.lt.nres-1) then
7916         l1=l+1
7917         l2=l-1
7918       else
7919         l1=l-1
7920         l2=l-2
7921       endif
7922 cd      eij=1.0d0
7923 cd      ekl=1.0d0
7924 cd      ekont=1.0d0
7925 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7926 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7927 C        summed up outside the subrouine as for the other subroutines
7928 C        handling long-range interactions. The old code is commented out
7929 C        with "cgrad" to keep track of changes.
7930       do ll=1,3
7931 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7932 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7933         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7934         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7935 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7936 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7937 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7938 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7939 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7940 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7941 c     &   gradcorr5ij,
7942 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7943 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7944 cgrad        ghalf=0.5d0*ggg1(ll)
7945 cd        ghalf=0.0d0
7946         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7947         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7948         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7949         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7950         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7951         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7952 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7953 cgrad        ghalf=0.5d0*ggg2(ll)
7954 cd        ghalf=0.0d0
7955         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7956         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7957         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7958         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7959         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7960         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7961       enddo
7962 cd      goto 1112
7963 cgrad      do m=i+1,j-1
7964 cgrad        do ll=1,3
7965 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7966 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7967 cgrad        enddo
7968 cgrad      enddo
7969 cgrad      do m=k+1,l-1
7970 cgrad        do ll=1,3
7971 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7972 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7973 cgrad        enddo
7974 cgrad      enddo
7975 c1112  continue
7976 cgrad      do m=i+2,j2
7977 cgrad        do ll=1,3
7978 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7979 cgrad        enddo
7980 cgrad      enddo
7981 cgrad      do m=k+2,l2
7982 cgrad        do ll=1,3
7983 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7984 cgrad        enddo
7985 cgrad      enddo
7986 cd      do iii=1,nres-3
7987 cd        write (2,*) iii,g_corr5_loc(iii)
7988 cd      enddo
7989       eello5=ekont*eel5
7990 cd      write (2,*) 'ekont',ekont
7991 cd      write (iout,*) 'eello5',ekont*eel5
7992       return
7993       end
7994 c--------------------------------------------------------------------------
7995       double precision function eello6(i,j,k,l,jj,kk)
7996       implicit real*8 (a-h,o-z)
7997       include 'DIMENSIONS'
7998       include 'COMMON.IOUNITS'
7999       include 'COMMON.CHAIN'
8000       include 'COMMON.DERIV'
8001       include 'COMMON.INTERACT'
8002       include 'COMMON.CONTACTS'
8003       include 'COMMON.TORSION'
8004       include 'COMMON.VAR'
8005       include 'COMMON.GEO'
8006       include 'COMMON.FFIELD'
8007       double precision ggg1(3),ggg2(3)
8008 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8009 cd        eello6=0.0d0
8010 cd        return
8011 cd      endif
8012 cd      write (iout,*)
8013 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8014 cd     &   ' and',k,l
8015       eello6_1=0.0d0
8016       eello6_2=0.0d0
8017       eello6_3=0.0d0
8018       eello6_4=0.0d0
8019       eello6_5=0.0d0
8020       eello6_6=0.0d0
8021 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8022 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8023       do iii=1,2
8024         do kkk=1,5
8025           do lll=1,3
8026             derx(lll,kkk,iii)=0.0d0
8027           enddo
8028         enddo
8029       enddo
8030 cd      eij=facont_hb(jj,i)
8031 cd      ekl=facont_hb(kk,k)
8032 cd      ekont=eij*ekl
8033 cd      eij=1.0d0
8034 cd      ekl=1.0d0
8035 cd      ekont=1.0d0
8036       if (l.eq.j+1) then
8037         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8038         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8039         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8040         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8041         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8042         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8043       else
8044         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8045         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8046         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8047         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8048         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8049           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8050         else
8051           eello6_5=0.0d0
8052         endif
8053         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8054       endif
8055 C If turn contributions are considered, they will be handled separately.
8056       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8057 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8058 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8059 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8060 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8061 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8062 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8063 cd      goto 1112
8064       if (j.lt.nres-1) then
8065         j1=j+1
8066         j2=j-1
8067       else
8068         j1=j-1
8069         j2=j-2
8070       endif
8071       if (l.lt.nres-1) then
8072         l1=l+1
8073         l2=l-1
8074       else
8075         l1=l-1
8076         l2=l-2
8077       endif
8078       do ll=1,3
8079 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8080 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8081 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8082 cgrad        ghalf=0.5d0*ggg1(ll)
8083 cd        ghalf=0.0d0
8084         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8085         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8086         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8087         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8088         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8089         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8090         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8091         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8092 cgrad        ghalf=0.5d0*ggg2(ll)
8093 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8094 cd        ghalf=0.0d0
8095         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8096         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8097         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8098         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8099         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8100         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8101       enddo
8102 cd      goto 1112
8103 cgrad      do m=i+1,j-1
8104 cgrad        do ll=1,3
8105 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8106 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8107 cgrad        enddo
8108 cgrad      enddo
8109 cgrad      do m=k+1,l-1
8110 cgrad        do ll=1,3
8111 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8112 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8113 cgrad        enddo
8114 cgrad      enddo
8115 cgrad1112  continue
8116 cgrad      do m=i+2,j2
8117 cgrad        do ll=1,3
8118 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8119 cgrad        enddo
8120 cgrad      enddo
8121 cgrad      do m=k+2,l2
8122 cgrad        do ll=1,3
8123 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8124 cgrad        enddo
8125 cgrad      enddo
8126 cd      do iii=1,nres-3
8127 cd        write (2,*) iii,g_corr6_loc(iii)
8128 cd      enddo
8129       eello6=ekont*eel6
8130 cd      write (2,*) 'ekont',ekont
8131 cd      write (iout,*) 'eello6',ekont*eel6
8132       return
8133       end
8134 c--------------------------------------------------------------------------
8135       double precision function eello6_graph1(i,j,k,l,imat,swap)
8136       implicit real*8 (a-h,o-z)
8137       include 'DIMENSIONS'
8138       include 'COMMON.IOUNITS'
8139       include 'COMMON.CHAIN'
8140       include 'COMMON.DERIV'
8141       include 'COMMON.INTERACT'
8142       include 'COMMON.CONTACTS'
8143       include 'COMMON.TORSION'
8144       include 'COMMON.VAR'
8145       include 'COMMON.GEO'
8146       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8147       logical swap
8148       logical lprn
8149       common /kutas/ lprn
8150 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8151 C
8152 C      Parallel       Antiparallel
8153 C
8154 C          o             o
8155 C         /l\           /j\
8156 C        /   \         /   \
8157 C       /| o |         | o |\
8158 C     \ j|/k\|  /   \  |/k\|l /
8159 C      \ /   \ /     \ /   \ /
8160 C       o     o       o     o
8161 C       i             i
8162 C
8163 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8164       itk=itortyp(itype(k))
8165       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8166       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8167       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8168       call transpose2(EUgC(1,1,k),auxmat(1,1))
8169       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8170       vv1(1)=pizda1(1,1)-pizda1(2,2)
8171       vv1(2)=pizda1(1,2)+pizda1(2,1)
8172       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8173       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8174       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8175       s5=scalar2(vv(1),Dtobr2(1,i))
8176 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8177       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8178       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8179      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8180      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8181      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8182      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8183      & +scalar2(vv(1),Dtobr2der(1,i)))
8184       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8185       vv1(1)=pizda1(1,1)-pizda1(2,2)
8186       vv1(2)=pizda1(1,2)+pizda1(2,1)
8187       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8188       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8189       if (l.eq.j+1) then
8190         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8191      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8192      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8193      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8194      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8195       else
8196         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8197      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8198      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8199      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8200      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8201       endif
8202       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8203       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8204       vv1(1)=pizda1(1,1)-pizda1(2,2)
8205       vv1(2)=pizda1(1,2)+pizda1(2,1)
8206       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8207      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8208      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8209      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8210       do iii=1,2
8211         if (swap) then
8212           ind=3-iii
8213         else
8214           ind=iii
8215         endif
8216         do kkk=1,5
8217           do lll=1,3
8218             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8219             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8220             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8221             call transpose2(EUgC(1,1,k),auxmat(1,1))
8222             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8223      &        pizda1(1,1))
8224             vv1(1)=pizda1(1,1)-pizda1(2,2)
8225             vv1(2)=pizda1(1,2)+pizda1(2,1)
8226             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8227             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8228      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8229             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8230      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8231             s5=scalar2(vv(1),Dtobr2(1,i))
8232             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8233           enddo
8234         enddo
8235       enddo
8236       return
8237       end
8238 c----------------------------------------------------------------------------
8239       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8240       implicit real*8 (a-h,o-z)
8241       include 'DIMENSIONS'
8242       include 'COMMON.IOUNITS'
8243       include 'COMMON.CHAIN'
8244       include 'COMMON.DERIV'
8245       include 'COMMON.INTERACT'
8246       include 'COMMON.CONTACTS'
8247       include 'COMMON.TORSION'
8248       include 'COMMON.VAR'
8249       include 'COMMON.GEO'
8250       logical swap
8251       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8252      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8253       logical lprn
8254       common /kutas/ lprn
8255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8256 C                                                                              C
8257 C      Parallel       Antiparallel                                             C
8258 C                                                                              C
8259 C          o             o                                                     C
8260 C     \   /l\           /j\   /                                                C
8261 C      \ /   \         /   \ /                                                 C
8262 C       o| o |         | o |o                                                  C
8263 C     \ j|/k\|      \  |/k\|l                                                  C
8264 C      \ /   \       \ /   \                                                   C
8265 C       o             o                                                        C
8266 C       i             i                                                        C
8267 C                                                                              C
8268 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8269 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8270 C AL 7/4/01 s1 would occur in the sixth-order moment,
8271 C           but not in a cluster cumulant
8272 #ifdef MOMENT
8273       s1=dip(1,jj,i)*dip(1,kk,k)
8274 #endif
8275       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8276       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8277       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8278       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8279       call transpose2(EUg(1,1,k),auxmat(1,1))
8280       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8281       vv(1)=pizda(1,1)-pizda(2,2)
8282       vv(2)=pizda(1,2)+pizda(2,1)
8283       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8284 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8285 #ifdef MOMENT
8286       eello6_graph2=-(s1+s2+s3+s4)
8287 #else
8288       eello6_graph2=-(s2+s3+s4)
8289 #endif
8290 c      eello6_graph2=-s3
8291 C Derivatives in gamma(i-1)
8292       if (i.gt.1) then
8293 #ifdef MOMENT
8294         s1=dipderg(1,jj,i)*dip(1,kk,k)
8295 #endif
8296         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8297         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8298         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8299         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8300 #ifdef MOMENT
8301         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8302 #else
8303         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8304 #endif
8305 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8306       endif
8307 C Derivatives in gamma(k-1)
8308 #ifdef MOMENT
8309       s1=dip(1,jj,i)*dipderg(1,kk,k)
8310 #endif
8311       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8312       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8313       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8314       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8315       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8316       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8317       vv(1)=pizda(1,1)-pizda(2,2)
8318       vv(2)=pizda(1,2)+pizda(2,1)
8319       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8320 #ifdef MOMENT
8321       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8322 #else
8323       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8324 #endif
8325 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8326 C Derivatives in gamma(j-1) or gamma(l-1)
8327       if (j.gt.1) then
8328 #ifdef MOMENT
8329         s1=dipderg(3,jj,i)*dip(1,kk,k)
8330 #endif
8331         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8332         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8333         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8334         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8335         vv(1)=pizda(1,1)-pizda(2,2)
8336         vv(2)=pizda(1,2)+pizda(2,1)
8337         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8338 #ifdef MOMENT
8339         if (swap) then
8340           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8341         else
8342           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8343         endif
8344 #endif
8345         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8346 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8347       endif
8348 C Derivatives in gamma(l-1) or gamma(j-1)
8349       if (l.gt.1) then
8350 #ifdef MOMENT
8351         s1=dip(1,jj,i)*dipderg(3,kk,k)
8352 #endif
8353         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8354         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8355         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8356         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8357         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8358         vv(1)=pizda(1,1)-pizda(2,2)
8359         vv(2)=pizda(1,2)+pizda(2,1)
8360         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8361 #ifdef MOMENT
8362         if (swap) then
8363           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8364         else
8365           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8366         endif
8367 #endif
8368         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8369 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8370       endif
8371 C Cartesian derivatives.
8372       if (lprn) then
8373         write (2,*) 'In eello6_graph2'
8374         do iii=1,2
8375           write (2,*) 'iii=',iii
8376           do kkk=1,5
8377             write (2,*) 'kkk=',kkk
8378             do jjj=1,2
8379               write (2,'(3(2f10.5),5x)')
8380      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8381             enddo
8382           enddo
8383         enddo
8384       endif
8385       do iii=1,2
8386         do kkk=1,5
8387           do lll=1,3
8388 #ifdef MOMENT
8389             if (iii.eq.1) then
8390               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8391             else
8392               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8393             endif
8394 #endif
8395             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8396      &        auxvec(1))
8397             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8398             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8399      &        auxvec(1))
8400             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8401             call transpose2(EUg(1,1,k),auxmat(1,1))
8402             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8403      &        pizda(1,1))
8404             vv(1)=pizda(1,1)-pizda(2,2)
8405             vv(2)=pizda(1,2)+pizda(2,1)
8406             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8407 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8408 #ifdef MOMENT
8409             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8410 #else
8411             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8412 #endif
8413             if (swap) then
8414               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8415             else
8416               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8417             endif
8418           enddo
8419         enddo
8420       enddo
8421       return
8422       end
8423 c----------------------------------------------------------------------------
8424       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8425       implicit real*8 (a-h,o-z)
8426       include 'DIMENSIONS'
8427       include 'COMMON.IOUNITS'
8428       include 'COMMON.CHAIN'
8429       include 'COMMON.DERIV'
8430       include 'COMMON.INTERACT'
8431       include 'COMMON.CONTACTS'
8432       include 'COMMON.TORSION'
8433       include 'COMMON.VAR'
8434       include 'COMMON.GEO'
8435       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8436       logical swap
8437 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8438 C                                                                              C
8439 C      Parallel       Antiparallel                                             C
8440 C                                                                              C
8441 C          o             o                                                     C
8442 C         /l\   /   \   /j\                                                    C
8443 C        /   \ /     \ /   \                                                   C
8444 C       /| o |o       o| o |\                                                  C
8445 C       j|/k\|  /      |/k\|l /                                                C
8446 C        /   \ /       /   \ /                                                 C
8447 C       /     o       /     o                                                  C
8448 C       i             i                                                        C
8449 C                                                                              C
8450 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8451 C
8452 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8453 C           energy moment and not to the cluster cumulant.
8454       iti=itortyp(itype(i))
8455       if (j.lt.nres-1) then
8456         itj1=itortyp(itype(j+1))
8457       else
8458         itj1=ntortyp+1
8459       endif
8460       itk=itortyp(itype(k))
8461       itk1=itortyp(itype(k+1))
8462       if (l.lt.nres-1) then
8463         itl1=itortyp(itype(l+1))
8464       else
8465         itl1=ntortyp+1
8466       endif
8467 #ifdef MOMENT
8468       s1=dip(4,jj,i)*dip(4,kk,k)
8469 #endif
8470       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8471       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8472       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8473       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8474       call transpose2(EE(1,1,itk),auxmat(1,1))
8475       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8476       vv(1)=pizda(1,1)+pizda(2,2)
8477       vv(2)=pizda(2,1)-pizda(1,2)
8478       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8479 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8480 cd     & "sum",-(s2+s3+s4)
8481 #ifdef MOMENT
8482       eello6_graph3=-(s1+s2+s3+s4)
8483 #else
8484       eello6_graph3=-(s2+s3+s4)
8485 #endif
8486 c      eello6_graph3=-s4
8487 C Derivatives in gamma(k-1)
8488       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8489       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8490       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8491       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8492 C Derivatives in gamma(l-1)
8493       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8494       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8495       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8496       vv(1)=pizda(1,1)+pizda(2,2)
8497       vv(2)=pizda(2,1)-pizda(1,2)
8498       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8499       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8500 C Cartesian derivatives.
8501       do iii=1,2
8502         do kkk=1,5
8503           do lll=1,3
8504 #ifdef MOMENT
8505             if (iii.eq.1) then
8506               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8507             else
8508               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8509             endif
8510 #endif
8511             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8512      &        auxvec(1))
8513             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8514             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8515      &        auxvec(1))
8516             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8517             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8518      &        pizda(1,1))
8519             vv(1)=pizda(1,1)+pizda(2,2)
8520             vv(2)=pizda(2,1)-pizda(1,2)
8521             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8522 #ifdef MOMENT
8523             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8524 #else
8525             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8526 #endif
8527             if (swap) then
8528               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8529             else
8530               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8531             endif
8532 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8533           enddo
8534         enddo
8535       enddo
8536       return
8537       end
8538 c----------------------------------------------------------------------------
8539       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8540       implicit real*8 (a-h,o-z)
8541       include 'DIMENSIONS'
8542       include 'COMMON.IOUNITS'
8543       include 'COMMON.CHAIN'
8544       include 'COMMON.DERIV'
8545       include 'COMMON.INTERACT'
8546       include 'COMMON.CONTACTS'
8547       include 'COMMON.TORSION'
8548       include 'COMMON.VAR'
8549       include 'COMMON.GEO'
8550       include 'COMMON.FFIELD'
8551       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8552      & auxvec1(2),auxmat1(2,2)
8553       logical swap
8554 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8555 C                                                                              C
8556 C      Parallel       Antiparallel                                             C
8557 C                                                                              C
8558 C          o             o                                                     C
8559 C         /l\   /   \   /j\                                                    C
8560 C        /   \ /     \ /   \                                                   C
8561 C       /| o |o       o| o |\                                                  C
8562 C     \ j|/k\|      \  |/k\|l                                                  C
8563 C      \ /   \       \ /   \                                                   C
8564 C       o     \       o     \                                                  C
8565 C       i             i                                                        C
8566 C                                                                              C
8567 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8568 C
8569 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8570 C           energy moment and not to the cluster cumulant.
8571 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8572       iti=itortyp(itype(i))
8573       itj=itortyp(itype(j))
8574       if (j.lt.nres-1) then
8575         itj1=itortyp(itype(j+1))
8576       else
8577         itj1=ntortyp+1
8578       endif
8579       itk=itortyp(itype(k))
8580       if (k.lt.nres-1) then
8581         itk1=itortyp(itype(k+1))
8582       else
8583         itk1=ntortyp+1
8584       endif
8585       itl=itortyp(itype(l))
8586       if (l.lt.nres-1) then
8587         itl1=itortyp(itype(l+1))
8588       else
8589         itl1=ntortyp+1
8590       endif
8591 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8592 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8593 cd     & ' itl',itl,' itl1',itl1
8594 #ifdef MOMENT
8595       if (imat.eq.1) then
8596         s1=dip(3,jj,i)*dip(3,kk,k)
8597       else
8598         s1=dip(2,jj,j)*dip(2,kk,l)
8599       endif
8600 #endif
8601       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8602       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8603       if (j.eq.l+1) then
8604         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8605         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8606       else
8607         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8608         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8609       endif
8610       call transpose2(EUg(1,1,k),auxmat(1,1))
8611       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8612       vv(1)=pizda(1,1)-pizda(2,2)
8613       vv(2)=pizda(2,1)+pizda(1,2)
8614       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8615 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8616 #ifdef MOMENT
8617       eello6_graph4=-(s1+s2+s3+s4)
8618 #else
8619       eello6_graph4=-(s2+s3+s4)
8620 #endif
8621 C Derivatives in gamma(i-1)
8622       if (i.gt.1) then
8623 #ifdef MOMENT
8624         if (imat.eq.1) then
8625           s1=dipderg(2,jj,i)*dip(3,kk,k)
8626         else
8627           s1=dipderg(4,jj,j)*dip(2,kk,l)
8628         endif
8629 #endif
8630         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8631         if (j.eq.l+1) then
8632           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8633           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8634         else
8635           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8636           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8637         endif
8638         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8639         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8640 cd          write (2,*) 'turn6 derivatives'
8641 #ifdef MOMENT
8642           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8643 #else
8644           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8645 #endif
8646         else
8647 #ifdef MOMENT
8648           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8649 #else
8650           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8651 #endif
8652         endif
8653       endif
8654 C Derivatives in gamma(k-1)
8655 #ifdef MOMENT
8656       if (imat.eq.1) then
8657         s1=dip(3,jj,i)*dipderg(2,kk,k)
8658       else
8659         s1=dip(2,jj,j)*dipderg(4,kk,l)
8660       endif
8661 #endif
8662       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8663       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8664       if (j.eq.l+1) then
8665         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8666         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8667       else
8668         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8669         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8670       endif
8671       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8672       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8673       vv(1)=pizda(1,1)-pizda(2,2)
8674       vv(2)=pizda(2,1)+pizda(1,2)
8675       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8676       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8677 #ifdef MOMENT
8678         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8679 #else
8680         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8681 #endif
8682       else
8683 #ifdef MOMENT
8684         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8685 #else
8686         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8687 #endif
8688       endif
8689 C Derivatives in gamma(j-1) or gamma(l-1)
8690       if (l.eq.j+1 .and. l.gt.1) then
8691         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8692         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8693         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8694         vv(1)=pizda(1,1)-pizda(2,2)
8695         vv(2)=pizda(2,1)+pizda(1,2)
8696         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8697         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8698       else if (j.gt.1) then
8699         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8700         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8701         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8702         vv(1)=pizda(1,1)-pizda(2,2)
8703         vv(2)=pizda(2,1)+pizda(1,2)
8704         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8705         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8706           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8707         else
8708           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8709         endif
8710       endif
8711 C Cartesian derivatives.
8712       do iii=1,2
8713         do kkk=1,5
8714           do lll=1,3
8715 #ifdef MOMENT
8716             if (iii.eq.1) then
8717               if (imat.eq.1) then
8718                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8719               else
8720                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8721               endif
8722             else
8723               if (imat.eq.1) then
8724                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8725               else
8726                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8727               endif
8728             endif
8729 #endif
8730             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8731      &        auxvec(1))
8732             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8733             if (j.eq.l+1) then
8734               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8735      &          b1(1,itj1),auxvec(1))
8736               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8737             else
8738               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8739      &          b1(1,itl1),auxvec(1))
8740               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8741             endif
8742             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8743      &        pizda(1,1))
8744             vv(1)=pizda(1,1)-pizda(2,2)
8745             vv(2)=pizda(2,1)+pizda(1,2)
8746             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8747             if (swap) then
8748               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8749 #ifdef MOMENT
8750                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8751      &             -(s1+s2+s4)
8752 #else
8753                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8754      &             -(s2+s4)
8755 #endif
8756                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8757               else
8758 #ifdef MOMENT
8759                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8760 #else
8761                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8762 #endif
8763                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8764               endif
8765             else
8766 #ifdef MOMENT
8767               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8768 #else
8769               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8770 #endif
8771               if (l.eq.j+1) then
8772                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8773               else
8774                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8775               endif
8776             endif
8777           enddo
8778         enddo
8779       enddo
8780       return
8781       end
8782 c----------------------------------------------------------------------------
8783       double precision function eello_turn6(i,jj,kk)
8784       implicit real*8 (a-h,o-z)
8785       include 'DIMENSIONS'
8786       include 'COMMON.IOUNITS'
8787       include 'COMMON.CHAIN'
8788       include 'COMMON.DERIV'
8789       include 'COMMON.INTERACT'
8790       include 'COMMON.CONTACTS'
8791       include 'COMMON.TORSION'
8792       include 'COMMON.VAR'
8793       include 'COMMON.GEO'
8794       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8795      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8796      &  ggg1(3),ggg2(3)
8797       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8798      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8799 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8800 C           the respective energy moment and not to the cluster cumulant.
8801       s1=0.0d0
8802       s8=0.0d0
8803       s13=0.0d0
8804 c
8805       eello_turn6=0.0d0
8806       j=i+4
8807       k=i+1
8808       l=i+3
8809       iti=itortyp(itype(i))
8810       itk=itortyp(itype(k))
8811       itk1=itortyp(itype(k+1))
8812       itl=itortyp(itype(l))
8813       itj=itortyp(itype(j))
8814 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8815 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8816 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8817 cd        eello6=0.0d0
8818 cd        return
8819 cd      endif
8820 cd      write (iout,*)
8821 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8822 cd     &   ' and',k,l
8823 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8824       do iii=1,2
8825         do kkk=1,5
8826           do lll=1,3
8827             derx_turn(lll,kkk,iii)=0.0d0
8828           enddo
8829         enddo
8830       enddo
8831 cd      eij=1.0d0
8832 cd      ekl=1.0d0
8833 cd      ekont=1.0d0
8834       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8835 cd      eello6_5=0.0d0
8836 cd      write (2,*) 'eello6_5',eello6_5
8837 #ifdef MOMENT
8838       call transpose2(AEA(1,1,1),auxmat(1,1))
8839       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8840       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8841       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8842 #endif
8843       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8844       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8845       s2 = scalar2(b1(1,itk),vtemp1(1))
8846 #ifdef MOMENT
8847       call transpose2(AEA(1,1,2),atemp(1,1))
8848       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8849       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8850       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8851 #endif
8852       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8853       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8854       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8855 #ifdef MOMENT
8856       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8857       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8858       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8859       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8860       ss13 = scalar2(b1(1,itk),vtemp4(1))
8861       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8862 #endif
8863 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8864 c      s1=0.0d0
8865 c      s2=0.0d0
8866 c      s8=0.0d0
8867 c      s12=0.0d0
8868 c      s13=0.0d0
8869       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8870 C Derivatives in gamma(i+2)
8871       s1d =0.0d0
8872       s8d =0.0d0
8873 #ifdef MOMENT
8874       call transpose2(AEA(1,1,1),auxmatd(1,1))
8875       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8876       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8877       call transpose2(AEAderg(1,1,2),atempd(1,1))
8878       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8879       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8880 #endif
8881       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8882       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8883       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8884 c      s1d=0.0d0
8885 c      s2d=0.0d0
8886 c      s8d=0.0d0
8887 c      s12d=0.0d0
8888 c      s13d=0.0d0
8889       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8890 C Derivatives in gamma(i+3)
8891 #ifdef MOMENT
8892       call transpose2(AEA(1,1,1),auxmatd(1,1))
8893       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8894       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8895       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8896 #endif
8897       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8898       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8899       s2d = scalar2(b1(1,itk),vtemp1d(1))
8900 #ifdef MOMENT
8901       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8902       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8903 #endif
8904       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8905 #ifdef MOMENT
8906       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8907       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8908       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8909 #endif
8910 c      s1d=0.0d0
8911 c      s2d=0.0d0
8912 c      s8d=0.0d0
8913 c      s12d=0.0d0
8914 c      s13d=0.0d0
8915 #ifdef MOMENT
8916       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8917      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8918 #else
8919       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8920      &               -0.5d0*ekont*(s2d+s12d)
8921 #endif
8922 C Derivatives in gamma(i+4)
8923       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8924       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8925       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8926 #ifdef MOMENT
8927       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8928       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8929       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8930 #endif
8931 c      s1d=0.0d0
8932 c      s2d=0.0d0
8933 c      s8d=0.0d0
8934 C      s12d=0.0d0
8935 c      s13d=0.0d0
8936 #ifdef MOMENT
8937       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8938 #else
8939       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8940 #endif
8941 C Derivatives in gamma(i+5)
8942 #ifdef MOMENT
8943       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8944       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8945       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8946 #endif
8947       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8948       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8949       s2d = scalar2(b1(1,itk),vtemp1d(1))
8950 #ifdef MOMENT
8951       call transpose2(AEA(1,1,2),atempd(1,1))
8952       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8953       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8954 #endif
8955       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8956       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8957 #ifdef MOMENT
8958       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8959       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8960       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8961 #endif
8962 c      s1d=0.0d0
8963 c      s2d=0.0d0
8964 c      s8d=0.0d0
8965 c      s12d=0.0d0
8966 c      s13d=0.0d0
8967 #ifdef MOMENT
8968       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8969      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8970 #else
8971       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8972      &               -0.5d0*ekont*(s2d+s12d)
8973 #endif
8974 C Cartesian derivatives
8975       do iii=1,2
8976         do kkk=1,5
8977           do lll=1,3
8978 #ifdef MOMENT
8979             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8980             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8981             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8982 #endif
8983             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8984             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8985      &          vtemp1d(1))
8986             s2d = scalar2(b1(1,itk),vtemp1d(1))
8987 #ifdef MOMENT
8988             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8989             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8990             s8d = -(atempd(1,1)+atempd(2,2))*
8991      &           scalar2(cc(1,1,itl),vtemp2(1))
8992 #endif
8993             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8994      &           auxmatd(1,1))
8995             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8996             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8997 c      s1d=0.0d0
8998 c      s2d=0.0d0
8999 c      s8d=0.0d0
9000 c      s12d=0.0d0
9001 c      s13d=0.0d0
9002 #ifdef MOMENT
9003             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9004      &        - 0.5d0*(s1d+s2d)
9005 #else
9006             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9007      &        - 0.5d0*s2d
9008 #endif
9009 #ifdef MOMENT
9010             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9011      &        - 0.5d0*(s8d+s12d)
9012 #else
9013             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9014      &        - 0.5d0*s12d
9015 #endif
9016           enddo
9017         enddo
9018       enddo
9019 #ifdef MOMENT
9020       do kkk=1,5
9021         do lll=1,3
9022           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9023      &      achuj_tempd(1,1))
9024           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9025           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9026           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9027           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9028           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9029      &      vtemp4d(1))
9030           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9031           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9032           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9033         enddo
9034       enddo
9035 #endif
9036 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9037 cd     &  16*eel_turn6_num
9038 cd      goto 1112
9039       if (j.lt.nres-1) then
9040         j1=j+1
9041         j2=j-1
9042       else
9043         j1=j-1
9044         j2=j-2
9045       endif
9046       if (l.lt.nres-1) then
9047         l1=l+1
9048         l2=l-1
9049       else
9050         l1=l-1
9051         l2=l-2
9052       endif
9053       do ll=1,3
9054 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9055 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9056 cgrad        ghalf=0.5d0*ggg1(ll)
9057 cd        ghalf=0.0d0
9058         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9059         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9060         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9061      &    +ekont*derx_turn(ll,2,1)
9062         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9063         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9064      &    +ekont*derx_turn(ll,4,1)
9065         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9066         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9067         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9068 cgrad        ghalf=0.5d0*ggg2(ll)
9069 cd        ghalf=0.0d0
9070         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9071      &    +ekont*derx_turn(ll,2,2)
9072         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9073         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9074      &    +ekont*derx_turn(ll,4,2)
9075         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9076         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9077         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9078       enddo
9079 cd      goto 1112
9080 cgrad      do m=i+1,j-1
9081 cgrad        do ll=1,3
9082 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9083 cgrad        enddo
9084 cgrad      enddo
9085 cgrad      do m=k+1,l-1
9086 cgrad        do ll=1,3
9087 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9088 cgrad        enddo
9089 cgrad      enddo
9090 cgrad1112  continue
9091 cgrad      do m=i+2,j2
9092 cgrad        do ll=1,3
9093 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9094 cgrad        enddo
9095 cgrad      enddo
9096 cgrad      do m=k+2,l2
9097 cgrad        do ll=1,3
9098 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9099 cgrad        enddo
9100 cgrad      enddo
9101 cd      do iii=1,nres-3
9102 cd        write (2,*) iii,g_corr6_loc(iii)
9103 cd      enddo
9104       eello_turn6=ekont*eel_turn6
9105 cd      write (2,*) 'ekont',ekont
9106 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9107       return
9108       end
9109
9110 C-----------------------------------------------------------------------------
9111       double precision function scalar(u,v)
9112 !DIR$ INLINEALWAYS scalar
9113 #ifndef OSF
9114 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9115 #endif
9116       implicit none
9117       double precision u(3),v(3)
9118 cd      double precision sc
9119 cd      integer i
9120 cd      sc=0.0d0
9121 cd      do i=1,3
9122 cd        sc=sc+u(i)*v(i)
9123 cd      enddo
9124 cd      scalar=sc
9125
9126       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9127       return
9128       end
9129 crc-------------------------------------------------
9130       SUBROUTINE MATVEC2(A1,V1,V2)
9131 !DIR$ INLINEALWAYS MATVEC2
9132 #ifndef OSF
9133 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9134 #endif
9135       implicit real*8 (a-h,o-z)
9136       include 'DIMENSIONS'
9137       DIMENSION A1(2,2),V1(2),V2(2)
9138 c      DO 1 I=1,2
9139 c        VI=0.0
9140 c        DO 3 K=1,2
9141 c    3     VI=VI+A1(I,K)*V1(K)
9142 c        Vaux(I)=VI
9143 c    1 CONTINUE
9144
9145       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9146       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9147
9148       v2(1)=vaux1
9149       v2(2)=vaux2
9150       END
9151 C---------------------------------------
9152       SUBROUTINE MATMAT2(A1,A2,A3)
9153 #ifndef OSF
9154 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9155 #endif
9156       implicit real*8 (a-h,o-z)
9157       include 'DIMENSIONS'
9158       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9159 c      DIMENSION AI3(2,2)
9160 c        DO  J=1,2
9161 c          A3IJ=0.0
9162 c          DO K=1,2
9163 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9164 c          enddo
9165 c          A3(I,J)=A3IJ
9166 c       enddo
9167 c      enddo
9168
9169       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9170       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9171       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9172       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9173
9174       A3(1,1)=AI3_11
9175       A3(2,1)=AI3_21
9176       A3(1,2)=AI3_12
9177       A3(2,2)=AI3_22
9178       END
9179
9180 c-------------------------------------------------------------------------
9181       double precision function scalar2(u,v)
9182 !DIR$ INLINEALWAYS scalar2
9183       implicit none
9184       double precision u(2),v(2)
9185       double precision sc
9186       integer i
9187       scalar2=u(1)*v(1)+u(2)*v(2)
9188       return
9189       end
9190
9191 C-----------------------------------------------------------------------------
9192
9193       subroutine transpose2(a,at)
9194 !DIR$ INLINEALWAYS transpose2
9195 #ifndef OSF
9196 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9197 #endif
9198       implicit none
9199       double precision a(2,2),at(2,2)
9200       at(1,1)=a(1,1)
9201       at(1,2)=a(2,1)
9202       at(2,1)=a(1,2)
9203       at(2,2)=a(2,2)
9204       return
9205       end
9206 c--------------------------------------------------------------------------
9207       subroutine transpose(n,a,at)
9208       implicit none
9209       integer n,i,j
9210       double precision a(n,n),at(n,n)
9211       do i=1,n
9212         do j=1,n
9213           at(j,i)=a(i,j)
9214         enddo
9215       enddo
9216       return
9217       end
9218 C---------------------------------------------------------------------------
9219       subroutine prodmat3(a1,a2,kk,transp,prod)
9220 !DIR$ INLINEALWAYS prodmat3
9221 #ifndef OSF
9222 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9223 #endif
9224       implicit none
9225       integer i,j
9226       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9227       logical transp
9228 crc      double precision auxmat(2,2),prod_(2,2)
9229
9230       if (transp) then
9231 crc        call transpose2(kk(1,1),auxmat(1,1))
9232 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9233 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9234
9235            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9236      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9237            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9238      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9239            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9240      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9241            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9242      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9243
9244       else
9245 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9246 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9247
9248            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9249      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9250            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9251      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9252            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9253      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9254            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9255      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9256
9257       endif
9258 c      call transpose2(a2(1,1),a2t(1,1))
9259
9260 crc      print *,transp
9261 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9262 crc      print *,((prod(i,j),i=1,2),j=1,2)
9263
9264       return
9265       end
9266