source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134
 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=iabs(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 + dsign(1.0,itype(i))*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=iabs(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 = -dsign(1.0,itype(i))*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         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6001         isccori=isccortyp(itype(i-2))
6002         isccori1=isccortyp(itype(i-1))
6003         phii=phi(i)
6004 cccc  Added 9 May 2012
6005 cc Tauangle is torsional engle depending on the value of first digit
6006 c(see comment below)
6007 cc Omicron is flat angle depending on the value of first digit
6008 c(see comment below)
6009
6010
6011         do intertyp=1,3 !intertyp
6012 cc Added 09 May 2012 (Adasko)
6013 cc  Intertyp means interaction type of backbone mainchain correlation:
6014 c   1 = SC...Ca...Ca...Ca
6015 c   2 = Ca...Ca...Ca...SC
6016 c   3 = SC...Ca...Ca...SCi
6017         gloci=0.0D0
6018         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6019      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6020      &      (itype(i-1).eq.ntyp1)))
6021      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6022      &     .or.(itype(i-2).eq.ntyp1)))
6023      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6024      &      (itype(i-1).eq.ntyp1)))) cycle
6025         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6026         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6027      & cycle
6028         do j=1,nterm_sccor(isccori,isccori1)
6029           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6030           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6031           cosphi=dcos(j*tauangle(intertyp,i))
6032           sinphi=dsin(j*tauangle(intertyp,i))
6033           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6034           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6035         enddo
6036         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6037 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6038 c     &gloc_sc(intertyp,i-3,icg)
6039         if (lprn)
6040      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6041      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6042      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6043      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6044         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6045        enddo !intertyp
6046       enddo
6047 c        do i=1,nres
6048 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6049 c        enddo
6050       return
6051       end
6052 c----------------------------------------------------------------------------
6053       subroutine multibody(ecorr)
6054 C This subroutine calculates multi-body contributions to energy following
6055 C the idea of Skolnick et al. If side chains I and J make a contact and
6056 C at the same time side chains I+1 and J+1 make a contact, an extra
6057 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6058       implicit real*8 (a-h,o-z)
6059       include 'DIMENSIONS'
6060       include 'COMMON.IOUNITS'
6061       include 'COMMON.DERIV'
6062       include 'COMMON.INTERACT'
6063       include 'COMMON.CONTACTS'
6064       double precision gx(3),gx1(3)
6065       logical lprn
6066
6067 C Set lprn=.true. for debugging
6068       lprn=.false.
6069
6070       if (lprn) then
6071         write (iout,'(a)') 'Contact function values:'
6072         do i=nnt,nct-2
6073           write (iout,'(i2,20(1x,i2,f10.5))')
6074      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6075         enddo
6076       endif
6077       ecorr=0.0D0
6078       do i=nnt,nct
6079         do j=1,3
6080           gradcorr(j,i)=0.0D0
6081           gradxorr(j,i)=0.0D0
6082         enddo
6083       enddo
6084       do i=nnt,nct-2
6085
6086         DO ISHIFT = 3,4
6087
6088         i1=i+ishift
6089         num_conti=num_cont(i)
6090         num_conti1=num_cont(i1)
6091         do jj=1,num_conti
6092           j=jcont(jj,i)
6093           do kk=1,num_conti1
6094             j1=jcont(kk,i1)
6095             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6096 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6097 cd   &                   ' ishift=',ishift
6098 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6099 C The system gains extra energy.
6100               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6101             endif   ! j1==j+-ishift
6102           enddo     ! kk
6103         enddo       ! jj
6104
6105         ENDDO ! ISHIFT
6106
6107       enddo         ! i
6108       return
6109       end
6110 c------------------------------------------------------------------------------
6111       double precision function esccorr(i,j,k,l,jj,kk)
6112       implicit real*8 (a-h,o-z)
6113       include 'DIMENSIONS'
6114       include 'COMMON.IOUNITS'
6115       include 'COMMON.DERIV'
6116       include 'COMMON.INTERACT'
6117       include 'COMMON.CONTACTS'
6118       double precision gx(3),gx1(3)
6119       logical lprn
6120       lprn=.false.
6121       eij=facont(jj,i)
6122       ekl=facont(kk,k)
6123 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6124 C Calculate the multi-body contribution to energy.
6125 C Calculate multi-body contributions to the gradient.
6126 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6127 cd   & k,l,(gacont(m,kk,k),m=1,3)
6128       do m=1,3
6129         gx(m) =ekl*gacont(m,jj,i)
6130         gx1(m)=eij*gacont(m,kk,k)
6131         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6132         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6133         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6134         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6135       enddo
6136       do m=i,j-1
6137         do ll=1,3
6138           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6139         enddo
6140       enddo
6141       do m=k,l-1
6142         do ll=1,3
6143           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6144         enddo
6145       enddo
6146       esccorr=-eij*ekl
6147       return
6148       end
6149 c------------------------------------------------------------------------------
6150       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6151 C This subroutine calculates multi-body contributions to hydrogen-bonding
6152       implicit real*8 (a-h,o-z)
6153       include 'DIMENSIONS'
6154       include 'COMMON.IOUNITS'
6155 #ifdef MPI
6156       include "mpif.h"
6157       parameter (max_cont=maxconts)
6158       parameter (max_dim=26)
6159       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6160       double precision zapas(max_dim,maxconts,max_fg_procs),
6161      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6162       common /przechowalnia/ zapas
6163       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6164      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6165 #endif
6166       include 'COMMON.SETUP'
6167       include 'COMMON.FFIELD'
6168       include 'COMMON.DERIV'
6169       include 'COMMON.INTERACT'
6170       include 'COMMON.CONTACTS'
6171       include 'COMMON.CONTROL'
6172       include 'COMMON.LOCAL'
6173       double precision gx(3),gx1(3),time00
6174       logical lprn,ldone
6175
6176 C Set lprn=.true. for debugging
6177       lprn=.false.
6178 #ifdef MPI
6179       n_corr=0
6180       n_corr1=0
6181       if (nfgtasks.le.1) goto 30
6182       if (lprn) then
6183         write (iout,'(a)') 'Contact function values before RECEIVE:'
6184         do i=nnt,nct-2
6185           write (iout,'(2i3,50(1x,i2,f5.2))')
6186      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6187      &    j=1,num_cont_hb(i))
6188         enddo
6189       endif
6190       call flush(iout)
6191       do i=1,ntask_cont_from
6192         ncont_recv(i)=0
6193       enddo
6194       do i=1,ntask_cont_to
6195         ncont_sent(i)=0
6196       enddo
6197 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6198 c     & ntask_cont_to
6199 C Make the list of contacts to send to send to other procesors
6200 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6201 c      call flush(iout)
6202       do i=iturn3_start,iturn3_end
6203 c        write (iout,*) "make contact list turn3",i," num_cont",
6204 c     &    num_cont_hb(i)
6205         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6206       enddo
6207       do i=iturn4_start,iturn4_end
6208 c        write (iout,*) "make contact list turn4",i," num_cont",
6209 c     &   num_cont_hb(i)
6210         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6211       enddo
6212       do ii=1,nat_sent
6213         i=iat_sent(ii)
6214 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6215 c     &    num_cont_hb(i)
6216         do j=1,num_cont_hb(i)
6217         do k=1,4
6218           jjc=jcont_hb(j,i)
6219           iproc=iint_sent_local(k,jjc,ii)
6220 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6221           if (iproc.gt.0) then
6222             ncont_sent(iproc)=ncont_sent(iproc)+1
6223             nn=ncont_sent(iproc)
6224             zapas(1,nn,iproc)=i
6225             zapas(2,nn,iproc)=jjc
6226             zapas(3,nn,iproc)=facont_hb(j,i)
6227             zapas(4,nn,iproc)=ees0p(j,i)
6228             zapas(5,nn,iproc)=ees0m(j,i)
6229             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6230             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6231             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6232             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6233             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6234             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6235             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6236             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6237             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6238             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6239             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6240             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6241             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6242             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6243             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6244             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6245             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6246             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6247             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6248             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6249             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6250           endif
6251         enddo
6252         enddo
6253       enddo
6254       if (lprn) then
6255       write (iout,*)
6256      &  "Numbers of contacts to be sent to other processors",
6257      &  (ncont_sent(i),i=1,ntask_cont_to)
6258       write (iout,*) "Contacts sent"
6259       do ii=1,ntask_cont_to
6260         nn=ncont_sent(ii)
6261         iproc=itask_cont_to(ii)
6262         write (iout,*) nn," contacts to processor",iproc,
6263      &   " of CONT_TO_COMM group"
6264         do i=1,nn
6265           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6266         enddo
6267       enddo
6268       call flush(iout)
6269       endif
6270       CorrelType=477
6271       CorrelID=fg_rank+1
6272       CorrelType1=478
6273       CorrelID1=nfgtasks+fg_rank+1
6274       ireq=0
6275 C Receive the numbers of needed contacts from other processors
6276       do ii=1,ntask_cont_from
6277         iproc=itask_cont_from(ii)
6278         ireq=ireq+1
6279         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6280      &    FG_COMM,req(ireq),IERR)
6281       enddo
6282 c      write (iout,*) "IRECV ended"
6283 c      call flush(iout)
6284 C Send the number of contacts needed by other processors
6285       do ii=1,ntask_cont_to
6286         iproc=itask_cont_to(ii)
6287         ireq=ireq+1
6288         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6289      &    FG_COMM,req(ireq),IERR)
6290       enddo
6291 c      write (iout,*) "ISEND ended"
6292 c      write (iout,*) "number of requests (nn)",ireq
6293       call flush(iout)
6294       if (ireq.gt.0)
6295      &  call MPI_Waitall(ireq,req,status_array,ierr)
6296 c      write (iout,*)
6297 c     &  "Numbers of contacts to be received from other processors",
6298 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6299 c      call flush(iout)
6300 C Receive contacts
6301       ireq=0
6302       do ii=1,ntask_cont_from
6303         iproc=itask_cont_from(ii)
6304         nn=ncont_recv(ii)
6305 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6306 c     &   " of CONT_TO_COMM group"
6307         call flush(iout)
6308         if (nn.gt.0) then
6309           ireq=ireq+1
6310           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6311      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6312 c          write (iout,*) "ireq,req",ireq,req(ireq)
6313         endif
6314       enddo
6315 C Send the contacts to processors that need them
6316       do ii=1,ntask_cont_to
6317         iproc=itask_cont_to(ii)
6318         nn=ncont_sent(ii)
6319 c        write (iout,*) nn," contacts to processor",iproc,
6320 c     &   " of CONT_TO_COMM group"
6321         if (nn.gt.0) then
6322           ireq=ireq+1
6323           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6324      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6325 c          write (iout,*) "ireq,req",ireq,req(ireq)
6326 c          do i=1,nn
6327 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6328 c          enddo
6329         endif
6330       enddo
6331 c      write (iout,*) "number of requests (contacts)",ireq
6332 c      write (iout,*) "req",(req(i),i=1,4)
6333 c      call flush(iout)
6334       if (ireq.gt.0)
6335      & call MPI_Waitall(ireq,req,status_array,ierr)
6336       do iii=1,ntask_cont_from
6337         iproc=itask_cont_from(iii)
6338         nn=ncont_recv(iii)
6339         if (lprn) then
6340         write (iout,*) "Received",nn," contacts from processor",iproc,
6341      &   " of CONT_FROM_COMM group"
6342         call flush(iout)
6343         do i=1,nn
6344           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6345         enddo
6346         call flush(iout)
6347         endif
6348         do i=1,nn
6349           ii=zapas_recv(1,i,iii)
6350 c Flag the received contacts to prevent double-counting
6351           jj=-zapas_recv(2,i,iii)
6352 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6353 c          call flush(iout)
6354           nnn=num_cont_hb(ii)+1
6355           num_cont_hb(ii)=nnn
6356           jcont_hb(nnn,ii)=jj
6357           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6358           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6359           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6360           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6361           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6362           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6363           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6364           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6365           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6366           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6367           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6368           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6369           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6370           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6371           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6372           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6373           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6374           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6375           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6376           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6377           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6378           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6379           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6380           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6381         enddo
6382       enddo
6383       call flush(iout)
6384       if (lprn) then
6385         write (iout,'(a)') 'Contact function values after receive:'
6386         do i=nnt,nct-2
6387           write (iout,'(2i3,50(1x,i3,f5.2))')
6388      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6389      &    j=1,num_cont_hb(i))
6390         enddo
6391         call flush(iout)
6392       endif
6393    30 continue
6394 #endif
6395       if (lprn) then
6396         write (iout,'(a)') 'Contact function values:'
6397         do i=nnt,nct-2
6398           write (iout,'(2i3,50(1x,i3,f5.2))')
6399      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6400      &    j=1,num_cont_hb(i))
6401         enddo
6402       endif
6403       ecorr=0.0D0
6404 C Remove the loop below after debugging !!!
6405       do i=nnt,nct
6406         do j=1,3
6407           gradcorr(j,i)=0.0D0
6408           gradxorr(j,i)=0.0D0
6409         enddo
6410       enddo
6411 C Calculate the local-electrostatic correlation terms
6412       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6413         i1=i+1
6414         num_conti=num_cont_hb(i)
6415         num_conti1=num_cont_hb(i+1)
6416         do jj=1,num_conti
6417           j=jcont_hb(jj,i)
6418           jp=iabs(j)
6419           do kk=1,num_conti1
6420             j1=jcont_hb(kk,i1)
6421             jp1=iabs(j1)
6422 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6423 c     &         ' jj=',jj,' kk=',kk
6424             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6425      &          .or. j.lt.0 .and. j1.gt.0) .and.
6426      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6427 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6428 C The system gains extra energy.
6429               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6430               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6431      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6432               n_corr=n_corr+1
6433             else if (j1.eq.j) then
6434 C Contacts I-J and I-(J+1) occur simultaneously.
6435 C The system loses extra energy.
6436 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6437             endif
6438           enddo ! kk
6439           do kk=1,num_conti
6440             j1=jcont_hb(kk,i)
6441 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6442 c    &         ' jj=',jj,' kk=',kk
6443             if (j1.eq.j+1) then
6444 C Contacts I-J and (I+1)-J occur simultaneously.
6445 C The system loses extra energy.
6446 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6447             endif ! j1==j+1
6448           enddo ! kk
6449         enddo ! jj
6450       enddo ! i
6451       return
6452       end
6453 c------------------------------------------------------------------------------
6454       subroutine add_hb_contact(ii,jj,itask)
6455       implicit real*8 (a-h,o-z)
6456       include "DIMENSIONS"
6457       include "COMMON.IOUNITS"
6458       integer max_cont
6459       integer max_dim
6460       parameter (max_cont=maxconts)
6461       parameter (max_dim=26)
6462       include "COMMON.CONTACTS"
6463       double precision zapas(max_dim,maxconts,max_fg_procs),
6464      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6465       common /przechowalnia/ zapas
6466       integer i,j,ii,jj,iproc,itask(4),nn
6467 c      write (iout,*) "itask",itask
6468       do i=1,2
6469         iproc=itask(i)
6470         if (iproc.gt.0) then
6471           do j=1,num_cont_hb(ii)
6472             jjc=jcont_hb(j,ii)
6473 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6474             if (jjc.eq.jj) then
6475               ncont_sent(iproc)=ncont_sent(iproc)+1
6476               nn=ncont_sent(iproc)
6477               zapas(1,nn,iproc)=ii
6478               zapas(2,nn,iproc)=jjc
6479               zapas(3,nn,iproc)=facont_hb(j,ii)
6480               zapas(4,nn,iproc)=ees0p(j,ii)
6481               zapas(5,nn,iproc)=ees0m(j,ii)
6482               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6483               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6484               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6485               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6486               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6487               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6488               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6489               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6490               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6491               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6492               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6493               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6494               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6495               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6496               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6497               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6498               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6499               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6500               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6501               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6502               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6503               exit
6504             endif
6505           enddo
6506         endif
6507       enddo
6508       return
6509       end
6510 c------------------------------------------------------------------------------
6511       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6512      &  n_corr1)
6513 C This subroutine calculates multi-body contributions to hydrogen-bonding
6514       implicit real*8 (a-h,o-z)
6515       include 'DIMENSIONS'
6516       include 'COMMON.IOUNITS'
6517 #ifdef MPI
6518       include "mpif.h"
6519       parameter (max_cont=maxconts)
6520       parameter (max_dim=70)
6521       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6522       double precision zapas(max_dim,maxconts,max_fg_procs),
6523      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6524       common /przechowalnia/ zapas
6525       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6526      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6527 #endif
6528       include 'COMMON.SETUP'
6529       include 'COMMON.FFIELD'
6530       include 'COMMON.DERIV'
6531       include 'COMMON.LOCAL'
6532       include 'COMMON.INTERACT'
6533       include 'COMMON.CONTACTS'
6534       include 'COMMON.CHAIN'
6535       include 'COMMON.CONTROL'
6536       double precision gx(3),gx1(3)
6537       integer num_cont_hb_old(maxres)
6538       logical lprn,ldone
6539       double precision eello4,eello5,eelo6,eello_turn6
6540       external eello4,eello5,eello6,eello_turn6
6541 C Set lprn=.true. for debugging
6542       lprn=.false.
6543       eturn6=0.0d0
6544 #ifdef MPI
6545       do i=1,nres
6546         num_cont_hb_old(i)=num_cont_hb(i)
6547       enddo
6548       n_corr=0
6549       n_corr1=0
6550       if (nfgtasks.le.1) goto 30
6551       if (lprn) then
6552         write (iout,'(a)') 'Contact function values before RECEIVE:'
6553         do i=nnt,nct-2
6554           write (iout,'(2i3,50(1x,i2,f5.2))')
6555      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6556      &    j=1,num_cont_hb(i))
6557         enddo
6558       endif
6559       call flush(iout)
6560       do i=1,ntask_cont_from
6561         ncont_recv(i)=0
6562       enddo
6563       do i=1,ntask_cont_to
6564         ncont_sent(i)=0
6565       enddo
6566 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6567 c     & ntask_cont_to
6568 C Make the list of contacts to send to send to other procesors
6569       do i=iturn3_start,iturn3_end
6570 c        write (iout,*) "make contact list turn3",i," num_cont",
6571 c     &    num_cont_hb(i)
6572         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6573       enddo
6574       do i=iturn4_start,iturn4_end
6575 c        write (iout,*) "make contact list turn4",i," num_cont",
6576 c     &   num_cont_hb(i)
6577         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6578       enddo
6579       do ii=1,nat_sent
6580         i=iat_sent(ii)
6581 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6582 c     &    num_cont_hb(i)
6583         do j=1,num_cont_hb(i)
6584         do k=1,4
6585           jjc=jcont_hb(j,i)
6586           iproc=iint_sent_local(k,jjc,ii)
6587 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6588           if (iproc.ne.0) then
6589             ncont_sent(iproc)=ncont_sent(iproc)+1
6590             nn=ncont_sent(iproc)
6591             zapas(1,nn,iproc)=i
6592             zapas(2,nn,iproc)=jjc
6593             zapas(3,nn,iproc)=d_cont(j,i)
6594             ind=3
6595             do kk=1,3
6596               ind=ind+1
6597               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6598             enddo
6599             do kk=1,2
6600               do ll=1,2
6601                 ind=ind+1
6602                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6603               enddo
6604             enddo
6605             do jj=1,5
6606               do kk=1,3
6607                 do ll=1,2
6608                   do mm=1,2
6609                     ind=ind+1
6610                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6611                   enddo
6612                 enddo
6613               enddo
6614             enddo
6615           endif
6616         enddo
6617         enddo
6618       enddo
6619       if (lprn) then
6620       write (iout,*)
6621      &  "Numbers of contacts to be sent to other processors",
6622      &  (ncont_sent(i),i=1,ntask_cont_to)
6623       write (iout,*) "Contacts sent"
6624       do ii=1,ntask_cont_to
6625         nn=ncont_sent(ii)
6626         iproc=itask_cont_to(ii)
6627         write (iout,*) nn," contacts to processor",iproc,
6628      &   " of CONT_TO_COMM group"
6629         do i=1,nn
6630           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6631         enddo
6632       enddo
6633       call flush(iout)
6634       endif
6635       CorrelType=477
6636       CorrelID=fg_rank+1
6637       CorrelType1=478
6638       CorrelID1=nfgtasks+fg_rank+1
6639       ireq=0
6640 C Receive the numbers of needed contacts from other processors
6641       do ii=1,ntask_cont_from
6642         iproc=itask_cont_from(ii)
6643         ireq=ireq+1
6644         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6645      &    FG_COMM,req(ireq),IERR)
6646       enddo
6647 c      write (iout,*) "IRECV ended"
6648 c      call flush(iout)
6649 C Send the number of contacts needed by other processors
6650       do ii=1,ntask_cont_to
6651         iproc=itask_cont_to(ii)
6652         ireq=ireq+1
6653         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6654      &    FG_COMM,req(ireq),IERR)
6655       enddo
6656 c      write (iout,*) "ISEND ended"
6657 c      write (iout,*) "number of requests (nn)",ireq
6658       call flush(iout)
6659       if (ireq.gt.0)
6660      &  call MPI_Waitall(ireq,req,status_array,ierr)
6661 c      write (iout,*)
6662 c     &  "Numbers of contacts to be received from other processors",
6663 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6664 c      call flush(iout)
6665 C Receive contacts
6666       ireq=0
6667       do ii=1,ntask_cont_from
6668         iproc=itask_cont_from(ii)
6669         nn=ncont_recv(ii)
6670 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6671 c     &   " of CONT_TO_COMM group"
6672         call flush(iout)
6673         if (nn.gt.0) then
6674           ireq=ireq+1
6675           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6676      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6677 c          write (iout,*) "ireq,req",ireq,req(ireq)
6678         endif
6679       enddo
6680 C Send the contacts to processors that need them
6681       do ii=1,ntask_cont_to
6682         iproc=itask_cont_to(ii)
6683         nn=ncont_sent(ii)
6684 c        write (iout,*) nn," contacts to processor",iproc,
6685 c     &   " of CONT_TO_COMM group"
6686         if (nn.gt.0) then
6687           ireq=ireq+1
6688           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6689      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6690 c          write (iout,*) "ireq,req",ireq,req(ireq)
6691 c          do i=1,nn
6692 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6693 c          enddo
6694         endif
6695       enddo
6696 c      write (iout,*) "number of requests (contacts)",ireq
6697 c      write (iout,*) "req",(req(i),i=1,4)
6698 c      call flush(iout)
6699       if (ireq.gt.0)
6700      & call MPI_Waitall(ireq,req,status_array,ierr)
6701       do iii=1,ntask_cont_from
6702         iproc=itask_cont_from(iii)
6703         nn=ncont_recv(iii)
6704         if (lprn) then
6705         write (iout,*) "Received",nn," contacts from processor",iproc,
6706      &   " of CONT_FROM_COMM group"
6707         call flush(iout)
6708         do i=1,nn
6709           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6710         enddo
6711         call flush(iout)
6712         endif
6713         do i=1,nn
6714           ii=zapas_recv(1,i,iii)
6715 c Flag the received contacts to prevent double-counting
6716           jj=-zapas_recv(2,i,iii)
6717 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6718 c          call flush(iout)
6719           nnn=num_cont_hb(ii)+1
6720           num_cont_hb(ii)=nnn
6721           jcont_hb(nnn,ii)=jj
6722           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6723           ind=3
6724           do kk=1,3
6725             ind=ind+1
6726             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6727           enddo
6728           do kk=1,2
6729             do ll=1,2
6730               ind=ind+1
6731               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6732             enddo
6733           enddo
6734           do jj=1,5
6735             do kk=1,3
6736               do ll=1,2
6737                 do mm=1,2
6738                   ind=ind+1
6739                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6740                 enddo
6741               enddo
6742             enddo
6743           enddo
6744         enddo
6745       enddo
6746       call flush(iout)
6747       if (lprn) then
6748         write (iout,'(a)') 'Contact function values after receive:'
6749         do i=nnt,nct-2
6750           write (iout,'(2i3,50(1x,i3,5f6.3))')
6751      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6752      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6753         enddo
6754         call flush(iout)
6755       endif
6756    30 continue
6757 #endif
6758       if (lprn) then
6759         write (iout,'(a)') 'Contact function values:'
6760         do i=nnt,nct-2
6761           write (iout,'(2i3,50(1x,i2,5f6.3))')
6762      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6763      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6764         enddo
6765       endif
6766       ecorr=0.0D0
6767       ecorr5=0.0d0
6768       ecorr6=0.0d0
6769 C Remove the loop below after debugging !!!
6770       do i=nnt,nct
6771         do j=1,3
6772           gradcorr(j,i)=0.0D0
6773           gradxorr(j,i)=0.0D0
6774         enddo
6775       enddo
6776 C Calculate the dipole-dipole interaction energies
6777       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6778       do i=iatel_s,iatel_e+1
6779         num_conti=num_cont_hb(i)
6780         do jj=1,num_conti
6781           j=jcont_hb(jj,i)
6782 #ifdef MOMENT
6783           call dipole(i,j,jj)
6784 #endif
6785         enddo
6786       enddo
6787       endif
6788 C Calculate the local-electrostatic correlation terms
6789 c                write (iout,*) "gradcorr5 in eello5 before loop"
6790 c                do iii=1,nres
6791 c                  write (iout,'(i5,3f10.5)')
6792 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6793 c                enddo
6794       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6795 c        write (iout,*) "corr loop i",i
6796         i1=i+1
6797         num_conti=num_cont_hb(i)
6798         num_conti1=num_cont_hb(i+1)
6799         do jj=1,num_conti
6800           j=jcont_hb(jj,i)
6801           jp=iabs(j)
6802           do kk=1,num_conti1
6803             j1=jcont_hb(kk,i1)
6804             jp1=iabs(j1)
6805 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6806 c     &         ' jj=',jj,' kk=',kk
6807 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6808             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6809      &          .or. j.lt.0 .and. j1.gt.0) .and.
6810      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6811 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6812 C The system gains extra energy.
6813               n_corr=n_corr+1
6814               sqd1=dsqrt(d_cont(jj,i))
6815               sqd2=dsqrt(d_cont(kk,i1))
6816               sred_geom = sqd1*sqd2
6817               IF (sred_geom.lt.cutoff_corr) THEN
6818                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6819      &            ekont,fprimcont)
6820 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6821 cd     &         ' jj=',jj,' kk=',kk
6822                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6823                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6824                 do l=1,3
6825                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6826                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6827                 enddo
6828                 n_corr1=n_corr1+1
6829 cd               write (iout,*) 'sred_geom=',sred_geom,
6830 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6831 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6832 cd               write (iout,*) "g_contij",g_contij
6833 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6834 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6835                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6836                 if (wcorr4.gt.0.0d0)
6837      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6838                   if (energy_dec.and.wcorr4.gt.0.0d0)
6839      1                 write (iout,'(a6,4i5,0pf7.3)')
6840      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6841 c                write (iout,*) "gradcorr5 before eello5"
6842 c                do iii=1,nres
6843 c                  write (iout,'(i5,3f10.5)')
6844 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6845 c                enddo
6846                 if (wcorr5.gt.0.0d0)
6847      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6848 c                write (iout,*) "gradcorr5 after eello5"
6849 c                do iii=1,nres
6850 c                  write (iout,'(i5,3f10.5)')
6851 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6852 c                enddo
6853                   if (energy_dec.and.wcorr5.gt.0.0d0)
6854      1                 write (iout,'(a6,4i5,0pf7.3)')
6855      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6856 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6857 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6858                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6859      &               .or. wturn6.eq.0.0d0))then
6860 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6861                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6862                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6863      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6864 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6865 cd     &            'ecorr6=',ecorr6
6866 cd                write (iout,'(4e15.5)') sred_geom,
6867 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6868 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6869 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6870                 else if (wturn6.gt.0.0d0
6871      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6872 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6873                   eturn6=eturn6+eello_turn6(i,jj,kk)
6874                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6875      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6876 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6877                 endif
6878               ENDIF
6879 1111          continue
6880             endif
6881           enddo ! kk
6882         enddo ! jj
6883       enddo ! i
6884       do i=1,nres
6885         num_cont_hb(i)=num_cont_hb_old(i)
6886       enddo
6887 c                write (iout,*) "gradcorr5 in eello5"
6888 c                do iii=1,nres
6889 c                  write (iout,'(i5,3f10.5)')
6890 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6891 c                enddo
6892       return
6893       end
6894 c------------------------------------------------------------------------------
6895       subroutine add_hb_contact_eello(ii,jj,itask)
6896       implicit real*8 (a-h,o-z)
6897       include "DIMENSIONS"
6898       include "COMMON.IOUNITS"
6899       integer max_cont
6900       integer max_dim
6901       parameter (max_cont=maxconts)
6902       parameter (max_dim=70)
6903       include "COMMON.CONTACTS"
6904       double precision zapas(max_dim,maxconts,max_fg_procs),
6905      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6906       common /przechowalnia/ zapas
6907       integer i,j,ii,jj,iproc,itask(4),nn
6908 c      write (iout,*) "itask",itask
6909       do i=1,2
6910         iproc=itask(i)
6911         if (iproc.gt.0) then
6912           do j=1,num_cont_hb(ii)
6913             jjc=jcont_hb(j,ii)
6914 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6915             if (jjc.eq.jj) then
6916               ncont_sent(iproc)=ncont_sent(iproc)+1
6917               nn=ncont_sent(iproc)
6918               zapas(1,nn,iproc)=ii
6919               zapas(2,nn,iproc)=jjc
6920               zapas(3,nn,iproc)=d_cont(j,ii)
6921               ind=3
6922               do kk=1,3
6923                 ind=ind+1
6924                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6925               enddo
6926               do kk=1,2
6927                 do ll=1,2
6928                   ind=ind+1
6929                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6930                 enddo
6931               enddo
6932               do jj=1,5
6933                 do kk=1,3
6934                   do ll=1,2
6935                     do mm=1,2
6936                       ind=ind+1
6937                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6938                     enddo
6939                   enddo
6940                 enddo
6941               enddo
6942               exit
6943             endif
6944           enddo
6945         endif
6946       enddo
6947       return
6948       end
6949 c------------------------------------------------------------------------------
6950       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6951       implicit real*8 (a-h,o-z)
6952       include 'DIMENSIONS'
6953       include 'COMMON.IOUNITS'
6954       include 'COMMON.DERIV'
6955       include 'COMMON.INTERACT'
6956       include 'COMMON.CONTACTS'
6957       double precision gx(3),gx1(3)
6958       logical lprn
6959       lprn=.false.
6960       eij=facont_hb(jj,i)
6961       ekl=facont_hb(kk,k)
6962       ees0pij=ees0p(jj,i)
6963       ees0pkl=ees0p(kk,k)
6964       ees0mij=ees0m(jj,i)
6965       ees0mkl=ees0m(kk,k)
6966       ekont=eij*ekl
6967       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6968 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6969 C Following 4 lines for diagnostics.
6970 cd    ees0pkl=0.0D0
6971 cd    ees0pij=1.0D0
6972 cd    ees0mkl=0.0D0
6973 cd    ees0mij=1.0D0
6974 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6975 c     & 'Contacts ',i,j,
6976 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6977 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6978 c     & 'gradcorr_long'
6979 C Calculate the multi-body contribution to energy.
6980 c      ecorr=ecorr+ekont*ees
6981 C Calculate multi-body contributions to the gradient.
6982       coeffpees0pij=coeffp*ees0pij
6983       coeffmees0mij=coeffm*ees0mij
6984       coeffpees0pkl=coeffp*ees0pkl
6985       coeffmees0mkl=coeffm*ees0mkl
6986       do ll=1,3
6987 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6988         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6989      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6990      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6991         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6992      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6993      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6994 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6995         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6996      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6997      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6998         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6999      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7000      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7001         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7002      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7003      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7004         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7005         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7006         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7007      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7008      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7009         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7010         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7011 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7012       enddo
7013 c      write (iout,*)
7014 cgrad      do m=i+1,j-1
7015 cgrad        do ll=1,3
7016 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7017 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7018 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7019 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7020 cgrad        enddo
7021 cgrad      enddo
7022 cgrad      do m=k+1,l-1
7023 cgrad        do ll=1,3
7024 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7025 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7026 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7027 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7028 cgrad        enddo
7029 cgrad      enddo
7030 c      write (iout,*) "ehbcorr",ekont*ees
7031       ehbcorr=ekont*ees
7032       return
7033       end
7034 #ifdef MOMENT
7035 C---------------------------------------------------------------------------
7036       subroutine dipole(i,j,jj)
7037       implicit real*8 (a-h,o-z)
7038       include 'DIMENSIONS'
7039       include 'COMMON.IOUNITS'
7040       include 'COMMON.CHAIN'
7041       include 'COMMON.FFIELD'
7042       include 'COMMON.DERIV'
7043       include 'COMMON.INTERACT'
7044       include 'COMMON.CONTACTS'
7045       include 'COMMON.TORSION'
7046       include 'COMMON.VAR'
7047       include 'COMMON.GEO'
7048       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7049      &  auxmat(2,2)
7050       iti1 = itortyp(itype(i+1))
7051       if (j.lt.nres-1) then
7052         itj1 = itortyp(itype(j+1))
7053       else
7054         itj1=ntortyp+1
7055       endif
7056       do iii=1,2
7057         dipi(iii,1)=Ub2(iii,i)
7058         dipderi(iii)=Ub2der(iii,i)
7059         dipi(iii,2)=b1(iii,iti1)
7060         dipj(iii,1)=Ub2(iii,j)
7061         dipderj(iii)=Ub2der(iii,j)
7062         dipj(iii,2)=b1(iii,itj1)
7063       enddo
7064       kkk=0
7065       do iii=1,2
7066         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7067         do jjj=1,2
7068           kkk=kkk+1
7069           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7070         enddo
7071       enddo
7072       do kkk=1,5
7073         do lll=1,3
7074           mmm=0
7075           do iii=1,2
7076             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7077      &        auxvec(1))
7078             do jjj=1,2
7079               mmm=mmm+1
7080               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7081             enddo
7082           enddo
7083         enddo
7084       enddo
7085       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7086       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7087       do iii=1,2
7088         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7089       enddo
7090       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7091       do iii=1,2
7092         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7093       enddo
7094       return
7095       end
7096 #endif
7097 C---------------------------------------------------------------------------
7098       subroutine calc_eello(i,j,k,l,jj,kk)
7099 C
7100 C This subroutine computes matrices and vectors needed to calculate
7101 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7102 C
7103       implicit real*8 (a-h,o-z)
7104       include 'DIMENSIONS'
7105       include 'COMMON.IOUNITS'
7106       include 'COMMON.CHAIN'
7107       include 'COMMON.DERIV'
7108       include 'COMMON.INTERACT'
7109       include 'COMMON.CONTACTS'
7110       include 'COMMON.TORSION'
7111       include 'COMMON.VAR'
7112       include 'COMMON.GEO'
7113       include 'COMMON.FFIELD'
7114       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7115      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7116       logical lprn
7117       common /kutas/ lprn
7118 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7119 cd     & ' jj=',jj,' kk=',kk
7120 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7121 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7122 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7123       do iii=1,2
7124         do jjj=1,2
7125           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7126           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7127         enddo
7128       enddo
7129       call transpose2(aa1(1,1),aa1t(1,1))
7130       call transpose2(aa2(1,1),aa2t(1,1))
7131       do kkk=1,5
7132         do lll=1,3
7133           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7134      &      aa1tder(1,1,lll,kkk))
7135           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7136      &      aa2tder(1,1,lll,kkk))
7137         enddo
7138       enddo
7139       if (l.eq.j+1) then
7140 C parallel orientation of the two CA-CA-CA frames.
7141         if (i.gt.1) then
7142           iti=itortyp(itype(i))
7143         else
7144           iti=ntortyp+1
7145         endif
7146         itk1=itortyp(itype(k+1))
7147         itj=itortyp(itype(j))
7148         if (l.lt.nres-1) then
7149           itl1=itortyp(itype(l+1))
7150         else
7151           itl1=ntortyp+1
7152         endif
7153 C A1 kernel(j+1) A2T
7154 cd        do iii=1,2
7155 cd          write (iout,'(3f10.5,5x,3f10.5)')
7156 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7157 cd        enddo
7158         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7159      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7160      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7161 C Following matrices are needed only for 6-th order cumulants
7162         IF (wcorr6.gt.0.0d0) THEN
7163         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7164      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7165      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7166         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7167      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7168      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7169      &   ADtEAderx(1,1,1,1,1,1))
7170         lprn=.false.
7171         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7172      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7173      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7174      &   ADtEA1derx(1,1,1,1,1,1))
7175         ENDIF
7176 C End 6-th order cumulants
7177 cd        lprn=.false.
7178 cd        if (lprn) then
7179 cd        write (2,*) 'In calc_eello6'
7180 cd        do iii=1,2
7181 cd          write (2,*) 'iii=',iii
7182 cd          do kkk=1,5
7183 cd            write (2,*) 'kkk=',kkk
7184 cd            do jjj=1,2
7185 cd              write (2,'(3(2f10.5),5x)')
7186 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7187 cd            enddo
7188 cd          enddo
7189 cd        enddo
7190 cd        endif
7191         call transpose2(EUgder(1,1,k),auxmat(1,1))
7192         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7193         call transpose2(EUg(1,1,k),auxmat(1,1))
7194         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7195         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7196         do iii=1,2
7197           do kkk=1,5
7198             do lll=1,3
7199               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7200      &          EAEAderx(1,1,lll,kkk,iii,1))
7201             enddo
7202           enddo
7203         enddo
7204 C A1T kernel(i+1) A2
7205         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7206      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7207      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7208 C Following matrices are needed only for 6-th order cumulants
7209         IF (wcorr6.gt.0.0d0) THEN
7210         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7211      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7212      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7213         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7214      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7215      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7216      &   ADtEAderx(1,1,1,1,1,2))
7217         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7218      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7219      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7220      &   ADtEA1derx(1,1,1,1,1,2))
7221         ENDIF
7222 C End 6-th order cumulants
7223         call transpose2(EUgder(1,1,l),auxmat(1,1))
7224         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7225         call transpose2(EUg(1,1,l),auxmat(1,1))
7226         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7227         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7228         do iii=1,2
7229           do kkk=1,5
7230             do lll=1,3
7231               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7232      &          EAEAderx(1,1,lll,kkk,iii,2))
7233             enddo
7234           enddo
7235         enddo
7236 C AEAb1 and AEAb2
7237 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7238 C They are needed only when the fifth- or the sixth-order cumulants are
7239 C indluded.
7240         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7241         call transpose2(AEA(1,1,1),auxmat(1,1))
7242         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7243         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7244         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7245         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7246         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7247         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7248         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7249         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7250         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7251         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7252         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7253         call transpose2(AEA(1,1,2),auxmat(1,1))
7254         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7255         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7256         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7257         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7258         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7259         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7260         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7261         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7262         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7263         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7264         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7265 C Calculate the Cartesian derivatives of the vectors.
7266         do iii=1,2
7267           do kkk=1,5
7268             do lll=1,3
7269               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7270               call matvec2(auxmat(1,1),b1(1,iti),
7271      &          AEAb1derx(1,lll,kkk,iii,1,1))
7272               call matvec2(auxmat(1,1),Ub2(1,i),
7273      &          AEAb2derx(1,lll,kkk,iii,1,1))
7274               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7275      &          AEAb1derx(1,lll,kkk,iii,2,1))
7276               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7277      &          AEAb2derx(1,lll,kkk,iii,2,1))
7278               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7279               call matvec2(auxmat(1,1),b1(1,itj),
7280      &          AEAb1derx(1,lll,kkk,iii,1,2))
7281               call matvec2(auxmat(1,1),Ub2(1,j),
7282      &          AEAb2derx(1,lll,kkk,iii,1,2))
7283               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7284      &          AEAb1derx(1,lll,kkk,iii,2,2))
7285               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7286      &          AEAb2derx(1,lll,kkk,iii,2,2))
7287             enddo
7288           enddo
7289         enddo
7290         ENDIF
7291 C End vectors
7292       else
7293 C Antiparallel orientation of the two CA-CA-CA frames.
7294         if (i.gt.1) then
7295           iti=itortyp(itype(i))
7296         else
7297           iti=ntortyp+1
7298         endif
7299         itk1=itortyp(itype(k+1))
7300         itl=itortyp(itype(l))
7301         itj=itortyp(itype(j))
7302         if (j.lt.nres-1) then
7303           itj1=itortyp(itype(j+1))
7304         else
7305           itj1=ntortyp+1
7306         endif
7307 C A2 kernel(j-1)T A1T
7308         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7309      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7310      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7311 C Following matrices are needed only for 6-th order cumulants
7312         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7313      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7314         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7315      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7316      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7317         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7318      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7319      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7320      &   ADtEAderx(1,1,1,1,1,1))
7321         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7322      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7323      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7324      &   ADtEA1derx(1,1,1,1,1,1))
7325         ENDIF
7326 C End 6-th order cumulants
7327         call transpose2(EUgder(1,1,k),auxmat(1,1))
7328         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7329         call transpose2(EUg(1,1,k),auxmat(1,1))
7330         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7331         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7332         do iii=1,2
7333           do kkk=1,5
7334             do lll=1,3
7335               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7336      &          EAEAderx(1,1,lll,kkk,iii,1))
7337             enddo
7338           enddo
7339         enddo
7340 C A2T kernel(i+1)T A1
7341         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7342      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7343      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7344 C Following matrices are needed only for 6-th order cumulants
7345         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7346      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7347         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7348      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7349      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7350         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7351      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7352      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7353      &   ADtEAderx(1,1,1,1,1,2))
7354         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7355      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7356      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7357      &   ADtEA1derx(1,1,1,1,1,2))
7358         ENDIF
7359 C End 6-th order cumulants
7360         call transpose2(EUgder(1,1,j),auxmat(1,1))
7361         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7362         call transpose2(EUg(1,1,j),auxmat(1,1))
7363         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7364         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7365         do iii=1,2
7366           do kkk=1,5
7367             do lll=1,3
7368               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7369      &          EAEAderx(1,1,lll,kkk,iii,2))
7370             enddo
7371           enddo
7372         enddo
7373 C AEAb1 and AEAb2
7374 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7375 C They are needed only when the fifth- or the sixth-order cumulants are
7376 C indluded.
7377         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7378      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7379         call transpose2(AEA(1,1,1),auxmat(1,1))
7380         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7381         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7382         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7383         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7384         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7385         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7386         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7387         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7388         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7389         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7390         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7391         call transpose2(AEA(1,1,2),auxmat(1,1))
7392         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7393         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7394         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7395         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7396         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7397         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7398         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7399         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7400         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7401         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7402         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7403 C Calculate the Cartesian derivatives of the vectors.
7404         do iii=1,2
7405           do kkk=1,5
7406             do lll=1,3
7407               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7408               call matvec2(auxmat(1,1),b1(1,iti),
7409      &          AEAb1derx(1,lll,kkk,iii,1,1))
7410               call matvec2(auxmat(1,1),Ub2(1,i),
7411      &          AEAb2derx(1,lll,kkk,iii,1,1))
7412               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7413      &          AEAb1derx(1,lll,kkk,iii,2,1))
7414               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7415      &          AEAb2derx(1,lll,kkk,iii,2,1))
7416               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7417               call matvec2(auxmat(1,1),b1(1,itl),
7418      &          AEAb1derx(1,lll,kkk,iii,1,2))
7419               call matvec2(auxmat(1,1),Ub2(1,l),
7420      &          AEAb2derx(1,lll,kkk,iii,1,2))
7421               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7422      &          AEAb1derx(1,lll,kkk,iii,2,2))
7423               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7424      &          AEAb2derx(1,lll,kkk,iii,2,2))
7425             enddo
7426           enddo
7427         enddo
7428         ENDIF
7429 C End vectors
7430       endif
7431       return
7432       end
7433 C---------------------------------------------------------------------------
7434       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7435      &  KK,KKderg,AKA,AKAderg,AKAderx)
7436       implicit none
7437       integer nderg
7438       logical transp
7439       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7440      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7441      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7442       integer iii,kkk,lll
7443       integer jjj,mmm
7444       logical lprn
7445       common /kutas/ lprn
7446       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7447       do iii=1,nderg
7448         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7449      &    AKAderg(1,1,iii))
7450       enddo
7451 cd      if (lprn) write (2,*) 'In kernel'
7452       do kkk=1,5
7453 cd        if (lprn) write (2,*) 'kkk=',kkk
7454         do lll=1,3
7455           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7456      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7457 cd          if (lprn) then
7458 cd            write (2,*) 'lll=',lll
7459 cd            write (2,*) 'iii=1'
7460 cd            do jjj=1,2
7461 cd              write (2,'(3(2f10.5),5x)')
7462 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7463 cd            enddo
7464 cd          endif
7465           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7466      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7467 cd          if (lprn) then
7468 cd            write (2,*) 'lll=',lll
7469 cd            write (2,*) 'iii=2'
7470 cd            do jjj=1,2
7471 cd              write (2,'(3(2f10.5),5x)')
7472 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7473 cd            enddo
7474 cd          endif
7475         enddo
7476       enddo
7477       return
7478       end
7479 C---------------------------------------------------------------------------
7480       double precision function eello4(i,j,k,l,jj,kk)
7481       implicit real*8 (a-h,o-z)
7482       include 'DIMENSIONS'
7483       include 'COMMON.IOUNITS'
7484       include 'COMMON.CHAIN'
7485       include 'COMMON.DERIV'
7486       include 'COMMON.INTERACT'
7487       include 'COMMON.CONTACTS'
7488       include 'COMMON.TORSION'
7489       include 'COMMON.VAR'
7490       include 'COMMON.GEO'
7491       double precision pizda(2,2),ggg1(3),ggg2(3)
7492 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7493 cd        eello4=0.0d0
7494 cd        return
7495 cd      endif
7496 cd      print *,'eello4:',i,j,k,l,jj,kk
7497 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7498 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7499 cold      eij=facont_hb(jj,i)
7500 cold      ekl=facont_hb(kk,k)
7501 cold      ekont=eij*ekl
7502       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7503 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7504       gcorr_loc(k-1)=gcorr_loc(k-1)
7505      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7506       if (l.eq.j+1) then
7507         gcorr_loc(l-1)=gcorr_loc(l-1)
7508      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7509       else
7510         gcorr_loc(j-1)=gcorr_loc(j-1)
7511      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7512       endif
7513       do iii=1,2
7514         do kkk=1,5
7515           do lll=1,3
7516             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7517      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7518 cd            derx(lll,kkk,iii)=0.0d0
7519           enddo
7520         enddo
7521       enddo
7522 cd      gcorr_loc(l-1)=0.0d0
7523 cd      gcorr_loc(j-1)=0.0d0
7524 cd      gcorr_loc(k-1)=0.0d0
7525 cd      eel4=1.0d0
7526 cd      write (iout,*)'Contacts have occurred for peptide groups',
7527 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7528 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7529       if (j.lt.nres-1) then
7530         j1=j+1
7531         j2=j-1
7532       else
7533         j1=j-1
7534         j2=j-2
7535       endif
7536       if (l.lt.nres-1) then
7537         l1=l+1
7538         l2=l-1
7539       else
7540         l1=l-1
7541         l2=l-2
7542       endif
7543       do ll=1,3
7544 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7545 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7546         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7547         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7548 cgrad        ghalf=0.5d0*ggg1(ll)
7549         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7550         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7551         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7552         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7553         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7554         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7555 cgrad        ghalf=0.5d0*ggg2(ll)
7556         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7557         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7558         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7559         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7560         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7561         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7562       enddo
7563 cgrad      do m=i+1,j-1
7564 cgrad        do ll=1,3
7565 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7566 cgrad        enddo
7567 cgrad      enddo
7568 cgrad      do m=k+1,l-1
7569 cgrad        do ll=1,3
7570 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7571 cgrad        enddo
7572 cgrad      enddo
7573 cgrad      do m=i+2,j2
7574 cgrad        do ll=1,3
7575 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7576 cgrad        enddo
7577 cgrad      enddo
7578 cgrad      do m=k+2,l2
7579 cgrad        do ll=1,3
7580 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7581 cgrad        enddo
7582 cgrad      enddo
7583 cd      do iii=1,nres-3
7584 cd        write (2,*) iii,gcorr_loc(iii)
7585 cd      enddo
7586       eello4=ekont*eel4
7587 cd      write (2,*) 'ekont',ekont
7588 cd      write (iout,*) 'eello4',ekont*eel4
7589       return
7590       end
7591 C---------------------------------------------------------------------------
7592       double precision function eello5(i,j,k,l,jj,kk)
7593       implicit real*8 (a-h,o-z)
7594       include 'DIMENSIONS'
7595       include 'COMMON.IOUNITS'
7596       include 'COMMON.CHAIN'
7597       include 'COMMON.DERIV'
7598       include 'COMMON.INTERACT'
7599       include 'COMMON.CONTACTS'
7600       include 'COMMON.TORSION'
7601       include 'COMMON.VAR'
7602       include 'COMMON.GEO'
7603       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7604       double precision ggg1(3),ggg2(3)
7605 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7606 C                                                                              C
7607 C                            Parallel chains                                   C
7608 C                                                                              C
7609 C          o             o                   o             o                   C
7610 C         /l\           / \             \   / \           / \   /              C
7611 C        /   \         /   \             \ /   \         /   \ /               C
7612 C       j| o |l1       | o |              o| o |         | o |o                C
7613 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7614 C      \i/   \         /   \ /             /   \         /   \                 C
7615 C       o    k1             o                                                  C
7616 C         (I)          (II)                (III)          (IV)                 C
7617 C                                                                              C
7618 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7619 C                                                                              C
7620 C                            Antiparallel chains                               C
7621 C                                                                              C
7622 C          o             o                   o             o                   C
7623 C         /j\           / \             \   / \           / \   /              C
7624 C        /   \         /   \             \ /   \         /   \ /               C
7625 C      j1| o |l        | o |              o| o |         | o |o                C
7626 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7627 C      \i/   \         /   \ /             /   \         /   \                 C
7628 C       o     k1            o                                                  C
7629 C         (I)          (II)                (III)          (IV)                 C
7630 C                                                                              C
7631 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7632 C                                                                              C
7633 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7634 C                                                                              C
7635 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7636 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7637 cd        eello5=0.0d0
7638 cd        return
7639 cd      endif
7640 cd      write (iout,*)
7641 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7642 cd     &   ' and',k,l
7643       itk=itortyp(itype(k))
7644       itl=itortyp(itype(l))
7645       itj=itortyp(itype(j))
7646       eello5_1=0.0d0
7647       eello5_2=0.0d0
7648       eello5_3=0.0d0
7649       eello5_4=0.0d0
7650 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7651 cd     &   eel5_3_num,eel5_4_num)
7652       do iii=1,2
7653         do kkk=1,5
7654           do lll=1,3
7655             derx(lll,kkk,iii)=0.0d0
7656           enddo
7657         enddo
7658       enddo
7659 cd      eij=facont_hb(jj,i)
7660 cd      ekl=facont_hb(kk,k)
7661 cd      ekont=eij*ekl
7662 cd      write (iout,*)'Contacts have occurred for peptide groups',
7663 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7664 cd      goto 1111
7665 C Contribution from the graph I.
7666 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7667 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7668       call transpose2(EUg(1,1,k),auxmat(1,1))
7669       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7670       vv(1)=pizda(1,1)-pizda(2,2)
7671       vv(2)=pizda(1,2)+pizda(2,1)
7672       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7673      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7674 C Explicit gradient in virtual-dihedral angles.
7675       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7676      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7677      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7678       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7679       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7680       vv(1)=pizda(1,1)-pizda(2,2)
7681       vv(2)=pizda(1,2)+pizda(2,1)
7682       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7683      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7684      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7685       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7686       vv(1)=pizda(1,1)-pizda(2,2)
7687       vv(2)=pizda(1,2)+pizda(2,1)
7688       if (l.eq.j+1) then
7689         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7690      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7691      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7692       else
7693         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7694      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7695      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7696       endif
7697 C Cartesian gradient
7698       do iii=1,2
7699         do kkk=1,5
7700           do lll=1,3
7701             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7702      &        pizda(1,1))
7703             vv(1)=pizda(1,1)-pizda(2,2)
7704             vv(2)=pizda(1,2)+pizda(2,1)
7705             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7706      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7707      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7708           enddo
7709         enddo
7710       enddo
7711 c      goto 1112
7712 c1111  continue
7713 C Contribution from graph II
7714       call transpose2(EE(1,1,itk),auxmat(1,1))
7715       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7716       vv(1)=pizda(1,1)+pizda(2,2)
7717       vv(2)=pizda(2,1)-pizda(1,2)
7718       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7719      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7720 C Explicit gradient in virtual-dihedral angles.
7721       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7722      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7723       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7724       vv(1)=pizda(1,1)+pizda(2,2)
7725       vv(2)=pizda(2,1)-pizda(1,2)
7726       if (l.eq.j+1) then
7727         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7728      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7729      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7730       else
7731         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7732      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7733      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7734       endif
7735 C Cartesian gradient
7736       do iii=1,2
7737         do kkk=1,5
7738           do lll=1,3
7739             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7740      &        pizda(1,1))
7741             vv(1)=pizda(1,1)+pizda(2,2)
7742             vv(2)=pizda(2,1)-pizda(1,2)
7743             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7744      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7745      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7746           enddo
7747         enddo
7748       enddo
7749 cd      goto 1112
7750 cd1111  continue
7751       if (l.eq.j+1) then
7752 cd        goto 1110
7753 C Parallel orientation
7754 C Contribution from graph III
7755         call transpose2(EUg(1,1,l),auxmat(1,1))
7756         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7757         vv(1)=pizda(1,1)-pizda(2,2)
7758         vv(2)=pizda(1,2)+pizda(2,1)
7759         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7760      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7761 C Explicit gradient in virtual-dihedral angles.
7762         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7763      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7764      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7765         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7766         vv(1)=pizda(1,1)-pizda(2,2)
7767         vv(2)=pizda(1,2)+pizda(2,1)
7768         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7769      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7770      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7771         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7772         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7773         vv(1)=pizda(1,1)-pizda(2,2)
7774         vv(2)=pizda(1,2)+pizda(2,1)
7775         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7776      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7777      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7778 C Cartesian gradient
7779         do iii=1,2
7780           do kkk=1,5
7781             do lll=1,3
7782               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7783      &          pizda(1,1))
7784               vv(1)=pizda(1,1)-pizda(2,2)
7785               vv(2)=pizda(1,2)+pizda(2,1)
7786               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7787      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7788      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7789             enddo
7790           enddo
7791         enddo
7792 cd        goto 1112
7793 C Contribution from graph IV
7794 cd1110    continue
7795         call transpose2(EE(1,1,itl),auxmat(1,1))
7796         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7797         vv(1)=pizda(1,1)+pizda(2,2)
7798         vv(2)=pizda(2,1)-pizda(1,2)
7799         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7800      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7801 C Explicit gradient in virtual-dihedral angles.
7802         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7803      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7804         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7805         vv(1)=pizda(1,1)+pizda(2,2)
7806         vv(2)=pizda(2,1)-pizda(1,2)
7807         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7808      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7809      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7810 C Cartesian gradient
7811         do iii=1,2
7812           do kkk=1,5
7813             do lll=1,3
7814               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7815      &          pizda(1,1))
7816               vv(1)=pizda(1,1)+pizda(2,2)
7817               vv(2)=pizda(2,1)-pizda(1,2)
7818               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7819      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7820      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7821             enddo
7822           enddo
7823         enddo
7824       else
7825 C Antiparallel orientation
7826 C Contribution from graph III
7827 c        goto 1110
7828         call transpose2(EUg(1,1,j),auxmat(1,1))
7829         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7830         vv(1)=pizda(1,1)-pizda(2,2)
7831         vv(2)=pizda(1,2)+pizda(2,1)
7832         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7833      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7834 C Explicit gradient in virtual-dihedral angles.
7835         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7836      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7837      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7838         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7839         vv(1)=pizda(1,1)-pizda(2,2)
7840         vv(2)=pizda(1,2)+pizda(2,1)
7841         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7842      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7843      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7844         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7845         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7846         vv(1)=pizda(1,1)-pizda(2,2)
7847         vv(2)=pizda(1,2)+pizda(2,1)
7848         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7849      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7850      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7851 C Cartesian gradient
7852         do iii=1,2
7853           do kkk=1,5
7854             do lll=1,3
7855               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7856      &          pizda(1,1))
7857               vv(1)=pizda(1,1)-pizda(2,2)
7858               vv(2)=pizda(1,2)+pizda(2,1)
7859               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7860      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7861      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7862             enddo
7863           enddo
7864         enddo
7865 cd        goto 1112
7866 C Contribution from graph IV
7867 1110    continue
7868         call transpose2(EE(1,1,itj),auxmat(1,1))
7869         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7870         vv(1)=pizda(1,1)+pizda(2,2)
7871         vv(2)=pizda(2,1)-pizda(1,2)
7872         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7873      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7874 C Explicit gradient in virtual-dihedral angles.
7875         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7876      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7877         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7878         vv(1)=pizda(1,1)+pizda(2,2)
7879         vv(2)=pizda(2,1)-pizda(1,2)
7880         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7881      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7882      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7883 C Cartesian gradient
7884         do iii=1,2
7885           do kkk=1,5
7886             do lll=1,3
7887               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7888      &          pizda(1,1))
7889               vv(1)=pizda(1,1)+pizda(2,2)
7890               vv(2)=pizda(2,1)-pizda(1,2)
7891               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7892      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7893      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7894             enddo
7895           enddo
7896         enddo
7897       endif
7898 1112  continue
7899       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7900 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7901 cd        write (2,*) 'ijkl',i,j,k,l
7902 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7903 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7904 cd      endif
7905 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7906 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7907 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7908 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7909       if (j.lt.nres-1) then
7910         j1=j+1
7911         j2=j-1
7912       else
7913         j1=j-1
7914         j2=j-2
7915       endif
7916       if (l.lt.nres-1) then
7917         l1=l+1
7918         l2=l-1
7919       else
7920         l1=l-1
7921         l2=l-2
7922       endif
7923 cd      eij=1.0d0
7924 cd      ekl=1.0d0
7925 cd      ekont=1.0d0
7926 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7927 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7928 C        summed up outside the subrouine as for the other subroutines
7929 C        handling long-range interactions. The old code is commented out
7930 C        with "cgrad" to keep track of changes.
7931       do ll=1,3
7932 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7933 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7934         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7935         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7936 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7937 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7938 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7939 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7940 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7941 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7942 c     &   gradcorr5ij,
7943 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7944 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7945 cgrad        ghalf=0.5d0*ggg1(ll)
7946 cd        ghalf=0.0d0
7947         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7948         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7949         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7950         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7951         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7952         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7953 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7954 cgrad        ghalf=0.5d0*ggg2(ll)
7955 cd        ghalf=0.0d0
7956         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7957         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7958         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7959         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7960         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7961         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7962       enddo
7963 cd      goto 1112
7964 cgrad      do m=i+1,j-1
7965 cgrad        do ll=1,3
7966 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7967 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7968 cgrad        enddo
7969 cgrad      enddo
7970 cgrad      do m=k+1,l-1
7971 cgrad        do ll=1,3
7972 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7973 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7974 cgrad        enddo
7975 cgrad      enddo
7976 c1112  continue
7977 cgrad      do m=i+2,j2
7978 cgrad        do ll=1,3
7979 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7980 cgrad        enddo
7981 cgrad      enddo
7982 cgrad      do m=k+2,l2
7983 cgrad        do ll=1,3
7984 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7985 cgrad        enddo
7986 cgrad      enddo
7987 cd      do iii=1,nres-3
7988 cd        write (2,*) iii,g_corr5_loc(iii)
7989 cd      enddo
7990       eello5=ekont*eel5
7991 cd      write (2,*) 'ekont',ekont
7992 cd      write (iout,*) 'eello5',ekont*eel5
7993       return
7994       end
7995 c--------------------------------------------------------------------------
7996       double precision function eello6(i,j,k,l,jj,kk)
7997       implicit real*8 (a-h,o-z)
7998       include 'DIMENSIONS'
7999       include 'COMMON.IOUNITS'
8000       include 'COMMON.CHAIN'
8001       include 'COMMON.DERIV'
8002       include 'COMMON.INTERACT'
8003       include 'COMMON.CONTACTS'
8004       include 'COMMON.TORSION'
8005       include 'COMMON.VAR'
8006       include 'COMMON.GEO'
8007       include 'COMMON.FFIELD'
8008       double precision ggg1(3),ggg2(3)
8009 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8010 cd        eello6=0.0d0
8011 cd        return
8012 cd      endif
8013 cd      write (iout,*)
8014 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8015 cd     &   ' and',k,l
8016       eello6_1=0.0d0
8017       eello6_2=0.0d0
8018       eello6_3=0.0d0
8019       eello6_4=0.0d0
8020       eello6_5=0.0d0
8021       eello6_6=0.0d0
8022 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8023 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8024       do iii=1,2
8025         do kkk=1,5
8026           do lll=1,3
8027             derx(lll,kkk,iii)=0.0d0
8028           enddo
8029         enddo
8030       enddo
8031 cd      eij=facont_hb(jj,i)
8032 cd      ekl=facont_hb(kk,k)
8033 cd      ekont=eij*ekl
8034 cd      eij=1.0d0
8035 cd      ekl=1.0d0
8036 cd      ekont=1.0d0
8037       if (l.eq.j+1) then
8038         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8039         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8040         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8041         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8042         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8043         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8044       else
8045         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8046         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8047         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8048         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8049         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8050           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8051         else
8052           eello6_5=0.0d0
8053         endif
8054         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8055       endif
8056 C If turn contributions are considered, they will be handled separately.
8057       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8058 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8059 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8060 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8061 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8062 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8063 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8064 cd      goto 1112
8065       if (j.lt.nres-1) then
8066         j1=j+1
8067         j2=j-1
8068       else
8069         j1=j-1
8070         j2=j-2
8071       endif
8072       if (l.lt.nres-1) then
8073         l1=l+1
8074         l2=l-1
8075       else
8076         l1=l-1
8077         l2=l-2
8078       endif
8079       do ll=1,3
8080 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8081 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8082 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8083 cgrad        ghalf=0.5d0*ggg1(ll)
8084 cd        ghalf=0.0d0
8085         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8086         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8087         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8088         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8089         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8090         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8091         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8092         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8093 cgrad        ghalf=0.5d0*ggg2(ll)
8094 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8095 cd        ghalf=0.0d0
8096         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8097         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8098         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8099         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8100         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8101         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8102       enddo
8103 cd      goto 1112
8104 cgrad      do m=i+1,j-1
8105 cgrad        do ll=1,3
8106 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8107 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8108 cgrad        enddo
8109 cgrad      enddo
8110 cgrad      do m=k+1,l-1
8111 cgrad        do ll=1,3
8112 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8113 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8114 cgrad        enddo
8115 cgrad      enddo
8116 cgrad1112  continue
8117 cgrad      do m=i+2,j2
8118 cgrad        do ll=1,3
8119 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8120 cgrad        enddo
8121 cgrad      enddo
8122 cgrad      do m=k+2,l2
8123 cgrad        do ll=1,3
8124 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8125 cgrad        enddo
8126 cgrad      enddo
8127 cd      do iii=1,nres-3
8128 cd        write (2,*) iii,g_corr6_loc(iii)
8129 cd      enddo
8130       eello6=ekont*eel6
8131 cd      write (2,*) 'ekont',ekont
8132 cd      write (iout,*) 'eello6',ekont*eel6
8133       return
8134       end
8135 c--------------------------------------------------------------------------
8136       double precision function eello6_graph1(i,j,k,l,imat,swap)
8137       implicit real*8 (a-h,o-z)
8138       include 'DIMENSIONS'
8139       include 'COMMON.IOUNITS'
8140       include 'COMMON.CHAIN'
8141       include 'COMMON.DERIV'
8142       include 'COMMON.INTERACT'
8143       include 'COMMON.CONTACTS'
8144       include 'COMMON.TORSION'
8145       include 'COMMON.VAR'
8146       include 'COMMON.GEO'
8147       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8148       logical swap
8149       logical lprn
8150       common /kutas/ lprn
8151 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8152 C
8153 C      Parallel       Antiparallel
8154 C
8155 C          o             o
8156 C         /l\           /j\
8157 C        /   \         /   \
8158 C       /| o |         | o |\
8159 C     \ j|/k\|  /   \  |/k\|l /
8160 C      \ /   \ /     \ /   \ /
8161 C       o     o       o     o
8162 C       i             i
8163 C
8164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8165       itk=itortyp(itype(k))
8166       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8167       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8168       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8169       call transpose2(EUgC(1,1,k),auxmat(1,1))
8170       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8171       vv1(1)=pizda1(1,1)-pizda1(2,2)
8172       vv1(2)=pizda1(1,2)+pizda1(2,1)
8173       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8174       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8175       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8176       s5=scalar2(vv(1),Dtobr2(1,i))
8177 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8178       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8179       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8180      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8181      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8182      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8183      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8184      & +scalar2(vv(1),Dtobr2der(1,i)))
8185       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8186       vv1(1)=pizda1(1,1)-pizda1(2,2)
8187       vv1(2)=pizda1(1,2)+pizda1(2,1)
8188       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8189       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8190       if (l.eq.j+1) then
8191         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8192      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8193      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8194      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8195      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8196       else
8197         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8198      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8199      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8200      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8201      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8202       endif
8203       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8204       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8205       vv1(1)=pizda1(1,1)-pizda1(2,2)
8206       vv1(2)=pizda1(1,2)+pizda1(2,1)
8207       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8208      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8209      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8210      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8211       do iii=1,2
8212         if (swap) then
8213           ind=3-iii
8214         else
8215           ind=iii
8216         endif
8217         do kkk=1,5
8218           do lll=1,3
8219             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8220             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8221             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8222             call transpose2(EUgC(1,1,k),auxmat(1,1))
8223             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8224      &        pizda1(1,1))
8225             vv1(1)=pizda1(1,1)-pizda1(2,2)
8226             vv1(2)=pizda1(1,2)+pizda1(2,1)
8227             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8228             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8229      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8230             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8231      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8232             s5=scalar2(vv(1),Dtobr2(1,i))
8233             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8234           enddo
8235         enddo
8236       enddo
8237       return
8238       end
8239 c----------------------------------------------------------------------------
8240       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8241       implicit real*8 (a-h,o-z)
8242       include 'DIMENSIONS'
8243       include 'COMMON.IOUNITS'
8244       include 'COMMON.CHAIN'
8245       include 'COMMON.DERIV'
8246       include 'COMMON.INTERACT'
8247       include 'COMMON.CONTACTS'
8248       include 'COMMON.TORSION'
8249       include 'COMMON.VAR'
8250       include 'COMMON.GEO'
8251       logical swap
8252       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8253      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8254       logical lprn
8255       common /kutas/ lprn
8256 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8257 C                                                                              C
8258 C      Parallel       Antiparallel                                             C
8259 C                                                                              C
8260 C          o             o                                                     C
8261 C     \   /l\           /j\   /                                                C
8262 C      \ /   \         /   \ /                                                 C
8263 C       o| o |         | o |o                                                  C
8264 C     \ j|/k\|      \  |/k\|l                                                  C
8265 C      \ /   \       \ /   \                                                   C
8266 C       o             o                                                        C
8267 C       i             i                                                        C
8268 C                                                                              C
8269 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8270 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8271 C AL 7/4/01 s1 would occur in the sixth-order moment,
8272 C           but not in a cluster cumulant
8273 #ifdef MOMENT
8274       s1=dip(1,jj,i)*dip(1,kk,k)
8275 #endif
8276       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8277       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8278       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8279       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8280       call transpose2(EUg(1,1,k),auxmat(1,1))
8281       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8282       vv(1)=pizda(1,1)-pizda(2,2)
8283       vv(2)=pizda(1,2)+pizda(2,1)
8284       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8285 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8286 #ifdef MOMENT
8287       eello6_graph2=-(s1+s2+s3+s4)
8288 #else
8289       eello6_graph2=-(s2+s3+s4)
8290 #endif
8291 c      eello6_graph2=-s3
8292 C Derivatives in gamma(i-1)
8293       if (i.gt.1) then
8294 #ifdef MOMENT
8295         s1=dipderg(1,jj,i)*dip(1,kk,k)
8296 #endif
8297         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8298         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8299         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8300         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8301 #ifdef MOMENT
8302         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8303 #else
8304         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8305 #endif
8306 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8307       endif
8308 C Derivatives in gamma(k-1)
8309 #ifdef MOMENT
8310       s1=dip(1,jj,i)*dipderg(1,kk,k)
8311 #endif
8312       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8313       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8314       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8315       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8316       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8317       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8318       vv(1)=pizda(1,1)-pizda(2,2)
8319       vv(2)=pizda(1,2)+pizda(2,1)
8320       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8321 #ifdef MOMENT
8322       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8323 #else
8324       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8325 #endif
8326 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8327 C Derivatives in gamma(j-1) or gamma(l-1)
8328       if (j.gt.1) then
8329 #ifdef MOMENT
8330         s1=dipderg(3,jj,i)*dip(1,kk,k)
8331 #endif
8332         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8333         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8334         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8335         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8336         vv(1)=pizda(1,1)-pizda(2,2)
8337         vv(2)=pizda(1,2)+pizda(2,1)
8338         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8339 #ifdef MOMENT
8340         if (swap) then
8341           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8342         else
8343           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8344         endif
8345 #endif
8346         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8347 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8348       endif
8349 C Derivatives in gamma(l-1) or gamma(j-1)
8350       if (l.gt.1) then
8351 #ifdef MOMENT
8352         s1=dip(1,jj,i)*dipderg(3,kk,k)
8353 #endif
8354         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8355         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8356         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8357         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8358         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8359         vv(1)=pizda(1,1)-pizda(2,2)
8360         vv(2)=pizda(1,2)+pizda(2,1)
8361         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8362 #ifdef MOMENT
8363         if (swap) then
8364           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8365         else
8366           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8367         endif
8368 #endif
8369         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8370 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8371       endif
8372 C Cartesian derivatives.
8373       if (lprn) then
8374         write (2,*) 'In eello6_graph2'
8375         do iii=1,2
8376           write (2,*) 'iii=',iii
8377           do kkk=1,5
8378             write (2,*) 'kkk=',kkk
8379             do jjj=1,2
8380               write (2,'(3(2f10.5),5x)')
8381      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8382             enddo
8383           enddo
8384         enddo
8385       endif
8386       do iii=1,2
8387         do kkk=1,5
8388           do lll=1,3
8389 #ifdef MOMENT
8390             if (iii.eq.1) then
8391               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8392             else
8393               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8394             endif
8395 #endif
8396             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8397      &        auxvec(1))
8398             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8399             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8400      &        auxvec(1))
8401             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8402             call transpose2(EUg(1,1,k),auxmat(1,1))
8403             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8404      &        pizda(1,1))
8405             vv(1)=pizda(1,1)-pizda(2,2)
8406             vv(2)=pizda(1,2)+pizda(2,1)
8407             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8408 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8409 #ifdef MOMENT
8410             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8411 #else
8412             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8413 #endif
8414             if (swap) then
8415               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8416             else
8417               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8418             endif
8419           enddo
8420         enddo
8421       enddo
8422       return
8423       end
8424 c----------------------------------------------------------------------------
8425       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8426       implicit real*8 (a-h,o-z)
8427       include 'DIMENSIONS'
8428       include 'COMMON.IOUNITS'
8429       include 'COMMON.CHAIN'
8430       include 'COMMON.DERIV'
8431       include 'COMMON.INTERACT'
8432       include 'COMMON.CONTACTS'
8433       include 'COMMON.TORSION'
8434       include 'COMMON.VAR'
8435       include 'COMMON.GEO'
8436       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8437       logical swap
8438 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8439 C                                                                              C
8440 C      Parallel       Antiparallel                                             C
8441 C                                                                              C
8442 C          o             o                                                     C
8443 C         /l\   /   \   /j\                                                    C
8444 C        /   \ /     \ /   \                                                   C
8445 C       /| o |o       o| o |\                                                  C
8446 C       j|/k\|  /      |/k\|l /                                                C
8447 C        /   \ /       /   \ /                                                 C
8448 C       /     o       /     o                                                  C
8449 C       i             i                                                        C
8450 C                                                                              C
8451 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8452 C
8453 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8454 C           energy moment and not to the cluster cumulant.
8455       iti=itortyp(itype(i))
8456       if (j.lt.nres-1) then
8457         itj1=itortyp(itype(j+1))
8458       else
8459         itj1=ntortyp+1
8460       endif
8461       itk=itortyp(itype(k))
8462       itk1=itortyp(itype(k+1))
8463       if (l.lt.nres-1) then
8464         itl1=itortyp(itype(l+1))
8465       else
8466         itl1=ntortyp+1
8467       endif
8468 #ifdef MOMENT
8469       s1=dip(4,jj,i)*dip(4,kk,k)
8470 #endif
8471       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8472       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8473       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8474       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8475       call transpose2(EE(1,1,itk),auxmat(1,1))
8476       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8477       vv(1)=pizda(1,1)+pizda(2,2)
8478       vv(2)=pizda(2,1)-pizda(1,2)
8479       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8480 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8481 cd     & "sum",-(s2+s3+s4)
8482 #ifdef MOMENT
8483       eello6_graph3=-(s1+s2+s3+s4)
8484 #else
8485       eello6_graph3=-(s2+s3+s4)
8486 #endif
8487 c      eello6_graph3=-s4
8488 C Derivatives in gamma(k-1)
8489       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8490       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8491       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8492       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8493 C Derivatives in gamma(l-1)
8494       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8495       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8496       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8497       vv(1)=pizda(1,1)+pizda(2,2)
8498       vv(2)=pizda(2,1)-pizda(1,2)
8499       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8500       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8501 C Cartesian derivatives.
8502       do iii=1,2
8503         do kkk=1,5
8504           do lll=1,3
8505 #ifdef MOMENT
8506             if (iii.eq.1) then
8507               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8508             else
8509               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8510             endif
8511 #endif
8512             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8513      &        auxvec(1))
8514             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8515             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8516      &        auxvec(1))
8517             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8518             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8519      &        pizda(1,1))
8520             vv(1)=pizda(1,1)+pizda(2,2)
8521             vv(2)=pizda(2,1)-pizda(1,2)
8522             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8523 #ifdef MOMENT
8524             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8525 #else
8526             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8527 #endif
8528             if (swap) then
8529               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8530             else
8531               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8532             endif
8533 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8534           enddo
8535         enddo
8536       enddo
8537       return
8538       end
8539 c----------------------------------------------------------------------------
8540       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8541       implicit real*8 (a-h,o-z)
8542       include 'DIMENSIONS'
8543       include 'COMMON.IOUNITS'
8544       include 'COMMON.CHAIN'
8545       include 'COMMON.DERIV'
8546       include 'COMMON.INTERACT'
8547       include 'COMMON.CONTACTS'
8548       include 'COMMON.TORSION'
8549       include 'COMMON.VAR'
8550       include 'COMMON.GEO'
8551       include 'COMMON.FFIELD'
8552       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8553      & auxvec1(2),auxmat1(2,2)
8554       logical swap
8555 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8556 C                                                                              C
8557 C      Parallel       Antiparallel                                             C
8558 C                                                                              C
8559 C          o             o                                                     C
8560 C         /l\   /   \   /j\                                                    C
8561 C        /   \ /     \ /   \                                                   C
8562 C       /| o |o       o| o |\                                                  C
8563 C     \ j|/k\|      \  |/k\|l                                                  C
8564 C      \ /   \       \ /   \                                                   C
8565 C       o     \       o     \                                                  C
8566 C       i             i                                                        C
8567 C                                                                              C
8568 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8569 C
8570 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8571 C           energy moment and not to the cluster cumulant.
8572 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8573       iti=itortyp(itype(i))
8574       itj=itortyp(itype(j))
8575       if (j.lt.nres-1) then
8576         itj1=itortyp(itype(j+1))
8577       else
8578         itj1=ntortyp+1
8579       endif
8580       itk=itortyp(itype(k))
8581       if (k.lt.nres-1) then
8582         itk1=itortyp(itype(k+1))
8583       else
8584         itk1=ntortyp+1
8585       endif
8586       itl=itortyp(itype(l))
8587       if (l.lt.nres-1) then
8588         itl1=itortyp(itype(l+1))
8589       else
8590         itl1=ntortyp+1
8591       endif
8592 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8593 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8594 cd     & ' itl',itl,' itl1',itl1
8595 #ifdef MOMENT
8596       if (imat.eq.1) then
8597         s1=dip(3,jj,i)*dip(3,kk,k)
8598       else
8599         s1=dip(2,jj,j)*dip(2,kk,l)
8600       endif
8601 #endif
8602       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8603       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8604       if (j.eq.l+1) then
8605         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8606         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8607       else
8608         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8609         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8610       endif
8611       call transpose2(EUg(1,1,k),auxmat(1,1))
8612       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8613       vv(1)=pizda(1,1)-pizda(2,2)
8614       vv(2)=pizda(2,1)+pizda(1,2)
8615       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8616 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8617 #ifdef MOMENT
8618       eello6_graph4=-(s1+s2+s3+s4)
8619 #else
8620       eello6_graph4=-(s2+s3+s4)
8621 #endif
8622 C Derivatives in gamma(i-1)
8623       if (i.gt.1) then
8624 #ifdef MOMENT
8625         if (imat.eq.1) then
8626           s1=dipderg(2,jj,i)*dip(3,kk,k)
8627         else
8628           s1=dipderg(4,jj,j)*dip(2,kk,l)
8629         endif
8630 #endif
8631         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8632         if (j.eq.l+1) then
8633           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8634           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8635         else
8636           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8637           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8638         endif
8639         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8640         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8641 cd          write (2,*) 'turn6 derivatives'
8642 #ifdef MOMENT
8643           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8644 #else
8645           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8646 #endif
8647         else
8648 #ifdef MOMENT
8649           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8650 #else
8651           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8652 #endif
8653         endif
8654       endif
8655 C Derivatives in gamma(k-1)
8656 #ifdef MOMENT
8657       if (imat.eq.1) then
8658         s1=dip(3,jj,i)*dipderg(2,kk,k)
8659       else
8660         s1=dip(2,jj,j)*dipderg(4,kk,l)
8661       endif
8662 #endif
8663       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8664       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8665       if (j.eq.l+1) then
8666         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8667         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8668       else
8669         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8670         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8671       endif
8672       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8673       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8674       vv(1)=pizda(1,1)-pizda(2,2)
8675       vv(2)=pizda(2,1)+pizda(1,2)
8676       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8677       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8678 #ifdef MOMENT
8679         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8680 #else
8681         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8682 #endif
8683       else
8684 #ifdef MOMENT
8685         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8686 #else
8687         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8688 #endif
8689       endif
8690 C Derivatives in gamma(j-1) or gamma(l-1)
8691       if (l.eq.j+1 .and. l.gt.1) then
8692         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8693         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8694         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8695         vv(1)=pizda(1,1)-pizda(2,2)
8696         vv(2)=pizda(2,1)+pizda(1,2)
8697         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8698         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8699       else if (j.gt.1) then
8700         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8701         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8702         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8703         vv(1)=pizda(1,1)-pizda(2,2)
8704         vv(2)=pizda(2,1)+pizda(1,2)
8705         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8706         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8707           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8708         else
8709           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8710         endif
8711       endif
8712 C Cartesian derivatives.
8713       do iii=1,2
8714         do kkk=1,5
8715           do lll=1,3
8716 #ifdef MOMENT
8717             if (iii.eq.1) then
8718               if (imat.eq.1) then
8719                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8720               else
8721                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8722               endif
8723             else
8724               if (imat.eq.1) then
8725                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8726               else
8727                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8728               endif
8729             endif
8730 #endif
8731             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8732      &        auxvec(1))
8733             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8734             if (j.eq.l+1) then
8735               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8736      &          b1(1,itj1),auxvec(1))
8737               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8738             else
8739               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8740      &          b1(1,itl1),auxvec(1))
8741               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8742             endif
8743             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8744      &        pizda(1,1))
8745             vv(1)=pizda(1,1)-pizda(2,2)
8746             vv(2)=pizda(2,1)+pizda(1,2)
8747             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8748             if (swap) then
8749               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8750 #ifdef MOMENT
8751                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8752      &             -(s1+s2+s4)
8753 #else
8754                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8755      &             -(s2+s4)
8756 #endif
8757                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8758               else
8759 #ifdef MOMENT
8760                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8761 #else
8762                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8763 #endif
8764                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8765               endif
8766             else
8767 #ifdef MOMENT
8768               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8769 #else
8770               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8771 #endif
8772               if (l.eq.j+1) then
8773                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8774               else
8775                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8776               endif
8777             endif
8778           enddo
8779         enddo
8780       enddo
8781       return
8782       end
8783 c----------------------------------------------------------------------------
8784       double precision function eello_turn6(i,jj,kk)
8785       implicit real*8 (a-h,o-z)
8786       include 'DIMENSIONS'
8787       include 'COMMON.IOUNITS'
8788       include 'COMMON.CHAIN'
8789       include 'COMMON.DERIV'
8790       include 'COMMON.INTERACT'
8791       include 'COMMON.CONTACTS'
8792       include 'COMMON.TORSION'
8793       include 'COMMON.VAR'
8794       include 'COMMON.GEO'
8795       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8796      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8797      &  ggg1(3),ggg2(3)
8798       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8799      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8800 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8801 C           the respective energy moment and not to the cluster cumulant.
8802       s1=0.0d0
8803       s8=0.0d0
8804       s13=0.0d0
8805 c
8806       eello_turn6=0.0d0
8807       j=i+4
8808       k=i+1
8809       l=i+3
8810       iti=itortyp(itype(i))
8811       itk=itortyp(itype(k))
8812       itk1=itortyp(itype(k+1))
8813       itl=itortyp(itype(l))
8814       itj=itortyp(itype(j))
8815 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8816 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8817 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8818 cd        eello6=0.0d0
8819 cd        return
8820 cd      endif
8821 cd      write (iout,*)
8822 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8823 cd     &   ' and',k,l
8824 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8825       do iii=1,2
8826         do kkk=1,5
8827           do lll=1,3
8828             derx_turn(lll,kkk,iii)=0.0d0
8829           enddo
8830         enddo
8831       enddo
8832 cd      eij=1.0d0
8833 cd      ekl=1.0d0
8834 cd      ekont=1.0d0
8835       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8836 cd      eello6_5=0.0d0
8837 cd      write (2,*) 'eello6_5',eello6_5
8838 #ifdef MOMENT
8839       call transpose2(AEA(1,1,1),auxmat(1,1))
8840       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8841       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8842       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8843 #endif
8844       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8845       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8846       s2 = scalar2(b1(1,itk),vtemp1(1))
8847 #ifdef MOMENT
8848       call transpose2(AEA(1,1,2),atemp(1,1))
8849       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8850       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8851       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8852 #endif
8853       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8854       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8855       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8856 #ifdef MOMENT
8857       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8858       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8859       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8860       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8861       ss13 = scalar2(b1(1,itk),vtemp4(1))
8862       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8863 #endif
8864 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8865 c      s1=0.0d0
8866 c      s2=0.0d0
8867 c      s8=0.0d0
8868 c      s12=0.0d0
8869 c      s13=0.0d0
8870       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8871 C Derivatives in gamma(i+2)
8872       s1d =0.0d0
8873       s8d =0.0d0
8874 #ifdef MOMENT
8875       call transpose2(AEA(1,1,1),auxmatd(1,1))
8876       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8877       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8878       call transpose2(AEAderg(1,1,2),atempd(1,1))
8879       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8880       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8881 #endif
8882       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8883       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8884       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8885 c      s1d=0.0d0
8886 c      s2d=0.0d0
8887 c      s8d=0.0d0
8888 c      s12d=0.0d0
8889 c      s13d=0.0d0
8890       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8891 C Derivatives in gamma(i+3)
8892 #ifdef MOMENT
8893       call transpose2(AEA(1,1,1),auxmatd(1,1))
8894       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8895       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8896       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8897 #endif
8898       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8899       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8900       s2d = scalar2(b1(1,itk),vtemp1d(1))
8901 #ifdef MOMENT
8902       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8903       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8904 #endif
8905       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8906 #ifdef MOMENT
8907       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8908       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8909       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8910 #endif
8911 c      s1d=0.0d0
8912 c      s2d=0.0d0
8913 c      s8d=0.0d0
8914 c      s12d=0.0d0
8915 c      s13d=0.0d0
8916 #ifdef MOMENT
8917       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8918      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8919 #else
8920       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8921      &               -0.5d0*ekont*(s2d+s12d)
8922 #endif
8923 C Derivatives in gamma(i+4)
8924       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8925       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8926       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8927 #ifdef MOMENT
8928       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8929       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8930       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8931 #endif
8932 c      s1d=0.0d0
8933 c      s2d=0.0d0
8934 c      s8d=0.0d0
8935 C      s12d=0.0d0
8936 c      s13d=0.0d0
8937 #ifdef MOMENT
8938       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8939 #else
8940       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8941 #endif
8942 C Derivatives in gamma(i+5)
8943 #ifdef MOMENT
8944       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8945       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8946       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8947 #endif
8948       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8949       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8950       s2d = scalar2(b1(1,itk),vtemp1d(1))
8951 #ifdef MOMENT
8952       call transpose2(AEA(1,1,2),atempd(1,1))
8953       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8954       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8955 #endif
8956       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8957       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8958 #ifdef MOMENT
8959       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8960       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8961       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8962 #endif
8963 c      s1d=0.0d0
8964 c      s2d=0.0d0
8965 c      s8d=0.0d0
8966 c      s12d=0.0d0
8967 c      s13d=0.0d0
8968 #ifdef MOMENT
8969       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8970      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8971 #else
8972       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8973      &               -0.5d0*ekont*(s2d+s12d)
8974 #endif
8975 C Cartesian derivatives
8976       do iii=1,2
8977         do kkk=1,5
8978           do lll=1,3
8979 #ifdef MOMENT
8980             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8981             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8982             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8983 #endif
8984             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8985             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8986      &          vtemp1d(1))
8987             s2d = scalar2(b1(1,itk),vtemp1d(1))
8988 #ifdef MOMENT
8989             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8990             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8991             s8d = -(atempd(1,1)+atempd(2,2))*
8992      &           scalar2(cc(1,1,itl),vtemp2(1))
8993 #endif
8994             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8995      &           auxmatd(1,1))
8996             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8997             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8998 c      s1d=0.0d0
8999 c      s2d=0.0d0
9000 c      s8d=0.0d0
9001 c      s12d=0.0d0
9002 c      s13d=0.0d0
9003 #ifdef MOMENT
9004             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9005      &        - 0.5d0*(s1d+s2d)
9006 #else
9007             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9008      &        - 0.5d0*s2d
9009 #endif
9010 #ifdef MOMENT
9011             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9012      &        - 0.5d0*(s8d+s12d)
9013 #else
9014             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9015      &        - 0.5d0*s12d
9016 #endif
9017           enddo
9018         enddo
9019       enddo
9020 #ifdef MOMENT
9021       do kkk=1,5
9022         do lll=1,3
9023           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9024      &      achuj_tempd(1,1))
9025           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9026           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9027           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9028           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9029           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9030      &      vtemp4d(1))
9031           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9032           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9033           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9034         enddo
9035       enddo
9036 #endif
9037 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9038 cd     &  16*eel_turn6_num
9039 cd      goto 1112
9040       if (j.lt.nres-1) then
9041         j1=j+1
9042         j2=j-1
9043       else
9044         j1=j-1
9045         j2=j-2
9046       endif
9047       if (l.lt.nres-1) then
9048         l1=l+1
9049         l2=l-1
9050       else
9051         l1=l-1
9052         l2=l-2
9053       endif
9054       do ll=1,3
9055 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9056 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9057 cgrad        ghalf=0.5d0*ggg1(ll)
9058 cd        ghalf=0.0d0
9059         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9060         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9061         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9062      &    +ekont*derx_turn(ll,2,1)
9063         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9064         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9065      &    +ekont*derx_turn(ll,4,1)
9066         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9067         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9068         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9069 cgrad        ghalf=0.5d0*ggg2(ll)
9070 cd        ghalf=0.0d0
9071         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9072      &    +ekont*derx_turn(ll,2,2)
9073         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9074         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9075      &    +ekont*derx_turn(ll,4,2)
9076         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9077         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9078         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9079       enddo
9080 cd      goto 1112
9081 cgrad      do m=i+1,j-1
9082 cgrad        do ll=1,3
9083 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9084 cgrad        enddo
9085 cgrad      enddo
9086 cgrad      do m=k+1,l-1
9087 cgrad        do ll=1,3
9088 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9089 cgrad        enddo
9090 cgrad      enddo
9091 cgrad1112  continue
9092 cgrad      do m=i+2,j2
9093 cgrad        do ll=1,3
9094 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9095 cgrad        enddo
9096 cgrad      enddo
9097 cgrad      do m=k+2,l2
9098 cgrad        do ll=1,3
9099 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9100 cgrad        enddo
9101 cgrad      enddo
9102 cd      do iii=1,nres-3
9103 cd        write (2,*) iii,g_corr6_loc(iii)
9104 cd      enddo
9105       eello_turn6=ekont*eel_turn6
9106 cd      write (2,*) 'ekont',ekont
9107 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9108       return
9109       end
9110
9111 C-----------------------------------------------------------------------------
9112       double precision function scalar(u,v)
9113 !DIR$ INLINEALWAYS scalar
9114 #ifndef OSF
9115 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9116 #endif
9117       implicit none
9118       double precision u(3),v(3)
9119 cd      double precision sc
9120 cd      integer i
9121 cd      sc=0.0d0
9122 cd      do i=1,3
9123 cd        sc=sc+u(i)*v(i)
9124 cd      enddo
9125 cd      scalar=sc
9126
9127       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9128       return
9129       end
9130 crc-------------------------------------------------
9131       SUBROUTINE MATVEC2(A1,V1,V2)
9132 !DIR$ INLINEALWAYS MATVEC2
9133 #ifndef OSF
9134 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9135 #endif
9136       implicit real*8 (a-h,o-z)
9137       include 'DIMENSIONS'
9138       DIMENSION A1(2,2),V1(2),V2(2)
9139 c      DO 1 I=1,2
9140 c        VI=0.0
9141 c        DO 3 K=1,2
9142 c    3     VI=VI+A1(I,K)*V1(K)
9143 c        Vaux(I)=VI
9144 c    1 CONTINUE
9145
9146       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9147       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9148
9149       v2(1)=vaux1
9150       v2(2)=vaux2
9151       END
9152 C---------------------------------------
9153       SUBROUTINE MATMAT2(A1,A2,A3)
9154 #ifndef OSF
9155 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9156 #endif
9157       implicit real*8 (a-h,o-z)
9158       include 'DIMENSIONS'
9159       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9160 c      DIMENSION AI3(2,2)
9161 c        DO  J=1,2
9162 c          A3IJ=0.0
9163 c          DO K=1,2
9164 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9165 c          enddo
9166 c          A3(I,J)=A3IJ
9167 c       enddo
9168 c      enddo
9169
9170       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9171       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9172       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9173       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9174
9175       A3(1,1)=AI3_11
9176       A3(2,1)=AI3_21
9177       A3(1,2)=AI3_12
9178       A3(2,2)=AI3_22
9179       END
9180
9181 c-------------------------------------------------------------------------
9182       double precision function scalar2(u,v)
9183 !DIR$ INLINEALWAYS scalar2
9184       implicit none
9185       double precision u(2),v(2)
9186       double precision sc
9187       integer i
9188       scalar2=u(1)*v(1)+u(2)*v(2)
9189       return
9190       end
9191
9192 C-----------------------------------------------------------------------------
9193
9194       subroutine transpose2(a,at)
9195 !DIR$ INLINEALWAYS transpose2
9196 #ifndef OSF
9197 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9198 #endif
9199       implicit none
9200       double precision a(2,2),at(2,2)
9201       at(1,1)=a(1,1)
9202       at(1,2)=a(2,1)
9203       at(2,1)=a(1,2)
9204       at(2,2)=a(2,2)
9205       return
9206       end
9207 c--------------------------------------------------------------------------
9208       subroutine transpose(n,a,at)
9209       implicit none
9210       integer n,i,j
9211       double precision a(n,n),at(n,n)
9212       do i=1,n
9213         do j=1,n
9214           at(j,i)=a(i,j)
9215         enddo
9216       enddo
9217       return
9218       end
9219 C---------------------------------------------------------------------------
9220       subroutine prodmat3(a1,a2,kk,transp,prod)
9221 !DIR$ INLINEALWAYS prodmat3
9222 #ifndef OSF
9223 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9224 #endif
9225       implicit none
9226       integer i,j
9227       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9228       logical transp
9229 crc      double precision auxmat(2,2),prod_(2,2)
9230
9231       if (transp) then
9232 crc        call transpose2(kk(1,1),auxmat(1,1))
9233 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9234 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9235
9236            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9237      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9238            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9239      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9240            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9241      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9242            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9243      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9244
9245       else
9246 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9247 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9248
9249            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9250      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9251            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9252      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9253            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9254      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9255            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9256      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9257
9258       endif
9259 c      call transpose2(a2(1,1),a2t(1,1))
9260
9261 crc      print *,transp
9262 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9263 crc      print *,((prod(i,j),i=1,2),j=1,2)
9264
9265       return
9266       end
9267